mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
73 lines
2.9 KiB
Haskell
73 lines
2.9 KiB
Haskell
-- | A file cache to avoid reading and parsing the same file many times
|
|
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 :: Maybe a -> 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 :: (Maybe a -> 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
|
|
| otherwise -> cacheLoad c (Just x) file
|
|
_ -> cacheLoad c Nothing file
|
|
return (Just (t',now,x'), (t',x'))
|