-----------------------------------------------------------------------------
-- |
-- Module      :  Data.TMap
-- Copyright   :  Peter Robinson 2009
-- License     :  LGPL
--
-- Maintainer  :  Peter Robinson <thaldyron@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- Provides a thread-safe STM interface for finite map types with optional persistent
-- storage.
--
-----------------------------------------------------------------------------

module Data.TMap( -- * TMap 
                  TMap, 
                  -- * Creating a new TMap
                  newTMapIO, 
                  -- * Finite Map Interace
                  lookup, 
                  insert, 
                  delete, 
                  member, 
                  adjust, 
                  -- * Handling the size of the TMap 
                  purgeTMap, 
                  purgeTMapIO, 
                  getMaximumSize, 
                  setMaximumSize, 
                  getCurrentSize,
                  -- * Flushing the backend
                  flushBackend,
                  -- * Exception Type
                  TMapException(..),
                  )
where

import Control.Concurrent.AdvSTM
import Control.Concurrent.AdvSTM.TVar
-- import Control.Monad.CatchIO
import Control.Monad( liftM, when )
import Control.Monad.Trans( MonadIO, liftIO )

import qualified Control.Exception as Exc
import Data.Maybe( isJust )
import Prelude hiding (lookup,catch)

import qualified Data.TMap.Backend as B
import qualified Data.CacheStructure as C
import Data.TMap.Exception( TMapException(..) )

import qualified Data.Edison.Assoc as M


--------------------------------------------------------------------------------


data Entry a = Entry a         -- ^ Cache hit
             | NotInTMap       -- ^ Cache miss
             | NotInBackend    -- ^ Element exists neither in backend nor in cache
             deriving (Show,Eq)

instance Functor Entry where
  fmap _ NotInBackend = NotInBackend
  fmap _ NotInTMap    = NotInTMap
  fmap f (Entry a)    = Entry (f a)


data TMap map k a b c = TMap 
  { backend  :: B.Backend k a b => b k a
  , sizeTVar :: TVar (Maybe Int)
  , tmapTVar :: (M.FiniteMapX map k, C.CacheStructure c k) 
             => TVar (map (Entry a),c k)
  }


--------------------------------------------------------------------------------

-- | Creates a new TMap. You will need to use an apropriate backend and specify
-- the caching policy, e.g.,
--
-- @
--   import Data.TMap.Backend.Binary( BinaryBackend,mkBinaryBackend )
--   import Data.TMap.CacheStructure.LRU
-- @
--
-- will use a binary-serialization backend for persistent storage and a \"least recently
-- used\" caching algorithm.
--
-- Now, to create an unbounded map that uses the 'FM Int String' (see package EdisonCore) 
-- as the map type, you can write
--
-- @
--   backend <- mkBinaryBackend \"myworkdir\" \"mytempdir\"
--   tmap <- newTMapIO backend Nothing :: IO (TMap (FM Int) Int String BinaryBackend LRU)
-- @
newTMapIO :: (M.FiniteMapX map k, Ord k, B.Backend k a b,C.CacheStructure c k) 
          => b k a            -- ^ the backend
          -> Maybe Int        -- ^ maximum-size: Use 'Nothing' for unbounded size.
          -> IO (TMap map k a b c)
newTMapIO b maxsize = do 
  tvar <- newTVarIO (M.empty,C.empty)
  tvarSize <- newTVarIO maxsize
  B.initialize b
  return $ TMap b tvarSize tvar 

{-
 - Deactivated --- Can cause a non-terminating retry-loop when used with lookup k:
 - When key 'k' is not found lookup retries.  (Cond 1)
 - But this causes the creation of the tmap to be rolled back too, and so 
 - (Cond 1) holds forever.
newTMap :: (M.FiniteMapX map k, Ord k, B.Backend k a b, MonadAdvSTM m) 
            => b -> m (TMap map k a b)
newTMap b = do 
  tvar <- newTVar M.empty 
  return $ TMap b tvar 
-}


-- | Looks for a given key in the map and (if necessary) in the persistent storage 
-- and updates the map if necessary.
lookup :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k)
       => k -> TMap map k a b c -> m (Maybe a) 
lookup k tmap = do
  (themap,accSeq) <- readTVar (tmapTVar tmap)
  case M.lookupWithDefault NotInTMap k themap of
    Entry v      -> do 
      writeTVar (tmapTVar tmap) (themap,C.hit k accSeq)
--      onCommit $ print ("OldAccess List: ",C.toList accSeq)
--      onCommit $ print ("NewAccess List: ",C.toList $ C.hit k accSeq)
      return $ Just v
    NotInBackend -> return Nothing
    NotInTMap    -> retryWith $ do 
--      print $ "Lookup: Didn't find " ++ show k ++ ", retrying lookup..."
      result <- B.lookup (backend tmap) k 
      case result of 
        Nothing -> do 
--          print "Entry not in backend"
          atomically $ do 
            (themap',accSeq') <- readTVar (tmapTVar tmap)
            writeTVar (tmapTVar tmap) (M.insert k (NotInBackend) themap', accSeq')
        Just v  -> do 
