Cache.hs

module Cache (Cache,newCache,flushCache,expireCache,listCache,readCache,readCache') where

import Control.Concurrent.MVar
import Data.Map (Map)
import qualified Data.Map as Map 
import Data.Foldable as T(mapM_)
import Data.Maybe(mapMaybe)
import System.Directory (getModificationTime)
import System.Mem(performGC)
import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
--import Data.Time.Compat (toUTCTime)

data Cache a = Cache {
      cacheLoad :: FilePath -> IO a,
      cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
    }

type FileInfo a = (UTCTime,UTCTime,a) -- modification time, access time, contents

-- | Create a new cache that uses the given function to read and parse files
newCache :: (FilePath -> IO a) -> IO (Cache a)
newCache load = 
    do objs <- newMVar Map.empty
       return $ Cache { cacheLoad = load, cacheObjects = objs }

-- | Forget all cached objects
flushCache :: Cache a -> IO ()
flushCache c = do modifyMVar_ (cacheObjects c) (const (return Map.empty))
                  performGC

-- | Forget cached objects that have been unused for longer than the given time
expireCache age c =
  do now <- getCurrentTime
     let expire object@(Just (_,t,_)) | diffUTCTime now t>age = return Nothing
         expire object = return object
     withMVar (cacheObjects c) (T.mapM_ (flip modifyMVar_ expire))
     performGC

-- | List currently cached files
listCache :: Cache a -> IO [(FilePath,UTCTime)]
listCache c =
    fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
  where
    check (path,v) = maybe Nothing (Just . (,) path . fst3) `fmap` readMVar v

fst3 (x,y,z) = x

-- | Lookup a cached object (or read the file if it is not in the cache or if
-- it has been modified)
readCache :: Cache a -> FilePath -> IO a
readCache c file = snd `fmap` readCache' c file

-- | Like 'readCache', but also return the last modification time of the file
readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
readCache' c file =
    do v <- modifyMVar (cacheObjects c) findEntry
       modifyMVar v readObject
  where
    -- Find the cache entry, inserting a new one if neccessary.
    findEntry objs = case Map.lookup file objs of
                       Just v -> return (objs,v)
                       Nothing -> do v <- newMVar Nothing
                                     return (Map.insert file v objs, v)
    -- Check time stamp, and reload if different than the cache entry
    readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file
                      now <- getCurrentTime
                      x' <- case m of
                              Just (t,_,x) | t' == t -> return x
                              _                      -> cacheLoad c file
                      return (Just (t',now,x'), (t',x'))