expiring-cache-map 0.0.5.0 → 0.0.5.3

raw patch · 12 files changed

+721/−240 lines, 12 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Caching/ExpiringCacheMap/HashECM.hs +113/−33
• Caching/ExpiringCacheMap/Internal/Internal.hs +108/−39
• Caching/ExpiringCacheMap/Internal/Types.hs +3/−2
• Caching/ExpiringCacheMap/OrdECM.hs +114/−33
• Caching/ExpiringCacheMap/Types.hs +14/−1
• Caching/ExpiringCacheMap/Utils/TestSequence.hs +16/−4
• expiring-cache-map.cabal +2/−1
• tests/TestECMWithTestSequenceCommon.hs +116/−0
• tests/TestHashECMWithTestSequence.hs +58/−37
• tests/TestHashECMWithThreads.hs +60/−27
• tests/TestOrdECMWithTestSequence.hs +58/−36
• tests/TestOrdECMWithThreads.hs +59/−27

@@ -13,7 +13,6 @@ -- An example of creating a cache for accessing files:
 --
 -- > {-# LANGUAGE OverloadedStrings #-}
--- > module Example where
 -- > 
 -- > import Caching.ExpiringCacheMap.HashECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)
 -- > 
@@ -33,10 +32,10 @@ -- >                                         return $! (state, content)))
 -- >         (do time <- POSIX.getPOSIXTime
 -- >             return (round (time * 100)))
--- >         12000 -- Time check frequency: (accumulator `mod` this_number) == 0.
+-- >         1 -- Time check frequency: (accumulator `mod` this_number) == 0.
 -- >         (CacheWithLRUList
 -- >           6     -- Expected size of key-value map when removing elements.
--- >           6     -- Size of list when to remove items from key-value map.
+-- >           6     -- Size of map when to remove items from key-value map.
 -- >           12    -- Size of list when to compact
 -- >           )
 -- >   
@@ -57,6 +56,13 @@     -- * Request value from cache
     lookupECM,
     
+    -- * Value request function state
+    -- putValReqState,
+    getValReqState,
+    
+    -- -- * Clear cache
+    -- clearCache,
+    
     -- * Type
     ECM,
     CacheSettings(..)
@@ -74,7 +80,16 @@ -- | Create a new expiring cache for retrieving uncached values via 'IO'
 -- interaction (such as in the case of reading a file from disk), with 
 -- a shared state lock via an 'MV.MVar' to manage cache state.
+--
+-- Value request and time check request functions are provided as arguments.
+--
+-- The time check frequency value has to be 1 or higher, with higher values
+-- postponing time checks for longer periods of time.
 -- 
+-- A cache setting specifies how the cache should remove entries when the
+-- cache becomes a certain size. The only constructor for this is
+-- 'CacheWithLRUList'.
+--
 newECMIO :: (Eq k, Hashable k) => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits)
   -> ECMIncr 
   -> CacheSettings
@@ -87,6 +102,23 @@ -- functions to create cache state in 'Monad' m2, and modify and read
 -- cache state in 'Monad' m1.
 --
+-- 'newECMIO' is just a wrapper to this function with 'MV.MVar' functions:
+--
+-- @
+--  newECMIO retr gettime timecheckmodulo cachesettings =
+--    newECMForM retr gettime timecheckmodulo cachesettings
+--      'MV.newMVar' 'MV.modifyMVar' 'MV.readMVar'
+-- @
+--
+-- Value request and time check request functions are provided as arguments.
+--
+-- The time check frequency value has to be 1 or higher, with higher values
+-- postponing time checks for longer periods of time.
+-- 
+-- A cache setting specifies how the cache should remove entries when the
+-- cache becomes a certain size. The only constructor for this is
+-- 'CacheWithLRUList'.
+--
 newECMForM :: (Monad m1, Monad m2) => (Eq k, Hashable k) => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits)
   -> ECMIncr 
   -> CacheSettings
@@ -95,11 +127,14 @@   -> ECMReadState m1 mv s HM.HashMap k v
     -> m2 (ECM m1 mv s HM.HashMap k v)
 newECMForM retr gettime timecheckmodulo (CacheWithLRUList minimumkeep removalsize compactlistsize)
-           newstate enterstate readstate = do
-  m'maps <- newstate $ CacheState ( Nothing, HM.empty, ([], 0), 0 )
-  return $ ECM ( m'maps, retr, gettime, minimumkeep, 
-                 timecheckmodulo, removalsize, compactlistsize,
-                 enterstate, readstate )
+           newstate enterstate readstate =
+  if timecheckmodulo <= 0
+    then error "Modulo time check must be 1 or higher."
+    else do
+      m'maps <- newstate $ CacheState ( Nothing, HM.empty, 0, ([], 0), 0 )
+      return $ ECM ( m'maps, retr, gettime, minimumkeep, 
+                     timecheckmodulo, removalsize, compactlistsize,
+                     enterstate, readstate )
 
 
 -- | Request a value associated with a key from the cache.
@@ -115,54 +150,99 @@ --    will be discarded and a new value will be requested for this computation.
 --
 -- Every 'lookupECM' computation increments an accumulator in the cache state
--- which is used to keep track of the succession of key accesses. This history 
+-- which is used to keep track of the succession of key accesses. Based on the
+-- parameters provided with the 'CacheWithLRUList' constructor, this history 
 -- of key accesses is then used to remove entries from the cache back down to 
 -- a minimum size. Also, when the modulo of the accumulator and the modulo 
--- value computes to 0, the time request function defined when the 'ECM' value
--- was created is invoked for the current time to determine of which if any of
--- the entries in the cache state map needs to be removed. In some cases the 
+-- value computes to 0, the time request function is invoked. In some cases the 
 -- accumulator may get incremented more than once in a 'lookupECM' computation.
 --
 -- As the accumulator is a bound unsigned integer, when the accumulator
 -- increments back to 0, the cache state is completely cleared.
+--
+-- The time request function is invoked in one of two different conditions
 -- 
+--  * When a new key-value entry is requested, the current time is also
+--    requested during the same lookup, as a recent time determination is
+--    needed for a new entry in the key-value cache.
+-- 
+--  * When the modulo of the accumulator and a specified value equals to 0.
+--
+-- When the current time is determined during a lookup, access times of the
+-- entries in the key-value cache are compared with the new time to filter
+-- out expired entries from the key-value map.
+-- 
 lookupECM :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m v
 lookupECM ecm id = do
   enter m'maps $
-    \(CacheState (retr_state, maps, uses, incr)) ->
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
       let incr' = incr + 1
        in if incr' < incr
             -- Word incrementor has cycled back to 0,
             -- so may as well clear the cache completely.
