module Data.Concurrent.Deque.Debugger
(DebugDeque(DebugDeque))
where
import Data.IORef
import Control.Concurrent
import Data.Concurrent.Deque.Class
data DebugDeque d elt = DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId)) (d elt)
instance DequeClass d => DequeClass (DebugDeque d) where
pushL :: forall elt. DebugDeque d elt -> elt -> IO ()
pushL (DebugDeque (IORef (Maybe ThreadId)
ref,IORef (Maybe ThreadId)
_) d elt
q) elt
elt = do
Bool -> IORef (Maybe ThreadId) -> IO ()
markThread (forall (d :: * -> *) elt. DequeClass d => d elt -> Bool
leftThreadSafe d elt
q) IORef (Maybe ThreadId)
ref
forall (d :: * -> *) elt. DequeClass d => d elt -> elt -> IO ()
pushL d elt
q elt
elt
tryPopR :: forall elt. DebugDeque d elt -> IO (Maybe elt)
tryPopR (DebugDeque (IORef (Maybe ThreadId)
_,IORef (Maybe ThreadId)
ref) d elt
q) = do
Bool -> IORef (Maybe ThreadId) -> IO ()
markThread (forall (d :: * -> *) elt. DequeClass d => d elt -> Bool
rightThreadSafe d elt
q) IORef (Maybe ThreadId)
ref
forall (d :: * -> *) elt. DequeClass d => d elt -> IO (Maybe elt)
tryPopR d elt
q
newQ :: forall elt. IO (DebugDeque d elt)
newQ = do IORef (Maybe ThreadId)
l <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
IORef (Maybe ThreadId)
r <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (d :: * -> *) elt.
(IORef (Maybe ThreadId), IORef (Maybe ThreadId))
-> d elt -> DebugDeque d elt
DebugDeque (IORef (Maybe ThreadId)
l,IORef (Maybe ThreadId)
r)) forall (d :: * -> *) elt. DequeClass d => IO (d elt)
newQ
nullQ :: forall elt. DebugDeque d elt -> IO Bool
nullQ (DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId))
_ d elt
q) = forall (d :: * -> *) elt. DequeClass d => d elt -> IO Bool
nullQ d elt
q
leftThreadSafe :: forall elt. DebugDeque d elt -> Bool
leftThreadSafe (DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId))
_ d elt
q) = forall (d :: * -> *) elt. DequeClass d => d elt -> Bool
leftThreadSafe d elt
q
rightThreadSafe :: forall elt. DebugDeque d elt -> Bool
rightThreadSafe (DebugDeque (IORef (Maybe ThreadId), IORef (Maybe ThreadId))
_ d elt
q) = forall (d :: * -> *) elt. DequeClass d => d elt -> Bool
rightThreadSafe d elt
q
instance PopL d => PopL (DebugDeque d) where
tryPopL :: forall elt. DebugDeque d elt -> IO (Maybe elt)
tryPopL (DebugDeque (IORef (Maybe ThreadId)
ref,IORef (Maybe ThreadId)
_) d elt
q) = do
Bool -> IORef (Maybe ThreadId) -> IO ()
markThread (forall (d :: * -> *) elt. DequeClass d => d elt -> Bool
leftThreadSafe d elt
q) IORef (Maybe ThreadId)
ref
forall (d :: * -> *) elt. PopL d => d elt -> IO (Maybe elt)
tryPopL d elt
q
markThread :: Bool -> IORef (Maybe ThreadId) -> IO ()
markThread Bool
True IORef (Maybe ThreadId)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
markThread Bool
False IORef (Maybe ThreadId)
ref = do
Maybe ThreadId
last <- forall a. IORef a -> IO a
readIORef IORef (Maybe ThreadId)
ref
ThreadId
tid <- IO ThreadId
myThreadId
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (Maybe ThreadId)
ref forall a b. (a -> b) -> a -> b
$ \ Maybe ThreadId
x ->
case Maybe ThreadId
x of
Maybe ThreadId
Nothing -> (forall a. a -> Maybe a
Just ThreadId
tid, ())
Just ThreadId
tid2
| ThreadId
tid forall a. Eq a => a -> a -> Bool
== ThreadId
tid2 -> (forall a. a -> Maybe a
Just ThreadId
tid,())
| Bool
otherwise -> forall a. HasCallStack => [Char] -> a
errorforall a b. (a -> b) -> a -> b
$ [Char]
"DebugDeque: invariant violated, thread safety not allowed but accessed by: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> [Char]
show (ThreadId
tid,ThreadId
tid2)