-- | 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 {
      Cache a -> FilePath -> IO a
cacheLoad :: FilePath -> IO a,
      Cache a -> MVar (Map FilePath (MVar (Maybe (FileInfo 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 :: (FilePath -> IO a) -> IO (Cache a)
newCache FilePath -> IO a
load = 
    do MVar (Map FilePath (MVar (Maybe (FileInfo a))))
objs <- Map FilePath (MVar (Maybe (FileInfo a)))
-> IO (MVar (Map FilePath (MVar (Maybe (FileInfo a)))))
forall a. a -> IO (MVar a)
newMVar Map FilePath (MVar (Maybe (FileInfo a)))
forall k a. Map k a
Map.empty
       Cache a -> IO (Cache a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Cache a -> IO (Cache a)) -> Cache a -> IO (Cache a)
forall a b. (a -> b) -> a -> b
$ Cache :: forall a.
(FilePath -> IO a)
-> MVar (Map FilePath (MVar (Maybe (FileInfo a)))) -> Cache a
Cache { cacheLoad :: FilePath -> IO a
cacheLoad = FilePath -> IO a
load, cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
cacheObjects = MVar (Map FilePath (MVar (Maybe (FileInfo a))))
objs }

-- | Forget all cached objects
flushCache :: Cache a -> IO ()
flushCache :: Cache a -> IO ()
flushCache Cache a
c = do MVar (Map FilePath (MVar (Maybe (FileInfo a))))
-> (Map FilePath (MVar (Maybe (FileInfo a)))
    -> IO (Map FilePath (MVar (Maybe (FileInfo a)))))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (Cache a -> MVar (Map FilePath (MVar (Maybe (FileInfo a))))
forall a.
Cache a -> MVar (Map FilePath (MVar (Maybe (FileInfo a))))
cacheObjects Cache a
c) (IO (Map FilePath (MVar (Maybe (FileInfo a))))
-> Map FilePath (MVar (Maybe (FileInfo a)))
-> IO (Map FilePath (MVar (Maybe (FileInfo a))))
forall a b. a -> b -> a
const (Map FilePath (MVar (Maybe (FileInfo a)))
-> IO (Map FilePath (MVar (Maybe (FileInfo a))))
forall (m :: * -> *) a. Monad m => a -> m a
return Map FilePath (MVar (Maybe (FileInfo a)))
forall k a. Map k a
Map.empty))
                  IO ()
performGC

-- | Forget cached objects that have been unused for longer than the given time
expireCache :: NominalDiffTime -> Cache c -> IO ()
expireCache NominalDiffTime
age Cache c
c =
  do UTCTime
now <- IO UTCTime
getCurrentTime
     let expire :: Maybe (a, UTCTime, c) -> m (Maybe (a, UTCTime, c))
expire object :: Maybe (a, UTCTime, c)
object@(Just (a
_,UTCTime
t,c
_)) | UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
tNominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>NominalDiffTime
age = Maybe (a, UTCTime, c) -> m (Maybe (a, UTCTime, c))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, UTCTime, c)
forall a. Maybe a
Nothing
         expire Maybe (a, UTCTime, c)
object = Maybe (a, UTCTime, c) -> m (Maybe (a, UTCTime, c))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, UTCTime, c)
object
     MVar (Map FilePath (MVar (Maybe (FileInfo c))))
-> (Map FilePath (MVar (Maybe (FileInfo c))) -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Cache c -> MVar (Map FilePath (MVar (Maybe (FileInfo c))))
forall a.
Cache a -> MVar (Map FilePath (MVar (Maybe (FileInfo a))))
cacheObjects Cache c
c) ((MVar (Maybe (FileInfo c)) -> IO ())
-> Map FilePath (MVar (Maybe (FileInfo c))) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
T.mapM_ ((MVar (Maybe (FileInfo c))
 -> (Maybe (FileInfo c) -> IO (Maybe (FileInfo c))) -> IO ())
-> (Maybe (FileInfo c) -> IO (Maybe (FileInfo c)))
-> MVar (Maybe (FileInfo c))
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip MVar (Maybe (FileInfo c))
-> (Maybe (FileInfo c) -> IO (Maybe (FileInfo c))) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ Maybe (FileInfo c) -> IO (Maybe (FileInfo c))
forall (m :: * -> *) a c.
Monad m =>
Maybe (a, UTCTime, c) -> m (Maybe (a, UTCTime, c))
expire))
     IO ()
performGC

-- | List currently cached files
listCache :: Cache a -> IO [(FilePath,UTCTime)]
listCache :: Cache a -> IO [(FilePath, UTCTime)]
listCache Cache a
c =
    ([Maybe (FilePath, UTCTime)] -> [(FilePath, UTCTime)])
-> IO [Maybe (FilePath, UTCTime)] -> IO [(FilePath, UTCTime)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe (FilePath, UTCTime) -> Maybe (FilePath, UTCTime))
-> [Maybe (FilePath, UTCTime)] -> [(FilePath, UTCTime)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Maybe (FilePath, UTCTime) -> Maybe (FilePath, UTCTime)
forall a. a -> a
id) (IO [Maybe (FilePath, UTCTime)] -> IO [(FilePath, UTCTime)])
-> (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a)))
    -> IO [Maybe (FilePath, UTCTime)])