-            then lookupECM' (retr_state, HM.empty, ([], 0), 0) (0+1)
-            else lookupECM' (retr_state, maps, uses, incr) incr'
+            then lookupECM' (retr_state, HM.empty, 0, ([], 0), 0) (0+1)
+            else lookupECM' (retr_state, maps, mapsize, uses, incr) incr'
   where
   
     ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, 
           compactlistsize, enter, _ro ) = ecm
     
     mnub = HM.toList . HM.fromList . reverse
-    lookupECM' (retr_state, maps, uses, incr) incr' = do
+    lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do
       let uses' = updateUses uses id incr' compactlistsize mnub
-      (ret, do_again) <- det retr_state maps uses' incr'
+      (ret, do_again) <- det retr_state maps mapsize uses' incr'
       if do_again
-        then do let (CacheState (retr_state', maps', uses'', incr''), _) = ret
+        then do let (CacheState (retr_state', maps', mapsize', uses'', incr''), _) = ret
                     uses''' = updateUses uses'' id incr'' compactlistsize mnub
-                (ret', _) <- det retr_state' maps' uses''' incr''
+                (ret', _) <- det retr_state' maps' mapsize' uses''' incr''
                 return ret'
         else return ret
     
-    det retr_state maps uses' incr' =
+    det retr_state maps mapsize uses' incr' =
       detECM (HM.lookup id maps) retr_state (retr retr_state id)
-        (\time_r -> HM.insert id time_r maps)
-        (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses)
-        mnub
+        ( (\time_r -> HM.insert id time_r maps),
+          (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses),
+          mnub, minimumkeep, removalsize )
         gettime
         HM.filter
-        uses' incr' timecheckmodulo maps minimumkeep removalsize
+        mapsize HM.size
+        uses' incr' timecheckmodulo maps
 
 
+getValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m (Maybe s)
+getValReqState ecm id = do
+  CacheState (retr_state, maps, mapsize, uses, incr) <- read m'maps
+  return retr_state
+  where
+  
+    ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm
+
 {-
+
+These functions would require inclusion of a enter_ function (like modifyMVar_)
+
+putValReqState :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> Maybe s -> m (Maybe s)
+putValReqState ecm id new_state = do
+  enter m'maps $
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
+      return (CacheState (new_state, maps, mapsize, uses, incr), retr_state)
+  where
+  
+    ECM ( m'maps, _, _, _, _, _, _, _, enter_ _ro ) = ecm
+
+-- 
+clearCache :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> m ()
+clearCache ecm = do
+  enter_ m'maps $
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
+      return $ CacheState (retr_state, HM.empty, 0, ([], 0), 0)
+  where
+    ECM ( m'maps, _, _, _, _, _, _, _, enter_, _ ) = ecm
+    
+-}
+
+
+{-
 -- This function differs from 'lookupECM' only in the case that the value
 -- being requested also causes a new time to have been computed during the 
 -- same lookup, and have been found to be out of date. When the condition 
@@ -173,29 +253,29 @@ lookupECMUse :: (Monad m, Eq k, Hashable k) => ECM m mv s HM.HashMap k v -> k -> m v
 lookupECMUse ecm id = do
   enter m'maps $
-    \(CacheState (retr_state, maps, uses, incr)) ->
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
       let incr' = incr + 1
        in if incr' < incr
             -- Word incrementor has cycled back to 0,
             -- so may as well clear the cache completely.
-            then lookupECM' (retr_state, HM.empty, ([], 0), 0) (0+1)
-            else lookupECM' (retr_state, maps, uses, incr) incr'
+            then lookupECM' (retr_state, HM.empty, 0, ([], 0), 0) (0+1)
+            else lookupECM' (retr_state, maps, mapsize, uses, incr) incr'
   where
   
     ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize, 
           compactlistsize, enter, _ro ) = ecm
     
     mnub = HM.toList . HM.fromList . reverse
-    lookupECM' (retr_state, maps, uses, incr) incr' = do
+    lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do
       let uses' = updateUses uses id incr' compactlistsize mnub
       (ret, _) <-
           detECM (HM.lookup id maps) retr_state (retr retr_state id)
-            (\time_r -> HM.insert id time_r maps)
-            (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses)
-            mnub
+            ( (\time_r -> HM.insert id time_r maps),
+              (\time_r keepuses -> HM.insert id time_r $! HM.intersection maps $ HM.fromList keepuses),
+              mnub, minimumkeep, removalsize)
             gettime
-            HM.filter
-            uses' incr' timecheckmodulo maps minimumkeep removalsize
+            HM.filter mapsize HM.size
+            uses' incr' timecheckmodulo maps
       return ret
 -}
 

@@ -26,76 +26,145 @@   -> ECMIncr -> ECMULength -> ([(k, ECMIncr)] -> [(k, ECMIncr)])
     -> ([(k, ECMIncr)], ECMULength)
 {-# INLINE updateUses #-}
-updateUses uses id incr' compactlistsize compactUses =
-    case uses of
-        (((id', _) : rest), lcount) | id' == id ->
-          (((id', incr') : rest), lcount)
-        ((latest : (id', _) : rest), lcount) | id' == id ->
-          (((id', incr') : latest : rest), lcount)
-        ((latest : latest' : (id', _) : rest), lcount) | id' == id ->
-          (((id', incr') : latest : latest' : rest), lcount)
-        (usesl, lcount) ->
-          if lcount > compactlistsize
-            then let newusesl = compactUses usesl
-                  in ((id, incr') : newusesl, (L.length newusesl) + 1)
-            else ((id, incr') : usesl, lcount+1)
+updateUses (usesl, lcount) id incr' compactlistsize compactUses
+ | lcount >= 5 =
+    case usesl of
+        (id', _) : rest | id' == id ->
+          ((id', incr') : rest, lcount)
 
+        latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest ->
+          case True of
+            _ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
+            _ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
+            _ | id3 == id -> ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id4, oincr4) : rest, lcount)
+            _ | id4 == id -> ((id4, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest, lcount)
+            _ -> justPrepend
+          {-
+          if id1 == id
+            then ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
+            else if id2 == id 
+                   then ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : (id4, oincr4) : rest, lcount)
+                   else if id3 == id 
+                          then ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id4, oincr4) : rest, lcount)
+                          else if id4 == id 
+                                 then ((id4, incr') : latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest, lcount)
+                                 else justPrepend
+          -}
+
+        _ -> justPrepend
+ | otherwise =
+    case usesl of
+        (id', _) : rest | id' == id ->
+          ((id', incr') : rest, lcount)
+
+        latest : (id1, oincr1) : (id2, oincr2) : (id3, oincr3) : rest ->
+          case True of
+            _ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : rest, lcount)
+            _ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : rest, lcount)
+            _ | id3 == id -> ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : rest, lcount)
+            _ -> justPrepend
+          {-
+          if id1 == id
+            then ((id1, incr') : latest : (id2, oincr2) : (id3, oincr3) : rest, lcount)
+            else if id2 == id 
+                   then ((id2, incr') : latest : (id1, oincr1) : (id3, oincr3) : rest, lcount)
+                   else if id3 == id 
+                          then ((id3, incr') : latest : (id1, oincr1) : (id2, oincr2) : rest, lcount)
+                          else justPrepend
+          -}
+        
+        latest : (id1, oincr1) : (id2, oincr2) : rest ->
+          case True of
+            _ | id1 == id -> ((id1, incr') : latest : (id2, oincr2) : rest, lcount)
+            _ | id2 == id -> ((id2, incr') : latest : (id1, oincr1) : rest, lcount)
+            _ -> justPrepend
+          {-
+          if id1 == id
+            then ((id1, incr') : latest : (id2, oincr2) : rest, lcount)
+            else if id2 == id 
+                   then ((id2, incr') : latest : (id1, oincr1) : rest, lcount)
+                   else justPrepend
+          -}
+        
+        latest : (id', _) : rest ->
+          if id' == id 
+            then ((id', incr') : latest : rest, lcount)
+            else justPrepend
+         
+        _ -> justPrepend
+  where
+    justPrepend =
+      if lcount > compactlistsize
+        then let newusesl = compactUses usesl
+              in ((id, incr') : newusesl, (+1) $! (L.length newusesl) )
+        else ((id, incr') : usesl, lcount + 1)
+
 detECM
   :: (Monad m, Eq k) =>
      Maybe (TimeUnits, TimeUnits, v)
      -> Maybe s
      -> m (TimeUnits, (Maybe s, v))
-     -> ((TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v))
-     -> ((TimeUnits, TimeUnits, v) -> [(k, ECMIncr)] -> mp k (TimeUnits, TimeUnits, v))
-     -> ([(k, ECMIncr)] -> [(k, ECMIncr)])
+     -> ( ((TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v)),
+          ((TimeUnits, TimeUnits, v) -> [(k, ECMIncr)] -> mp k (TimeUnits, TimeUnits, v)),
+          ([(k, ECMIncr)] -> [(k, ECMIncr)]),
+          ECMMapSize,
+          ECMULength)
      -> m TimeUnits
      -> (((TimeUnits, TimeUnits, v) -> Bool)
          -> mp k (TimeUnits, TimeUnits, v) -> mp k (TimeUnits, TimeUnits, v))
+     -> ECMMapSize
+     -> (mp k (TimeUnits, TimeUnits, v) -> ECMMapSize)
      -> ([(k, ECMIncr)], ECMULength)
      -> ECMIncr
      -> ECMIncr
      -> mp k (TimeUnits, TimeUnits, v)
-     -> ECMMapSize
-     -> ECMULength
        -> m ((CacheState s mp k v, v), Bool)
 {-# INLINE detECM #-}
-detECM result retr_state retr_id insert_id1 insert_id2 mnub gettime filt uses' incr' timecheckmodulo maps minimumkeep removalsize = 
+detECM result retr_state retr_id etc  gettime filt  cmapsize newsize uses' incr' timecheckmodulo maps = 
     case result of
         Nothing -> do
           (expirytime, (retr_state', r)) <- retr_id
           time <- gettime
-          let (newmaps,newuses) = insertAndPerhapsRemoveSome time r expirytime uses'
-          return $! ((CacheState (retr_state', newmaps, newuses, incr'), r), False)
+          let (newmaps,mapsize',newuses) = insertAndPerhapsRemoveSome etc cmapsize newsize filt time r expirytime uses'
+          return $! ((CacheState (retr_state', newmaps, mapsize', newuses, incr'), r), False)
         Just (_accesstime, _expirytime, m) -> do
           if incr' `mod` timecheckmodulo == 0
             then do
               time <- gettime
-              return ((CacheState (retr_state, filterExpired time maps, uses', incr'), m), True)
-            else return ((CacheState (retr_state, maps, uses', incr'), m), False)
+              return $! let maps' = filterExpired time maps
+                         in ((CacheState (retr_state, maps', (+0) $! newsize maps', uses', incr'), m), True)
+            else return ((CacheState (retr_state, maps, cmapsize, uses', incr'), m), False)
   where
+    filterExpired = filterExpired' filt
   
-    getKeepAndRemove =
-      finalTup . splitAt minimumkeep . reverse . 
-          sortI . map swap2 . mnub
-        where swap2 (a,b) = (b,a)
-              finalTup (l1,l2) = 
-                (map (\(c,k) -> (k,c)) l1, map (\(c,k) -> k) l2)
-              sortI = L.sortBy (\(l,_) (r,_) -> compare l r)
-    
-    insertAndPerhapsRemoveSome time r expirytime uses =
-      if lcount >= removalsize
+
+{-# INLINE insertAndPerhapsRemoveSome #-}  
+insertAndPerhapsRemoveSome (insert_id1, insert_id2, mnub, minimumkeep, removalsize) cmapsize newsize filt time r expirytime uses =
+      if cmapsize >= removalsize
         then 
           let (keepuses, _removekeys) = getKeepAndRemove usesl
               newmaps = insert_id2 (time, expirytime, r) keepuses
-           in (filterExpired time newmaps, (keepuses, L.length keepuses))
+              newmaps' = filterExpired time newmaps
+           in (newmaps', (+0) $! newsize newmaps', (keepuses, (+0) $! (L.length keepuses)))
         else
           let newmaps = insert_id1 (time, expirytime, r)
-           in (filterExpired time newmaps, uses)
+           in (newmaps, cmapsize + 1, uses) -- filterExpired time
       where
-        (usesl, lcount) = uses
+        (usesl, _lcount) = uses
+        getKeepAndRemove =
+          finalTup . splitAt minimumkeep . reverse . 
+              sortI . map swap2 . mnub
+            where swap2 (a,b) = (b,a)
+                  finalTup (l1,l2) = 
+                    (map (\(c,k) -> (k,c)) l1, map (\(c,k) -> k) l2)
+                  sortI = L.sortBy (\(l,_) (r,_) -> compare l r)
     
-    filterExpired time =
-      filt (\(accesstime, expirytime, value) ->
+
+        filterExpired = filterExpired' filt
+
+{-# INLINE filterExpired' #-}
+filterExpired' filt time =
+      filt (\(accesstime, expirytime, _value) ->
                  (accesstime <= time) &&
                    (accesstime > (time - expirytime)))
 
@@ -103,7 +172,7 @@ -- | Debugging function
 --
 getStatsString ecm = do
-  CacheState (_retr_state, _maps, uses, _incr) <- ro m'uses
+  CacheState (_retr_state, _maps, _mapsize, uses, _incr) <- ro m'uses
   return $ show uses
   where
     ECM ( m'uses, _retr, _gettime, _minimumkeep, _timecheckmodulo, _removalsize,

@@ -7,7 +7,8 @@ -- Stability: experimental
 -- Portability: portable
 --
--- Internal types.
+-- Types used by internal functions and as the opaque types exported by other 
+-- modules, assume these type definitions to change from version to version.
 -- 
 
 module Caching.ExpiringCacheMap.Internal.Types (
@@ -30,7 +31,7 @@ 
 -- | The cache state.
 newtype CacheState s m k v =
-  CacheState (Maybe s, m k (TimeUnits, TimeUnits, v), ([(k, ECMIncr)], ECMULength), ECMIncr)
+  CacheState (Maybe s, m k (TimeUnits, TimeUnits, v), ECMMapSize, ([(k, ECMIncr)], ECMULength), ECMIncr)
 
 -- | The type that encapsulates a cache map.
 newtype ECM a b s m k v = ECM ( b (CacheState s m k v),

@@ -13,7 +13,6 @@ -- An example of creating a cache for accessing files:
 --
 -- > {-# LANGUAGE OverloadedStrings #-}
--- > module Example where
 -- > 
 -- > import Caching.ExpiringCacheMap.OrdECM (newECMIO, lookupECM, CacheSettings(..), consistentDuration)
 -- > 
@@ -33,10 +32,10 @@ -- >                                         return $! (state, content)))
 -- >         (do time <- POSIX.getPOSIXTime
 -- >             return (round (time * 100)))
--- >         12000 -- Time check frequency: (accumulator `mod` this_number) == 0.
+-- >         1 -- Time check frequency: (accumulator `mod` this_number) == 0.
 -- >         (CacheWithLRUList
 -- >           6     -- Expected size of key-value map when removing elements.
--- >           6     -- Size of list when to remove items from key-value map.
+-- >           6     -- Size of map when to remove items from key-value map.
 -- >           12    -- Size of list when to compact
 -- >           )
 -- >   
@@ -56,6 +55,13 @@     -- * Request value from cache
     lookupECM,
     
+    -- * Value request function state
+    -- putValReqState,
+    getValReqState,
+    
+    -- -- * Clear cache
+    -- clearCache,
+    
     -- * Type
     ECM,
     CacheSettings(..)
@@ -73,6 +79,15 @@ -- interaction (such as in the case of reading a file from disk), with
 -- a shared state lock via an 'MV.MVar' to manage cache state.
 --
+-- Value request and time check request functions are provided as arguments.
+--
+-- The time check frequency value has to be 1 or higher, with higher values
+-- postponing time checks for longer periods of time.
+-- 
+-- A cache setting specifies how the cache should remove entries when the
+-- cache becomes a certain size. The only constructor for this is
+-- 'CacheWithLRUList'.
+--
 newECMIO :: Ord k => (Maybe s -> k -> IO (TimeUnits, (Maybe s, v))) -> (IO TimeUnits)
   -> ECMIncr 
   -> CacheSettings
@@ -85,6 +100,23 @@ -- functions to create cache state in 'Monad' m2, and modify and read
 -- cache state in 'Monad' m1.
 --
+-- 'newECMIO' is just a wrapper to this function with 'MV.MVar' functions:
+--
+-- @
+--  newECMIO retr gettime timecheckmodulo cachesettings =
+--    newECMForM retr gettime timecheckmodulo cachesettings
+--      'MV.newMVar' 'MV.modifyMVar' 'MV.readMVar'
+-- @
+--
+-- Value request and time check request functions are provided as arguments.
+--
+-- The time check frequency value has to be 1 or higher, with higher values
+-- postponing time checks for longer periods of time.
+-- 
+-- A cache setting specifies how the cache should remove entries when the
+-- cache becomes a certain size. The only constructor for this is
+-- 'CacheWithLRUList'.
+--
 newECMForM :: (Monad m1, Monad m2) => Ord k => (Maybe s -> k -> m1 (TimeUnits, (Maybe s, v))) -> (m1 TimeUnits)
   -> ECMIncr
   -> CacheSettings
@@ -93,10 +125,13 @@   -> ECMReadState m1 mv s M.Map k v
     -> m2 (ECM m1 mv s M.Map k v)
 newECMForM retr gettime timecheckmodulo (CacheWithLRUList minimumkeep removalsize compactlistsize)
-           newstate enterstate readstate = do
-  m'maps <- newstate $ CacheState ( Nothing, M.empty, ([], 0), 0 )
-  return $ ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
-                 compactlistsize, enterstate, readstate )
+           newstate enterstate readstate =
+  if timecheckmodulo <= 0
+    then error "Modulo time check must be 1 or higher."
+    else do
+      m'maps <- newstate $ CacheState ( Nothing, M.empty, 0, ([], 0), 0 )
+      return $ ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
+                     compactlistsize, enterstate, readstate )
 
 -- | Request a value associated with a key from the cache.
 --
@@ -111,53 +146,99 @@ --    will be discarded and a new value will be requested for this computation.
 --
 -- Every 'lookupECM' computation increments an accumulator in the cache state 
--- which is used to keep track of the succession of key accesses. This history 
+-- which is used to keep track of the succession of key accesses. Based on the
+-- parameters provided with the 'CacheWithLRUList' constructor, this history 
 -- of key accesses is then used to remove entries from the cache back down to 
 -- a minimum size. Also, when the modulo of the accumulator and the modulo 
--- value computes to 0, the time request function defined when the 'ECM' value
--- was created is invoked for the current time to determine of which if any of
--- the entries in the cache state map needs to be removed. In some cases the 
--- accumulator may get incremented more than once in a 'lookupECM' computation.
+-- value computes to 0, the time request function is invoked. In some cases
+-- the accumulator may get incremented more than once in a 'lookupECM'
+-- computation.
 --
 -- As the accumulator is a bound unsigned integer, when the accumulator
 -- increments back to 0, the cache state is completely cleared.
 -- 
+-- The time request function is invoked in one of two different conditions
+-- 
+--  * When a new key-value entry is requested, the current time is also
+--    requested during the same lookup, as a recent time determination is
+--    needed for a new entry in the key-value cache.
+-- 
+--  * When the modulo of the accumulator and a specified value equals to 0.
+--
+-- When the current time is determined during a lookup, access times of the
+-- entries in the key-value cache are compared with the new time to filter
+-- out expired entries from the key-value map.
+-- 
 lookupECM :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m v
 lookupECM ecm id = do
   enter m'maps $
-    \(CacheState (retr_state, maps, uses, incr)) ->
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
       let incr' = incr + 1
        in if incr' < incr
             -- Word incrementor has cycled back to 0,
             -- so may as well clear the cache completely.
-            then lookupECM' (retr_state, M.empty, ([], 0), 0) (0+1)
-            else lookupECM' (retr_state, maps, uses, incr) incr'
+            then lookupECM' (retr_state, M.empty, 0, ([], 0), 0) (0+1)
+            else lookupECM' (retr_state, maps, mapsize, uses, incr) incr'
   where
     
     ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
           compactlistsize, enter, _ro ) = ecm
   
     mnub = M.toList . M.fromList . reverse
-    lookupECM' (retr_state, maps, uses, incr) incr' = do
+    lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do
       let uses' = updateUses uses id incr' compactlistsize mnub
-      (ret, do_again) <- det retr_state maps uses' incr'
+      (ret, do_again) <- det retr_state maps mapsize uses' incr'
       if do_again
-        then do let (CacheState (retr_state', maps', uses'', incr''), _) = ret
+        then do let (CacheState (retr_state', maps', mapsize', uses'', incr''), _) = ret
                     uses''' = updateUses uses'' id incr'' compactlistsize mnub
-                (ret', _) <- det retr_state' maps' uses''' incr''
+                (ret', _) <- det retr_state' maps' mapsize' uses''' incr''
                 return ret'
         else return ret
     
-    det retr_state maps uses' incr' =
+    det retr_state maps mapsize uses' incr' =
       detECM (M.lookup id maps) retr_state (retr retr_state id)
-        (\time_r -> M.insert id time_r maps)
-        (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses)
-        mnub
+        ( (\time_r -> M.insert id time_r maps),
+          (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses),
+          mnub, minimumkeep, removalsize )
         gettime
         M.filter
-        uses' incr' timecheckmodulo maps minimumkeep removalsize
+        mapsize M.size
+        uses' incr' timecheckmodulo maps
+
+
+getValReqState :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m (Maybe s)
+getValReqState ecm id = do
+  CacheState (retr_state, maps, mapsize, uses, incr) <- read m'maps
+  return retr_state
+  where
+    ECM ( m'maps, _, _, _, _, _, _, _, read ) = ecm
+
+
+{-
+
+These functions would require inclusion of a enter_ function (like modifyMVar_)
+
+putValReqState :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> Maybe s -> m (Maybe s)
+putValReqState ecm id new_state = do
+  enter_ m'maps $
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
+      return (CacheState (new_state, maps, mapsize, uses, incr), retr_state)
+  where
     
+    ECM ( m'maps, _, _, _, _, _, _, _, enter_, _ro ) = ecm
 
+
+clearCache :: (Monad m, Ord k) => ECM m mv s M.Map k v -> m ()
+clearCache ecm = do
+  enter_ m'maps $
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
+      return $ CacheState (retr_state, M.empty, 0, ([], 0), 0)
+  where
+    ECM ( m'maps, _, _, _, _, _, _, enter, enter_, _ ) = ecm
+
+-}
+
+
 {-
 -- This function differs from 'lookupECM' only in the case that the value
 -- being requested also causes a new time to have been computed during the 
@@ -169,29 +250,29 @@ lookupECMUse :: (Monad m, Ord k) => ECM m mv s M.Map k v -> k -> m v
 lookupECMUse ecm id = do
   enter m'maps $
-    \(CacheState (retr_state, maps, uses, incr)) ->
+    \(CacheState (retr_state, maps, mapsize, uses, incr)) ->
       let incr' = incr + 1
        in if incr' < incr
             -- Word incrementor has cycled back to 0,
             -- so may as well clear the cache completely.
-            then lookupECM' (retr_state, M.empty, ([], 0), 0) (0+1)
-            else lookupECM' (retr_state, maps, uses, incr) incr'
+            then lookupECM' (retr_state, M.empty, 0, ([], 0), 0) (0+1)
+            else lookupECM' (retr_state, maps, mapsize, uses, incr) incr'
   where
     
     ECM ( m'maps, retr, gettime, minimumkeep, timecheckmodulo, removalsize,
           compactlistsize, enter, _ro ) = ecm
   
     mnub = M.toList . M.fromList . reverse
-    lookupECM' (retr_state, maps, uses, incr) incr' = do
+    lookupECM' (retr_state, maps, mapsize, uses, incr) incr' = do
       let uses' = updateUses uses id incr' compactlistsize mnub
       (ret, _) <-
           detECM (M.lookup id maps) retr_state (retr retr_state id)
-            (\time_r -> M.insert id time_r maps)
-            (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses)
-            mnub
+            ( (\time_r -> M.insert id time_r maps),
+              (\time_r keepuses -> M.insert id time_r $! M.intersection maps $ M.fromList keepuses),
+              mnub, minimumkeep, removalsize )
             gettime
-            M.filter
-            uses' incr' timecheckmodulo maps minimumkeep removalsize
+            M.filter mapsize M.size
+            uses' incr' timecheckmodulo maps
       return ret
 -}
 

@@ -31,8 +31,21 @@ import Caching.ExpiringCacheMap.Internal.Types
 
 data CacheSettings =
+  -- | A cache that maintains a key access history list to perform removals
+  -- of /least recently used/ entries. Once the key-value map reaches 
+  -- 'removalsize' keys, then a list of keys to keep in the map is determined 
+  -- which is no larger than 'mapsize' size. Entries are removed only on 
+  -- insertion of a new entry in the key-value map.
+  -- 
+  -- Key access history entries are prepended to the head of the LRU list, 
+  -- if an existing entry for the key appears close to the head of the list
+  -- it is moved to the head of the list, instead of growing the list. When the 
+  -- LRU list reaches 'compactlistsize' items, it is compacted by removing 
+  -- duplicate keys, by keeping only the most recent accumulator value for 
+  -- that key.
+  --
   CacheWithLRUList {
     mapsize :: ECMMapSize,
-    removalsize :: ECMULength,
+    removalsize :: ECMMapSize,
     compactlistsize :: ECMULength
   }

@@ -10,8 +10,6 @@ --
 -- > {-# LANGUAGE OverloadedStrings #-}
 -- > 
--- > module TestSequenceExample where
--- > 
 -- > import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration)
 -- > import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq
 -- > 
@@ -31,7 +29,7 @@ -- >             12000 -- Time check frequency: (accumulator `mod` this_number) == 0.
 -- >             (CacheWithLRUList 
 -- >               6   -- Expected size of key-value map when removing elements.
--- >               6   -- Size of list when to remove items from key-value map.
+-- >               6   -- Size of map when to remove items from key-value map.
 -- >               12  -- Size of list when to compact
 -- >               )
 -- >             TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar
@@ -45,11 +43,25 @@ -- >       return b
 -- >
 --
+-- Evaluating the @test@ function results in a list of events.
+--
 -- >>> test
 -- [GetVar 3,ReadNumber 4,GetTime 7,PutVar 11,HaveNumber 4,GetVar 14,PutVar 17,
 --  GetVar 19,ReadNumber 20,GetTime 23,PutVar 27,HaveNumber 20]
 -- 
+-- In this example the history shows 2 time accesses (@GetTime 7@ and
+-- @GetTime 23@) since the time check frequency number is a high value (12000),
+-- but regardless the high value a time check is still requested again because
+-- of the new key request for @"file2"@.
 --
+-- Changing the time frequency to 1 will alter the list of events with more
+-- frequent time checks:
+--
+-- >>> test
+-- [GetVar 3,ReadNumber 4,GetTime 7,PutVar 11,HaveNumber 4,GetVar 14,GetTime 15,
+--  GetTime 18,PutVar 22,GetVar 24,ReadNumber 25,GetTime 28,PutVar 32,
+--  HaveNumber 25]
+--
 
 module Caching.ExpiringCacheMap.Utils.TestSequence (
     runTestSequence,
@@ -95,7 +107,7 @@ 
 newtype TestSVar a = TestSVar a
 
-
+-- TODO: Add instance to Applicative per GHC 7.10 warning
 instance Monad (TestSequence a) where
   TestSequence fun >>= k =
     TestSequence

@@ -1,5 +1,5 @@ name:                expiring-cache-map
-version:             0.0.5.0
+version:             0.0.5.3
 synopsis:            General purpose simple caching.
 description:         
     A simple general purpose shared state cache map with automatic expiration 
@@ -64,5 +64,6 @@       hashable >= 1.0.1.1 && < 1.2,
       unordered-containers >= 0.2.0.0
     other-modules:
+      TestECMWithTestSequenceCommon
       TestHashECMWithTestSequence
       TestOrdECMWithTestSequence

@@ -0,0 +1,116 @@+{-# LANGUAGE OverloadedStrings #-}
+
+module TestECMWithTestSequenceCommon (
+    someEventsOnly,
+    numberEventsOnly,
+    pattern',
+    pattern'',
+    pattern''',
+    pattern'''',
+    testLookups,
+    printOutEvents,
+    printOutFailedPattern
+) where
+
+import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq
+
+import qualified Data.ByteString.Char8 as BS
+
+printOutFailedPattern from_where filt_events' filt_events'' filt_events''' filt_events'''' = do
+  putStrLn $ "Failed sequence test in " ++ from_where ++ ":"
+  if not (pattern' (filt_events'))
+    then putStrLn $ "Failed: pattern 1: " ++ (show filt_events')
+    else return ()
+  if not (pattern'' (filt_events''))
+    then putStrLn $ "Failed: pattern 2: " ++ (show filt_events'')
+    else return ()
+  if not (pattern''' (filt_events'''))
+    then putStrLn $ "Failed: pattern 3: " ++ (show filt_events''')
+    else return ()
+  if not (pattern'''' (filt_events''''))
+    then putStrLn $ "Failed: pattern 4: " ++ (show filt_events'''')
+    else return ()
+  return ()
+
+
+printOutEvents events' events'' events''' events'''' = do
+  (putStrLn . show . filter someEventsOnly . reverse) events'
+  (putStrLn . show . filter someEventsOnly . reverse) events''
+  (putStrLn . show . filter someEventsOnly . reverse) events'''
+  (putStrLn . show . filter someEventsOnly . reverse) events''''
+  return ()
+
+someEventsOnly a =
+  case a of
+    TestSeq.GetTime _    -> True
+    TestSeq.ReadNumber _ -> True
+    TestSeq.HaveNumber _ -> True
+    _ -> False
+
+numberEventsOnly a =
+  case a of
+    TestSeq.ReadNumber _ -> True
+    TestSeq.HaveNumber _ -> True
+    _ -> False
+
+pattern' c =
+  case c of
+    [ TestSeq.ReadNumber numr1,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh1,
+      TestSeq.HaveNumber numh1',
+      TestSeq.ReadNumber numr2,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh2 ]
+      | numr1 == numh1 && numr1 == numh1' && numr2 == numh2 -> True
+    _ -> False
+    
+pattern'' c =
+  case c of
+    [ TestSeq.ReadNumber numr1,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh1,
+      TestSeq.GetTime _,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh1',
+      TestSeq.ReadNumber numr2,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh2 ]
+      | numr1 == numh1 && numr1 == numh1' && numr2 == numh2 -> True
+    _ -> False
+
+pattern''' c =
+  case c of
+    [ TestSeq.ReadNumber numr1,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh1,
+      TestSeq.HaveNumber numh1',
+      TestSeq.ReadNumber numr2,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh2 ]
+      | numr1 == numh1 && numr1 == numh1' && numr2 == numh2 -> True
+    _ -> False
+
+pattern'''' c =
+  case c of
+    [ TestSeq.ReadNumber numr1,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh1,
+      TestSeq.GetTime _,
+      TestSeq.ReadNumber numr2,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh2,
+      TestSeq.ReadNumber numr3,
+      TestSeq.GetTime _,
+      TestSeq.HaveNumber numh3 ]
+      | numr1 == numh1 && numr2 == numh2 && numr3 == numh3 -> True
+    _ -> False
+
+testLookups lookup = do
+  b <- lookup ("file1" :: BS.ByteString)
+  TestSeq.haveNumber b
+  b <- lookup "file1"
+  TestSeq.haveNumber b
+  b <- lookup "file2"
+  TestSeq.haveNumber b
+  return b

@@ -1,49 +1,70 @@ {-# LANGUAGE OverloadedStrings #-}
 
-module TestHashECMWithTestSequence where
+module TestHashECMWithTestSequence (
+    testWithTestSequence
+) where
 
 import Caching.ExpiringCacheMap.HashECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration)
 import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq
 
-import qualified Data.ByteString.Char8 as BS
+import TestECMWithTestSequenceCommon
 
-numberEventsOnly a =
-  case a of
-    TestSeq.ReadNumber _ -> True
-    TestSeq.HaveNumber _ -> True
-    _ -> False
+import qualified Data.ByteString.Char8 as BS
+import System.Exit (exitFailure)
 
 testWithTestSequence = do
-  (TestSeq.TestSequenceState (_, events, _), return_value) <- TestSeq.runTestSequence test'
-  case (filter numberEventsOnly . reverse) events of
-    [ TestSeq.ReadNumber numr1, TestSeq.HaveNumber numh1,
-      TestSeq.ReadNumber numr2, TestSeq.HaveNumber numh2 ]
-      | numr1 == numh1 && numr2 == numh2 -> do
-        (putStrLn . show . filter numberEventsOnly . reverse) events
-        return ()
+  (TestSeq.TestSequenceState (_, events',    _), return_value) <- TestSeq.runTestSequence test'
+  (TestSeq.TestSequenceState (_, events'',   _), return_value) <- TestSeq.runTestSequence test''
+  (TestSeq.TestSequenceState (_, events''',  _), return_value) <- TestSeq.runTestSequence test'''
+  (TestSeq.TestSequenceState (_, events'''', _), return_value) <- TestSeq.runTestSequence test''''
+  if pattern'    (filt events') &&
+     pattern''   (filt events'') &&
+     pattern'''  (filt events''') &&
+     pattern'''' (filt events'''')
+    then do
+      putStrLn "Passed TestHashECMWithTestSequence"
+      -- printOutEvents events' events'' events''' events''''
+      return ()
+    else do
+      printOutFailedPattern "TestHashECMWithTestSequence.testWithTestSequence"
+        (filt events') (filt events'') (filt events''') (filt events'''')
+      printOutEvents events' events'' events''' events''''
+      exitFailure
   where
+    filt = filter someEventsOnly . reverse
+    commonreadnumber =
+      (\state _id -> do number <- TestSeq.readNumber
+                        return (state, number))
+    
+    newTestECM valreq timecheck =
+      newECMForM valreq
+        (TestSeq.getCurrentTime >>= return)
+        timecheck
+        (CacheWithLRUList 6 6 12)
+        TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar
+            
     test' = do
-      filecache <- newECMForM
-            (consistentDuration 100 -- Duration between access and expiry time of each item, no state needed.
-              (\state _id -> do number <- TestSeq.readNumber
-                                return (state, number)))
-            (TestSeq.getCurrentTime >>= return)
-            12000 -- Time check frequency: (accumulator `mod` this_number) == 0.
-            (CacheWithLRUList 
-              6   -- Expected size of key-value map when removing elements.
-              6   -- Size of list when to remove items from key-value map.
-              12  -- Size of list when to compact
-              )
-            TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar
-      
-      -- Use lookupECM whenever the contents of "file1" is needed.
-      b <- lookupECM filecache ("file1" :: BS.ByteString)
-      TestSeq.haveNumber b
-      b <- lookupECM filecache "file1"
-      b <- lookupECM filecache "file2"
-      TestSeq.haveNumber b
-      return b
-
-main = testWithTestSequence
+      filecache <- newTestECM
+        (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time
+        12000 -- Time check frequency
+      testLookups (lookupECM filecache)
+    
+    test'' = do
+      filecache <- newTestECM
+        (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time
+        1 -- Time check frequency
+      testLookups (lookupECM filecache)
+            
+    test''' = do
+      filecache <- newTestECM
+        (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time
+        12000 -- Time check frequency
+      testLookups (lookupECM filecache)
+    
+    test'''' = do
+      filecache <- newTestECM
+        (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time
+        1 -- Time check frequency
+      testLookups (lookupECM filecache)
 
- +-- main = testWithTestSequence

@@ -4,9 +4,11 @@ -- Test HashECM with threads
 --
 
-module TestHashECMWithThreads where
+module TestHashECMWithThreads (
+    testWithThreads
+) where
 
-import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent (forkIO, threadDelay, yield)
 import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime)
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
@@ -17,7 +19,16 @@ import Caching.ExpiringCacheMap.HashECM
 import Caching.ExpiringCacheMap.Internal.Internal (getStatsString)
 
+import System.Timeout (timeout)
+import System.Exit (exitFailure)
+
 testWithThreads = do
+  res <- timeout 60000000 testWithThreads'
+  case res of
+    Nothing -> exitFailure
+    Just () -> return ()
+
+testWithThreads' = do
   ecm <- newECMIO
             (consistentDuration 10
               (\state id -> do LBS.putStrLn id; return (state, [])))
@@ -25,61 +36,83 @@                 return (round (time * 100)))
             120 
             (CacheWithLRUList 6 6 12) :: IO (ECM IO MV.MVar () HM.HashMap LBS.ByteString [Int])
+  t1 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.2"
-      threadDelay 2
+      yield --threadDelay 2
       return ())
-      [0..400]
+      [0..500]
+    MV.putMVar t1 True
+  t2 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
+      b <- lookupECM ecm "test.3"
+      yield --threadDelay 3
+      return ())
+      [0..333]
+    MV.putMVar t2 True
+  t3 <- MV.newEmptyMVar
+  forkIO $ do
+    mapM_ (\a -> do
       b <- lookupECM ecm "test.5"
-      threadDelay 5
+      yield -- threadDelay 5
       return ())
-      [0..300]
+      [0..200]
+    MV.putMVar t3 True
+  t4 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.7"
-      threadDelay 7
+      yield -- threadDelay 7
       return ())
-      [0..300]
+      [0..142]
+    MV.putMVar t4 True
+  t5 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.11"
-      threadDelay 11
+      yield -- threadDelay 11
       return ())
-      [0..200]
+      [0..90]
+    MV.putMVar t5 True
+  t6 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.13"
-      threadDelay 13
+      yield -- threadDelay 13
       return ())
-      [0..200]
+      [0..76]
+    MV.putMVar t6 True
+  t7 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.17"
-      threadDelay 17
-      return ())
-      [0..200]
-  forkIO $ do
-    mapM_ (\a -> do
-      b <- lookupECM ecm "test.111"
-      threadDelay 111
+      yield -- threadDelay 17
       return ())
-      [0..20]
+      [0..58]
+    MV.putMVar t7 True
+  t8 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
-      b <- lookupECM ecm "test.109"
-      threadDelay 109
+      b <- lookupECM ecm "test.19"
+      yield -- threadDelay 19
       return ())
-      [0..20]
+      [0..52]
+    MV.putMVar t8 True
+  t9 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
-      b <- lookupECM ecm "test.1091"
-      threadDelay 1091
+      b <- lookupECM ecm "test.23"
+      yield -- threadDelay 23
       return ())
-      [0..5]
-  threadDelay 2000000
+      [0..43]
+    MV.putMVar t9 True
+  untilDone [t1,t2,t3,t4,t5,t6,t7,t8,t9]
   c <- getStatsString ecm
   putStrLn c
   return ()
+  where
+    untilDone [] = return ()
+    untilDone (t:tr) = MV.takeMVar t >> untilDone tr
+      

@@ -1,49 +1,71 @@ {-# LANGUAGE OverloadedStrings #-}
 
-module TestOrdECMWithTestSequence where
+module TestOrdECMWithTestSequence (
+    testWithTestSequence
+) where
 
 import Caching.ExpiringCacheMap.OrdECM (newECMForM, lookupECM, CacheSettings(..), consistentDuration)
 import qualified Caching.ExpiringCacheMap.Utils.TestSequence as TestSeq
 
-import qualified Data.ByteString.Char8 as BS
+import TestECMWithTestSequenceCommon
 
-numberEventsOnly a =
-  case a of
-    TestSeq.ReadNumber _ -> True
-    TestSeq.HaveNumber _ -> True
-    _ -> False
+import qualified Data.ByteString.Char8 as BS
+import System.Exit (exitFailure)
 
 testWithTestSequence = do
-  (TestSeq.TestSequenceState (_, events, _), return_value) <- TestSeq.runTestSequence test'
-  case (filter numberEventsOnly . reverse) events of
-    [ TestSeq.ReadNumber numr1, TestSeq.HaveNumber numh1,
-      TestSeq.ReadNumber numr2, TestSeq.HaveNumber numh2 ]
-      | numr1 == numh1 && numr2 == numh2 -> do
-        (putStrLn . show . filter numberEventsOnly . reverse) events
-        return ()
+  (TestSeq.TestSequenceState (_, events',    _), return_value) <- TestSeq.runTestSequence test'
+  (TestSeq.TestSequenceState (_, events'',   _), return_value) <- TestSeq.runTestSequence test''
+  (TestSeq.TestSequenceState (_, events''',  _), return_value) <- TestSeq.runTestSequence test'''
+  (TestSeq.TestSequenceState (_, events'''', _), return_value) <- TestSeq.runTestSequence test''''
+  if pattern'    (filt events') &&
+     pattern''   (filt events'') &&
+     pattern'''  (filt events''') &&
+     pattern'''' (filt events'''')
+    then do
+      putStrLn "Passed TestOrdECMWithTestSequence"
+      -- printOutEvents events' events'' events''' events''''
+      return ()
+    else do
+      printOutFailedPattern "TestOrdECMWithTestSequence.testWithTestSequence"
+        (filt events') (filt events'') (filt events''') (filt events'''')
+      printOutEvents events' events'' events''' events''''
+      exitFailure
   where
+    filt = filter someEventsOnly . reverse
+    commonreadnumber = 
+      (\state _id -> do number <- TestSeq.readNumber
+                        return (state, number))
+    
+    newTestECM valreq timecheck =
+      newECMForM valreq
+        (TestSeq.getCurrentTime >>= return)
+        timecheck
+        (CacheWithLRUList 6 6 12)
+        TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar
+  
     test' = do
-      filecache <- newECMForM
-            (consistentDuration 100 -- Duration between access and expiry time of each item, no state needed.
-              (\state _id -> do number <- TestSeq.readNumber
-                                return (state, number)))
-            (TestSeq.getCurrentTime >>= return)
-            12000 -- Time check frequency: (accumulator `mod` this_number) == 0.
-            (CacheWithLRUList 
-              6   -- Expected size of key-value map when removing elements.
-              6   -- Size of list when to remove items from key-value map.
-              12  -- Size of list when to compact
-              )
-            TestSeq.newTestSVar TestSeq.enterTestSVar TestSeq.readTestSVar
-      
-      -- Use lookupECM whenever the contents of "file1" is needed.
-      b <- lookupECM filecache ("file1" :: BS.ByteString)
-      TestSeq.haveNumber b
-      b <- lookupECM filecache "file1"
-      b <- lookupECM filecache "file2"
-      TestSeq.haveNumber b
-      return b
+      filecache <- newTestECM
+        (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time
+        12000 -- Time check frequency
+      testLookups (lookupECM filecache)
+    
+    test'' = do
+      filecache <- newTestECM
+        (consistentDuration 100 commonreadnumber) -- Duration between access and expiry time
+        1 -- Time check frequency
+      testLookups (lookupECM filecache)
+  
+    test''' = do
+      filecache <- newTestECM
+        (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time
+        12000 -- Time check frequency
+      testLookups (lookupECM filecache)
+    
+    test'''' = do
+      filecache <- newTestECM
+        (consistentDuration 1 commonreadnumber) -- Duration between access and expiry time
+        1 -- Time check frequency
+      testLookups (lookupECM filecache)
 
-main = testWithTestSequence
 
- +-- main = testWithTestSequence

@@ -4,9 +4,11 @@ -- Test OrdECM with threads
 --
 
-module TestOrdECMWithThreads where
+module TestOrdECMWithThreads (
+    testWithThreads
+) where
 
-import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent (forkIO, threadDelay, yield)
 import qualified Data.Time.Clock.POSIX as POSIX (POSIXTime, getPOSIXTime)
 import qualified Data.ByteString.Lazy.Char8 as LBS
 
@@ -16,7 +18,16 @@ import Caching.ExpiringCacheMap.OrdECM
 import Caching.ExpiringCacheMap.Internal.Internal (getStatsString)
 
+import System.Timeout (timeout)
+import System.Exit (exitFailure)
+
 testWithThreads = do
+  res <- timeout 60000000 testWithThreads'
+  case res of
+    Nothing -> exitFailure
+    Just () -> return ()
+
+testWithThreads' = do
   ecm <- newECMIO
             (consistentDuration 10
               (\state id -> do LBS.putStrLn id; return (state, [])))
@@ -24,61 +35,82 @@                 return (round (time * 100)))
             120
             (CacheWithLRUList 6 6 12 ) :: IO (ECM IO MV.MVar () M.Map LBS.ByteString [Int])
+  t1 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.2"
-      threadDelay 2
+      yield -- threadDelay 2
       return ())
-      [0..400]
+      [0..500]
+    MV.putMVar t1 True
+  t2 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
+      b <- lookupECM ecm "test.3"
+      yield -- threadDelay 3
+      return ())
+      [0..333]
+    MV.putMVar t2 True
+  t3 <- MV.newEmptyMVar
+  forkIO $ do
+    mapM_ (\a -> do
       b <- lookupECM ecm "test.5"
-      threadDelay 5
+      yield -- threadDelay 5
       return ())
-      [0..300]
+      [0..200]
+    MV.putMVar t3 True
+  t4 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.7"
-      threadDelay 7
+      yield -- threadDelay 7
       return ())
-      [0..300]
+      [0..142]
+    MV.putMVar t4 True
+  t5 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.11"
-      threadDelay 11
+      yield -- threadDelay 11
       return ())
-      [0..200]
+      [0..90]
+    MV.putMVar t5 True
+  t6 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.13"
-      threadDelay 13
+      yield -- threadDelay 13
       return ())
-      [0..200]
+      [0..76]
+    MV.putMVar t6 True
+  t7 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
       b <- lookupECM ecm "test.17"
-      threadDelay 17
-      return ())
-      [0..200]
-  forkIO $ do
-    mapM_ (\a -> do
-      b <- lookupECM ecm "test.111"
-      threadDelay 111
+      yield -- threadDelay 17
       return ())
-      [0..20]
+      [0..58]
+    MV.putMVar t7 True
+  t8 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
-      b <- lookupECM ecm "test.109"
-      threadDelay 109
+      b <- lookupECM ecm "test.19"
+      yield -- threadDelay 19
       return ())
-      [0..20]
+      [0..52]
+    MV.putMVar t8 True
+  t9 <- MV.newEmptyMVar
   forkIO $ do
     mapM_ (\a -> do
-      b <- lookupECM ecm "test.1091"
-      threadDelay 1091
+      b <- lookupECM ecm "test.23"
+      yield -- threadDelay 23
       return ())
-      [0..5]
-  threadDelay 2000000
+      [0..43]
+    MV.putMVar t9 True
+  untilDone [t1,t2,t3,t4,t5,t6,t7,t8,t9]
   c <- getStatsString ecm
   putStrLn c
   return ()
+  where
+    untilDone [] = return ()
+    untilDone (t:tr) = MV.takeMVar t >> untilDone tr