Debug.hs

-- | An internal Snap module for (optionally) printing debugging messages. To
-- enable debug output, compile the library with the @debug@ flag (off by
-- default) and set the environment variable @DEBUG@ to @1@. We use
-- 'unsafePerformIO' to make sure that the call to 'getEnv' is only made once.
--
-- /N.B./ this is an internal interface, please don't write external code that
-- depends on it.

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-cse         #-}


module Snap.Internal.Debug (debug, debugErrno) where

------------------------------------------------------------------------------
import           Control.Monad.IO.Class (MonadIO (..))

#ifndef NODEBUG
import           Control.Concurrent     (MVar, myThreadId, newMVar, withMVar)
import           Control.Exception      (SomeException, try)
import           Data.Char              (toLower)
import           Data.List              (stripPrefix)
import           Data.Maybe             (fromMaybe)
import           Foreign.C.Error        (errnoToIOError, getErrno)
import           System.Environment     (getEnv)
import           System.IO              (hFlush, hPutStrLn, stderr)
import           System.IO.Unsafe       (unsafePerformIO)
import           Text.Printf            (printf)
#endif
------------------------------------------------------------------------------

-- | Print out the provided debug message prefixed by the thread ID.
--
-- Example:
--
-- @
-- ghci> debug "Some debug message"
-- [     225] Some debug message
-- @
debug :: MonadIO m => String -> m ()


-- | Print out the error message corresponding to the 'Foreign.C.Error.Errno'
-- value returned by 'Foreign.C.Error.getErrno' together with any additional
-- information provided by the user (usually the location where the error
-- occurred).
--
-- Example:
--
-- @
-- ghci> debugErrno "path/to/Source.hs:34"
-- [     323] path/to/Source.hs:34: failed (Success)
-- @
debugErrno :: MonadIO m => String -> m ()


#ifndef NODEBUG

{-# NOINLINE debug #-}
debug = let !x = unsafePerformIO $ do
                !e <- try $ getEnv "DEBUG"

                !f <- either (\(_::SomeException) -> return debugIgnore)
                             (\y0 -> let y = map toLower y0
                                     in if y == "1" || y == "on"
                                       then return debugOn
                                       else if y == "testsuite"
                                              then return debugSeq
                                              else return debugIgnore)
                             e
                return $! f
        in x


{-# NOINLINE debugErrno #-}
debugErrno = let !x = unsafePerformIO $ do
                     e <- try $ getEnv "DEBUG"
                     !f <- either (\(_::SomeException) -> return debugErrnoIgnore)
                                  (\y0 -> let y = map toLower y0
                                          in if y == "1" || y == "on"
                                            then return debugErrnoOn
                                            else if y == "testsuite"
                                                   then return debugSeq
                                                   else return debugErrnoIgnore)
                                  e
                     return $! f
             in x


------------------------------------------------------------------------------
debugSeq :: (MonadIO m) => String -> m ()
debugSeq !s = length s `seq` return $! ()
{-# NOINLINE debugSeq #-}

------------------------------------------------------------------------------
_debugMVar :: MVar ()
_debugMVar = unsafePerformIO $ newMVar ()
{-# NOINLINE _debugMVar #-}


------------------------------------------------------------------------------
debugOn :: (MonadIO m) => String -> m ()
debugOn s = liftIO $ withMVar _debugMVar $ \_ -> do
                tid <- myThreadId
                hPutStrLn stderr $ s' tid
                hFlush stderr
  where
    chop x = let y = fromMaybe x $ stripPrefix "ThreadId " x
             in printf "%8s" y

    s' t   = "[" ++ chop (show t) ++ "] " ++ s

{-# NOINLINE debugOn #-}


------------------------------------------------------------------------------
debugErrnoOn :: (MonadIO m) => String -> m ()
debugErrnoOn loc = liftIO $ do
    err <- getErrno
    let ex = errnoToIOError loc err Nothing Nothing
    debug $ show ex
------------------------------------------------------------------------------

#else

debug      = debugIgnore
{-# INLINE debug #-}

debugErrno = debugErrnoIgnore
{-# INLINE debugErrno #-}

#endif

------------------------------------------------------------------------------
debugIgnore :: (MonadIO m) => String -> m ()
debugIgnore _ = return ()
{-# INLINE debugIgnore #-}

debugErrnoIgnore :: (MonadIO m) => String -> m ()
debugErrnoIgnore _ = return ()
{-# INLINE debugErrnoIgnore #-}
------------------------------------------------------------------------------