MonadLabelledSTM: added labelTChan

Author: coot

io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs

@@ -433,6 +433,7 @@ class MonadSTM m
   labelTArray  :: (Ix i, Show i)
                => TArray  m i e -> String -> STM m ()
   labelTSem    :: TSem    m     -> String -> STM m ()
+  labelTChan   :: TChan   m a   -> String -> STM m ()
 
   labelTVarIO    :: TVar    m a   -> String -> m ()
   labelTMVarIO   :: TMVar   m a   -> String -> m ()
@@ -441,6 +442,7 @@ class MonadSTM m
   labelTArrayIO  :: (Ix i, Show i)
                  => TArray  m i e -> String -> m ()
   labelTSemIO    :: TSem    m     -> String -> m ()
+  labelTChanIO   :: TChan   m a   -> String -> m ()
 
   --
   -- default implementations
@@ -462,6 +464,10 @@ class MonadSTM m
                     => TSem m -> String -> STM m ()
   labelTSem = labelTSemDefault
 
+  default labelTChan :: TChan m ~ TChanDefault m
+                     => TChan m a -> String -> STM m ()
+  labelTChan = labelTChanDefault
+
   default labelTArray :: ( TArray m ~ TArrayDefault m
                          , Ix i
                          , Show i
@@ -488,6 +494,9 @@ class MonadSTM m
   default labelTSemIO :: TSem m -> String -> m ()
   labelTSemIO = \v l -> atomically (labelTSem v l)
 
+  default labelTChanIO :: TChan m a -> String -> m ()
+  labelTChanIO = \v l -> atomically (labelTChan v l)
+
 
 -- | This type class is indented for 'io-sim', where one might want to access
 -- 'TVar' in the underlying 'ST' monad.
@@ -738,13 +747,15 @@ instance MonadLabelledSTM IO where
   labelTBQueue = \_  _ -> return ()
   labelTArray  = \_  _ -> return ()
   labelTSem    = \_  _ -> return ()
+  labelTChan   = \_  _ -> return ()
 
   labelTVarIO    = \_  _ -> return ()
   labelTMVarIO   = \_  _ -> return ()
   labelTQueueIO  = \_  _ -> return ()
   labelTBQueueIO = \_  _ -> return ()
   labelTArrayIO  = \_  _ -> return ()
   labelTSemIO    = \_  _ -> return ()
+  labelTChanIO   = \_  _ -> return ()
 
 -- | noop instance
 --
@@ -1183,6 +1194,11 @@ data TList m a = TNil | TCons a (TVarList m a)
 
 data TChanDefault m a = TChan (TVar m (TVarList m a)) (TVar m (TVarList m a))
 
+labelTChanDefault :: MonadLabelledSTM m => TChanDefault m a -> String -> STM m ()
+labelTChanDefault (TChan read write) name = do
+  labelTVar read  (name ++ ":read")
+  labelTVar write (name ++ ":write")
+
 newTChanDefault :: MonadSTM m => STM m (TChanDefault m a)
 newTChanDefault = do
   hole <- newTVar TNil