Debug.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Conjure.Debug
-- Copyright   :  (c) ADEpt 2005
-- License     :  BSD-like
--
-- Maintainer  :  adept@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-----------------------------------------------------------------------------
-- TODO: make it not THAT trivial
module Conjure.Debug
    ( debug
    , initSTMLogger
    , stmTransactionName
    , stmDebug
    ) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import System.IO.Unsafe
import GHC.Conc                   ( unsafeIOToSTM )

import qualified Data.Map as Map
import Data.Map ( Map )

import Conjure.Utils.Logger()

debug :: String -> IO ()
debug = putStrLn -- syslog Debug


--------------------------------------------------------------
-- Non-portable STM debugger
--------------------------------------------------------------

{-# NOINLINE stmLog #-}
stmLog :: TVar (Map ThreadId (String, [String]))
stmLog = unsafePerformIO (newTVarIO Map.empty)

initSTMLogger :: IO ()
initSTMLogger
    = do evaluate stmLog
         forkIO $ loop $
           do msgs <- atomically $
                      do msgs <- readTVar stmLog
                         when (Map.null msgs) retry
                         writeTVar stmLog Map.empty
                         return (Map.elems msgs)
              mapM_ printMsg msgs
         debug "STMLogger initialized"
    where loop fn = fn >> loop fn
          printMsg (name,strs)
              | null strs
                  = return ()
              | null name
                  = mapM_ putStrLn (reverse strs)
              | otherwise
                  = do putStrLn (name++":")
                       mapM_ (\str -> putStr "  " >> putStrLn str) (reverse strs)

stmTransactionName :: String -> STM ()
stmTransactionName name
    = do tid <- unsafeIOToSTM myThreadId
         msgs <- readTVar stmLog
         case Map.lookup tid msgs of
           Nothing -> writeTVar stmLog (Map.singleton tid (name,[]))
           Just (name',strs)
               | null name'
                   -> writeTVar stmLog (Map.singleton tid (name,strs))
               | otherwise
                   -> retry

stmDebug :: String -> STM ()
stmDebug str
    = do tid <- unsafeIOToSTM myThreadId
         msgs <- readTVar stmLog
         writeTVar stmLog (Map.insertWith joinInfo tid ("",[str]) msgs)
    where joinInfo ("",[string]) (name,strings) = (name,string:strings)
          joinInfo (name,strings) ("",[string]) = (name,string:strings)