--          print "Found entry in backend"
          atomically $ do 
            (themap',accSeq') <- readTVar (tmapTVar tmap)
            writeTVar (tmapTVar tmap) ( M.insert k (Entry v) themap'
                                      , C.hit k accSeq')
--            onCommit $ print ("Access List: ",C.toList $ C.hit k accSeq')

-- | Checks whether the given key is in the map.
member :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k) 
       => k -> TMap map k a b c -> m Bool
member k tmap = liftM isJust (lookup k tmap)


-- | Adds a key-value mapping to the map. Can throw a 'DuplicateEntry'
-- exception.
insert :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) 
       => k -> a -> TMap map k a b c -> m () 
insert k a tmap = do
  res <- lookup k tmap 
  case res of
    Just _  -> Exc.throw $ DuplicateEntry -- (show (k,v))
    Nothing -> do
      (themap,accSeq) <- readTVar (tmapTVar tmap)
      writeTVar (tmapTVar tmap) ( M.insert k (Entry a) themap
                                , C.hit k accSeq)
      onCommit $ B.insert (backend tmap) k a


-- | Applies a function to the element identified by the key. Can throw an 'EntryNotFound' exception.
adjust :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) 
       => (a -> a) -> k -> TMap map k a b c -> m () 
adjust f k tmap = do
  res <- lookup k tmap 
  case res of
    Nothing -> Exc.throw EntryNotFound 
    Just _  -> do
      (themap,accSeq) <- readTVar (tmapTVar tmap)
      writeTVar (tmapTVar tmap) (M.adjust (fmap f) k themap, C.hit k accSeq)
      onCommit $ B.adjust (backend tmap) f k 


-- | Removes a key from the map. Can throw an 'EntryNotFound' exception.
delete :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k) 
       => k -> TMap map k a b c -> m () 
delete k tmap = do
  res <- lookup k tmap 
  case res of
    Nothing -> Exc.throw EntryNotFound 
    Just _  -> do
      (themap,accSeq) <- readTVar (tmapTVar tmap)
      writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap, accSeq)
      onCommit $ B.delete (backend tmap) k 

--------------------------------------------------------------------------------

-- | Reduces the map to the appropriate size if the maximum size was exceeded.
-- Calls /Data.TMap.Backend.flush/ if the map is purged.
-- Runs in /O(1)/ if the map size is within bounds, otherwise /O(n)/.
purgeTMapIO :: (M.FiniteMapX map k, MonadIO m, Ord k, B.Backend k a b, C.CacheStructure c k) 
            => TMap map k a b c -> m ()
purgeTMapIO tmap = liftIO . atomically  $ purgeTMap tmap           


-- | Reduces the map to the appropriate size if the maximum size was exceeded.
-- Calls /Data.TMap.Backend.flush/ if the map is purged.
-- Runs in /O(1)/ if the map size is within bounds, otherwise /O(n)/. 
-- /Warning:/ This function should always be called at the end of a transaction to
-- prevent nonterminating retry-loops!
purgeTMap :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) 
          => TMap map k a b c -> m () 
purgeTMap tmap =   do
  mSize <- readTVar (sizeTVar tmap)
  case mSize of
    Just maxSize -> do
      (themap,accSeq) <- readTVar (tmapTVar tmap)
--      onCommit $ print ("Old List: ",C.toList accSeq)
      when (C.size accSeq > maxSize) $ do
        let (restSeq,delSeq) = C.popMany (C.size accSeq - maxSize) accSeq
        writeTVar (tmapTVar tmap) (foldr M.delete themap delSeq, restSeq)
        onCommit $ B.flush (backend tmap)
--        onCommit $ print ("Purged List: ",C.toList restSeq)
    Nothing -> return ()

--------------------------------------------------------------------------------

-- | Sets the maximum size of the map. /O(1)/. Note that the size of the TMap needs
-- to be reduced manually to the maximum size by calling /purgeTMap/.
setMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) 
               => TMap map k a b  c -> Int -> m () 
setMaximumSize tmap maxSize
  | maxSize <= 0 = Exc.throw $ TMapDefaultExc "setMaximumSize: Invalid size specified."
  | otherwise    = writeTVar (sizeTVar tmap) $ Just maxSize

-- | Gets the maximum size of the map. /O(1)/.
getMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) 
               => TMap map k a b c 
               -> m (Maybe Int)
getMaximumSize tmap 
  | otherwise = readTVar (sizeTVar tmap) 


-- | Gets the current size of the map. /O(1)/.
getCurrentSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) 
               => TMap map k a b c 
               -> m Int
getCurrentSize tmap = do
  (_,accSeq) <- readTVar (tmapTVar tmap) 
  return $ C.size accSeq


--------------------------------------------------------------------------------

-- | Sends a /B.flush/ request to the backend. Useful for asynchronous backend
-- implementations.
flushBackend :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k) 
             => TMap map k a b c -> IO ()
flushBackend tmap = B.flush (backend tmap)