DPut Trace Variations

        tput - like dput, but works in any Applicative
        dtrace - like trace, but takes DebugTag

3 files changed, 33 insertions, 19 deletions

diff --git a/src/DPut.hs b/src/DPut.hs
index 52714086..1b87eb93 100644
--- a/src/DPut.hs
+++ b/src/DPut.hs
@@ -27,6 +27,14 @@ dput tag msg = liftIO $ debugM (appName <.> show tag) msg
 dputB :: MonadIO m => DebugTag -> B.ByteString -> m ()
 dputB tag msg = liftIO $ debugM (appName <.> show tag) (T.unpack . T.decodeUtf8 $ msg)
 
+-- | Trace version of 'dput' works in arbitrary monad, using unsafePerformIO.
+tput :: Applicative m => DebugTag -> String -> m ()
+tput tag msg = (unsafePerformIO $ dput tag msg) `seq` pure ()
+
+-- | like 'trace' but parameterized with 'DebugTag'
+dtrace :: DebugTag -> String -> a -> a
+dtrace tag msg result = (unsafePerformIO $ dput tag msg) `seq` result
+
 setTagLevel :: Priority -> DebugTag -> IO ()
 setTagLevel level tag = updateGlobalLogger (appName <.> show tag) (setLevel level)
 
diff --git a/src/Data/PacketQueue.hs b/src/Data/PacketQueue.hs
index e0221f5a..8182706e 100644
--- a/src/Data/PacketQueue.hs
+++ b/src/Data/PacketQueue.hs
@@ -35,7 +35,7 @@ import Control.Applicative
 import Data.Word
 import Data.Array.MArray
 import Data.Maybe
-import Debug.Trace
+import DPut
 
 data PacketQueue a = PacketQueue
     { pktq    :: TArray Word32 (Maybe a)
@@ -234,15 +234,18 @@ peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoT
     let arrayEmpty :: MArray a e m => a Word32 e -> m Bool
         arrayEmpty ar = do (lowB,highB) <- getBounds ar
                            let result= lowB > highB
-                           return $ trace ("arrayEmpty result=" ++ show result
+                           tput XNetCrypto
+                                        ("arrayEmpty result=" ++ show result
                                         ++ " lowB="    ++ show lowB
                                         ++ " highB = " ++ show highB
-                                        ++ " i = " ++ show i) result
+                                        ++ " i = " ++ show i)
+                           return result
     mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ)
-                if emp then trace "(peekPacket empty)"    $ return Nothing
-                       else trace "(peekPacket nonempty)" $ do
+                if emp then tput XNetCrypto "(peekPacket empty)" >> return Nothing
+                       else do  tput XNetCrypto "(peekPacket nonempty)"
                                 result <- readArray (pktq pktoOutPQ) i
-                                return $ trace ("readArray (isJust result)=="  ++ show (isJust result)) result
+                                tput XNetCrypto ("readArray (isJust result)=="  ++ show (isJust result))
+                                return result
     pktno <- readTVar pktoPacketNo
     nextno <- readTVar (seqno pktoInPQ)
     pktoToWire getExtra nextno be pktno msg
@@ -252,37 +255,40 @@ peekPacket getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoT
 --   index in this implementation.)
 tryAppendQueueOutgoing :: STM extra -> PacketOutQueue extra msg wire fromwire -> msg -> STM OutGoingResult
 tryAppendQueueOutgoing getExtra q@(PacketOutQueue { pktoInPQ, pktoOutPQ, pktoPacketNo, pktoToWireIO, pktoToWire }) msg
-  = trace "(tryAppendQueueOutgoing)" $ do
+  = dtrace XNetCrypto "(tryAppendQueueOutgoing)" $ do
     be <- readTVar (buffend pktoOutPQ)
     let i = be `mod` (qsize pktoOutPQ)
     let arrayEmpty :: MArray a e m => a Word32 e -> m Bool
         arrayEmpty ar = do (lowB,highB) <- getBounds ar
                            let result= lowB > highB
-                           return $ trace ("arrayEmpty result=" ++ show result
+                           tput XNetCrypto
+                                        ("arrayEmpty result=" ++ show result
                                         ++ " lowB="    ++ show lowB
                                         ++ " highB = " ++ show highB
-                                        ++ " i = " ++ show i) result
+                                        ++ " i = " ++ show i)
+                           return result
     mbPkt <- do emp <- arrayEmpty (pktq pktoOutPQ)
