{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}

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(fromMaybe, fromJust)
import Data.List(nubBy)

--import Debug.Trace

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])]
{-# NOINLINE cmtriggers #-}
cmtriggers :: IORef [(TypeRep, [CMTrigger])]
cmtriggers = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []



{- | Add an user defined trigger to the list of triggers
Trriggers are called just before an object of the given type is created, modified or deleted.
The DBRef to the object and the new value is passed to the trigger.
The called trigger function has two parameters: the DBRef being accesed
(which still contains the old value), and the new value.
If the DBRef is being deleted, the second parameter is 'Nothing'.
if the DBRef contains Nothing, then the object is being created
-}
addTrigger :: (IResource a, Typeable a) => (DBRef a -> Maybe a -> STM()) -> IO()
addTrigger :: forall a.
(IResource a, Typeable a) =>
(DBRef a -> Maybe a -> STM ()) -> IO ()
addTrigger  DBRef a -> Maybe a -> STM ()
tr = do
   [(TypeRep, [CMTrigger])]
map' <-  forall a. IORef a -> IO a
readIORef IORef [(TypeRep, [CMTrigger])]
cmtriggers
   forall a. IORef a -> a -> IO ()
writeIORef IORef [(TypeRep, [CMTrigger])]
cmtriggers forall a b. (a -> b) -> a -> b
$
      let ts :: [CMTrigger]
ts = forall a. Maybe [a] -> [a]
mbToList forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TypeRep
atype [(TypeRep, [CMTrigger])]
map'
          in  forall {b}. [(TypeRep, b)] -> [(TypeRep, b)]
nubByType forall a b. (a -> b) -> a -> b
$ (TypeRep
atype ,forall a.
(IResource a, Typeable a) =>
(DBRef a -> Maybe a -> STM ()) -> CMTrigger
CMTrigger DBRef a -> Maybe a -> STM ()
tr forall a. a -> [a] -> [a]
: [CMTrigger]
ts) forall a. a -> [a] -> [a]
: [(TypeRep, [CMTrigger])]
map'
  where
  nubByType :: [(TypeRep, b)] -> [(TypeRep, b)]
nubByType= forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\(TypeRep
t,b
_)(TypeRep
t',b
_) -> TypeRep
tforall a. Eq a => a -> a -> Bool
==TypeRep
t')
  (TyCon
_,TypeRep
atype:[TypeRep]
_)= TypeRep -> (TyCon, [TypeRep])
splitTyConApp  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> TypeRep
typeOf forall a b. (a -> b) -> a -> b
$ forall a. (DBRef a -> Maybe a -> STM ()) -> TriggerType a
TriggerType DBRef a -> Maybe a -> STM ()
tr



mbToList :: Maybe [a] -> [a]
mbToList :: forall a. Maybe [a] -> [a]
mbToList = forall a. a -> Maybe a -> a
fromMaybe []

-- | internally called when a DBRef is modified/deleted/created
applyTriggers:: (IResource a, Typeable a) => [DBRef a] -> [Maybe a] -> STM()
applyTriggers :: forall a.
(IResource a, Typeable a) =>
[DBRef a] -> [Maybe a] -> STM ()
applyTriggers  [] [Maybe a]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return()
applyTriggers  [DBRef a]
dbrfs [Maybe a]
mas = do
   [(TypeRep, [CMTrigger])]
map' <- forall a. IO a -> STM a
unsafeIOToSTM forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef [(TypeRep, [CMTrigger])]
cmtriggers
   let ts :: [CMTrigger]
ts = forall a. Maybe [a] -> [a]
mbToList forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup   (forall a. Typeable a => a -> TypeRep
typeOf forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust (forall a. [a] -> a
head [Maybe a]
mas)) [(TypeRep, [CMTrigger])]
map'
   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CMTrigger -> STM ()
f  [CMTrigger]
ts

   where
   f :: CMTrigger -> STM ()
f CMTrigger
t= forall (m :: * -> *) t1 t2 a.
Monad m =>
(t1 -> t2 -> m a) -> [t1] -> [t2] -> m ()
mapM2_ (forall a.
(IResource a, Typeable a) =>
CMTrigger -> DBRef a -> Maybe a -> STM ()
f1 CMTrigger
t)  [DBRef a]
dbrfs  [Maybe a]
mas

   f1 ::(IResource a, Typeable a) =>  CMTrigger -> DBRef a -> Maybe a ->  STM()
   f1 :: forall a.
(IResource a, Typeable a) =>
CMTrigger -> DBRef a -> Maybe a -> STM ()
f1 (CMTrigger DBRef a -> Maybe a -> STM ()
t)= forall a b. a -> b
unsafeCoerce DBRef a -> Maybe a -> STM ()
t



mapM2_ :: Monad m => (t1 -> t2 -> m a) -> [t1] -> [t2] -> m ()
mapM2_ :: forall (m :: * -> *) t1 t2 a.
Monad m =>
(t1 -> t2 -> m a) -> [t1] -> [t2] -> m ()
mapM2_ t1 -> t2 -> m a
_ [] [t2]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return()
mapM2_ t1 -> t2 -> m a
_ [t1]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return()
mapM2_ t1 -> t2 -> m a
f (t1
x:[t1]
xs) (t2
y:[t2]
ys)=  t1 -> t2 -> m a
f t1
x t2
y forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) t1 t2 a.
Monad m =>
(t1 -> t2 -> m a) -> [t1] -> [t2] -> m ()
mapM2_ t1 -> t2 -> m a
f [t1]
xs [t2]
ys