-> Map FilePath (MVar (Maybe (UTCTime, UTCTime, a)))
-> IO [(FilePath, UTCTime)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, MVar (Maybe (UTCTime, UTCTime, a)))
 -> IO (Maybe (FilePath, UTCTime)))
-> [(FilePath, MVar (Maybe (UTCTime, UTCTime, a)))]
-> IO [Maybe (FilePath, UTCTime)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath, MVar (Maybe (UTCTime, UTCTime, a)))
-> IO (Maybe (FilePath, UTCTime))
forall a b b c. (a, MVar (Maybe (b, b, c))) -> IO (Maybe (a, b))
check ([(FilePath, MVar (Maybe (UTCTime, UTCTime, a)))]
 -> IO [Maybe (FilePath, UTCTime)])
-> (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a)))
    -> [(FilePath, MVar (Maybe (UTCTime, UTCTime, a)))])
-> Map FilePath (MVar (Maybe (UTCTime, UTCTime, a)))
-> IO [Maybe (FilePath, UTCTime)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FilePath (MVar (Maybe (UTCTime, UTCTime, a)))
-> [(FilePath, MVar (Maybe (UTCTime, UTCTime, a)))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a)))
 -> IO [(FilePath, UTCTime)])
-> IO (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a))))
-> IO [(FilePath, UTCTime)]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a))))
-> IO (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a))))
forall a. MVar a -> IO a
readMVar (Cache a -> MVar (Map FilePath (MVar (Maybe (UTCTime, UTCTime, a))))
forall a.
Cache a -> MVar (Map FilePath (MVar (Maybe (FileInfo a))))
cacheObjects Cache a
c)
  where
    check :: (a, MVar (Maybe (b, b, c))) -> IO (Maybe (a, b))
check (a
path,MVar (Maybe (b, b, c))
v) = Maybe (a, b)
-> ((b, b, c) -> Maybe (a, b)) -> Maybe (b, b, c) -> Maybe (a, b)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (a, b)
forall a. Maybe a
Nothing ((a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just ((a, b) -> Maybe (a, b))
-> ((b, b, c) -> (a, b)) -> (b, b, c) -> Maybe (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) a
path (b -> (a, b)) -> ((b, b, c) -> b) -> (b, b, c) -> (a, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b, c) -> b
forall a b c. (a, b, c) -> a
fst3) (Maybe (b, b, c) -> Maybe (a, b))
-> IO (Maybe (b, b, c)) -> IO (Maybe (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` MVar (Maybe (b, b, c)) -> IO (Maybe (b, b, c))
forall a. MVar a -> IO a
readMVar MVar (Maybe (b, b, c))
v

fst3 :: (a, b, c) -> a
fst3 (a
x,b
y,c
z) = a
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 :: Cache a -> FilePath -> IO a
readCache Cache a
c FilePath
file = (UTCTime, a) -> a
forall a b. (a, b) -> b
snd ((UTCTime, a) -> a) -> IO (UTCTime, a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Cache a -> FilePath -> IO (UTCTime, a)
forall a. Cache a -> FilePath -> IO (UTCTime, a)
readCache' Cache a
c FilePath
file

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