-                if emp then trace "(tryAppendQueueOutgoing empty)"    $ return Nothing
-                       else trace "(tryAppendQueueOutgoing nonempty)" $ do
+                if emp then tput XNetCrypto "(tryAppendQueueOutgoing empty)" >> return Nothing
+                       else do  tput XNetCrypto "(tryAppendQueueOutgoing nonempty)"
                                 result <- readArray (pktq pktoOutPQ) i
-                                return $ trace ("readArray (isJust result)=="  ++ show (isJust result)) result
+                                tput XNetCrypto ("readArray (isJust result)=="  ++ show (isJust result))
+                                return result
     pktno <- readTVar pktoPacketNo
     nextno <- readTVar (seqno pktoInPQ)
     mbWire <- pktoToWire getExtra nextno be pktno msg
     -- TODO all the above lines ^^ can be replaced with call to peekPacket
-    case trace "(tryAppendQueueOutgoing mbWire)" mbWire of
+    case dtrace XNetCrypto "(tryAppendQueueOutgoing mbWire)" mbWire of
         Just (pkt,pktno')
-            -> trace "(tryAppendQueueOutgoing A)"
+            -> dtrace XNetCrypto "(tryAppendQueueOutgoing A)"
              $ case mbPkt of
                     -- slot is free, insert element
-                    Nothing -> trace "(tryAppendQueueOutgoing Nothing case)" $ do
+                    Nothing -> dtrace XNetCrypto "(tryAppendQueueOutgoing Nothing case)" $ do
                         modifyTVar' (buffend pktoOutPQ) (+1)
                         writeTVar pktoPacketNo $! pktno'
                         writeArray (pktq pktoOutPQ) i (Just (pktno,pkt))
                         return OGSuccess
                     -- queue is full
-                    Just (n,_) -> trace "tryAppendQueueOutgoing Just case)" $ do
+                    Just (n,_) -> dtrace XNetCrypto "tryAppendQueueOutgoing Just case)" $ do
                         nn <- getHighestHandledPacketPlus1 q
                         if (n < nn)
                           -- but we can overwrite an old packet
diff --git a/src/Network/Tox/Crypto/Handlers.hs b/src/Network/Tox/Crypto/Handlers.hs
index 457171a9..44b2f26f 100644
--- a/src/Network/Tox/Crypto/Handlers.hs
+++ b/src/Network/Tox/Crypto/Handlers.hs
@@ -681,7 +681,7 @@ createNetCryptoOutQueue sessions newsession theirSessionKey pktq ncMyPacketNonce
 addSessionToMap :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM ()
 addSessionToMap sessions addrRaw netCryptoSession = do
     let addr = either id id $ either4or6 addrRaw
-    let dmsg msg = trace msg (return ())
+    let dmsg msg = tput XNetCrypto msg
     dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession)
     let remotePublicKey = ncTheirPublicKey netCryptoSession
         allsessions     = netCryptoSessions sessions
@@ -695,7 +695,7 @@ addSessionToMap sessions addrRaw netCryptoSession = do
 addSessionToMapIfNotThere :: NetCryptoSessions -> SockAddr -> NetCryptoSession -> STM ()
 addSessionToMapIfNotThere sessions addrRaw netCryptoSession = do
     let addr = either id id $ either4or6 addrRaw
-    let dmsg msg = trace msg (return ())
+    let dmsg msg = tput XNetCrypto msg
     dmsg $ "addSessionToMapIfNotThere sockaddr = " ++ show addr ++ ", sessionid = " ++ show (ncSessionId netCryptoSession)
     let remotePublicKey = ncTheirPublicKey netCryptoSession
         allsessions     = netCryptoSessions sessions
@@ -857,7 +857,7 @@ destroySession session = do
 updateCryptoSession :: NetCryptoSessions -> SockAddr -> SecretKey -> POSIXTime -> HandshakeParams
                     -> NetCryptoSession -> Handshake Encrypted -> STM (Maybe (Handshake Encrypted), IO ())
 updateCryptoSession sessions addr newsession timestamp hp session handshake = do
-    let dmsg msg = trace msg (return ())
+    let dmsg msg = tput XNetCrypto msg
     ncState0 <- readTVar (ncState session)
     ncTheirBaseNonce0 <- readTVar (ncTheirBaseNonce session)
     if (ncState0 >= {-Accepted-}InProgress AwaitingSessionPacket)