mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
b061d59044
This can be used if the cloud service seems slow, but it would probably be better to automatically expire unused PGFs from the cache after some time.
39 lines
1.4 KiB
Haskell
39 lines
1.4 KiB
Haskell
module Cache (Cache,newCache,flushCache,readCache) where
|
|
|
|
import Control.Concurrent.MVar
|
|
import Data.Map (Map)
|
|
import qualified Data.Map as Map
|
|
import System.Directory (getModificationTime)
|
|
import Data.Time (UTCTime)
|
|
import Data.Time.Compat (toUTCTime)
|
|
|
|
data Cache a = Cache {
|
|
cacheLoad :: FilePath -> IO a,
|
|
cacheObjects :: MVar (Map FilePath (MVar (Maybe (UTCTime, a))))
|
|
}
|
|
|
|
newCache :: (FilePath -> IO a) -> IO (Cache a)
|
|
newCache load =
|
|
do objs <- newMVar Map.empty
|
|
return $ Cache { cacheLoad = load, cacheObjects = objs }
|
|
|
|
flushCache :: Cache a -> IO ()
|
|
flushCache c = modifyMVar_ (cacheObjects c) (const (return Map.empty))
|
|
|
|
readCache :: Cache a -> FilePath -> IO 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
|
|
x' <- case m of
|
|
Just (t,x) | t' == t -> return x
|
|
_ -> cacheLoad c file
|
|
return (Just (t',x'), x')
|