module Data.TCache.Triggers(DBRef(..),Elem(..),Status(..),addTrigger,applyTriggers) where
import Data.TCache.IResource
import Data.TCache.Defs
import Data.Typeable
import Data.IORef
import System.IO.Unsafe
import Unsafe.Coerce
import GHC.Conc (STM, unsafeIOToSTM)
import Data.Maybe(maybeToList,catMaybes)
import Data.List(nubBy)
import Control.Concurrent.STM
import Debug.Trace
import Data.Maybe(fromJust)
newtype TriggerType a= TriggerType (DBRef a -> Maybe a -> STM()) deriving Typeable
data CMTrigger= forall a.(IResource a, Typeable a) => CMTrigger !((DBRef a) -> Maybe a -> STM())
cmtriggers :: IORef [(TypeRep ,[CMTrigger])]
cmtriggers= unsafePerformIO $ newIORef []
addTrigger :: (IResource a, Typeable a) => ((DBRef a) -> Maybe a -> STM()) -> IO()
addTrigger t= do
map <- readIORef cmtriggers
writeIORef cmtriggers $
let ts = mbToList $ lookup atype map
in nubByType $ (atype ,CMTrigger t : ts) : map
where
nubByType= nubBy (\(t,_)(t',_) -> t==t')
(_,(atype:_))= splitTyConApp . typeOf $ TriggerType t
mbToList mxs= case mxs of Nothing -> []; Just xs -> xs
applyTriggers:: (IResource a, Typeable a) => [DBRef a] -> [Maybe a] -> STM()
applyTriggers [] _ = return()
applyTriggers dbrfs mas = do
map <- unsafeIOToSTM $ readIORef cmtriggers
let ts = mbToList $ lookup (typeOf $ fromJust (head mas)) map
mapM_ f ts
where
f t= mapM2_ (f1 t) dbrfs mas
f1 ::(IResource a, Typeable a) => CMTrigger -> DBRef a -> Maybe a -> STM()
f1 (CMTrigger t) dbref ma = (unsafeCoerce t) dbref ma
mapM2_ _ [] _= return()
mapM2_ f (x:xs) (y:ys)= f x y >> mapM2_ f xs ys