-- | Tracing utilities
module GHC.Utils.Trace
  ( pprTrace
  , pprTraceM
  , pprTraceDebug
  , pprTraceIt
  , pprTraceWith
  , pprSTrace
  , pprTraceException
  , warnPprTrace
  , warnPprTraceM
  , pprTraceUserWarning
  , trace
  )
where

{- Note [Exporting pprTrace from GHC.Prelude]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For our own sanity we want to export pprTrace from GHC.Prelude.
Since calls to traces should never be performance sensitive it's okay for these
to be source imports/exports. However we still need to make sure that all
transitive imports from Trace.hs-boot do not import GHC.Prelude.

To get there we import the basic GHC.Prelude.Basic prelude instead of GHC.Prelude
within the transitive dependencies of Trace.hs
-}

import GHC.Prelude.Basic
import GHC.Utils.Outputable
import GHC.Utils.Exception
import GHC.Utils.Panic
import GHC.Utils.GlobalVars
import GHC.Utils.Constants
import GHC.Stack

import Debug.Trace (trace)
import Control.Monad.IO.Class

-- | If debug output is on, show some 'SDoc' on the screen
pprTrace :: String -> SDoc -> a -> a
pprTrace :: forall a. String -> SDoc -> a -> a
pprTrace String
str SDoc
doc a
x
  | Bool
unsafeHasNoDebugOutput = a
x
  | Bool
otherwise              = SDocContext -> (String -> a -> a) -> SDoc -> SDoc -> a -> a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
traceSDocContext String -> a -> a
forall a. String -> a -> a
trace (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
str) SDoc
doc a
x

pprTraceM :: Applicative f => String -> SDoc -> f ()
pprTraceM :: forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
pprTraceM String
str SDoc
doc = String -> SDoc -> f () -> f ()
forall a. String -> SDoc -> a -> a
pprTrace String
str SDoc
doc (() -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

pprTraceDebug :: String -> SDoc -> a -> a
pprTraceDebug :: forall a. String -> SDoc -> a -> a
pprTraceDebug String
str SDoc
doc a
x
   | Bool
debugIsOn Bool -> Bool -> Bool
&& Bool
unsafeHasPprDebug = String -> SDoc -> a -> a
forall a. String -> SDoc -> a -> a
pprTrace String
str SDoc
doc a
x
   | Bool
otherwise                      = a
x

-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.
-- This allows you to print details from the returned value as well as from
-- ambient variables.
pprTraceWith :: String -> (a -> SDoc) -> a -> a
pprTraceWith :: forall a. String -> (a -> SDoc) -> a -> a
pprTraceWith String
desc a -> SDoc
f a
x = String -> SDoc -> a -> a
forall a. String -> SDoc -> a -> a
pprTrace String
desc (a -> SDoc
f a
x) a
x

-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
pprTraceIt :: Outputable a => String -> a -> a
pprTraceIt :: forall a. Outputable a => String -> a -> a
pprTraceIt String
desc a
x = String -> (a -> SDoc) -> a -> a
forall a. String -> (a -> SDoc) -> a -> a
pprTraceWith String
desc a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
x

-- | @pprTraceException desc x action@ runs action, printing a message
-- if it throws an exception.
pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a
pprTraceException :: forall (m :: * -> *) a.
ExceptionMonad m =>
String -> SDoc -> m a -> m a
pprTraceException String
heading SDoc
doc =
    (GhcException -> m a) -> m a -> m a
forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException ((GhcException -> m a) -> m a -> m a)
-> (GhcException -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \GhcException
exc -> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext
                 (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
                 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
heading, Int -> SDoc -> SDoc
nest Int
2 SDoc
doc]
        GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO GhcException
exc

-- | If debug output is on, show some 'SDoc' on the screen along
-- with a call stack when available.
pprSTrace :: HasCallStack => SDoc -> a -> a
pprSTrace :: forall a. HasCallStack => SDoc -> a -> a
pprSTrace SDoc
doc = String -> SDoc -> a -> a
forall a. String -> SDoc -> a -> a
pprTrace String
"" (SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
HasCallStack => SDoc
traceCallStackDoc)

-- | Just warn about an assertion failure, recording the given file and line number.
warnPprTrace :: HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace :: forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
_     String
_s SDoc
_    a
x | Bool -> Bool
not Bool
debugIsOn     = a
x
warnPprTrace Bool
_     String
_s SDoc
_msg a
x | Bool
unsafeHasNoDebugOutput = a
x
warnPprTrace Bool
False String
_s SDoc
_msg a
x = a
x
warnPprTrace Bool
True   String
s  SDoc
msg a
x
  = SDocContext -> (String -> a -> a) -> SDoc -> SDoc -> a -> a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
traceSDocContext String -> a -> a
forall a. String -> a -> a
trace (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WARNING:")
                    (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
s SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (HasCallStack => SDoc) -> SDoc
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack SDoc
HasCallStack => SDoc
traceCallStackDoc )
                    a
x

warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f ()
warnPprTraceM :: forall (f :: * -> *).
(Applicative f, HasCallStack) =>
Bool -> String -> SDoc -> f ()
warnPprTraceM Bool
b String
s SDoc
doc = (HasCallStack => Bool -> String -> SDoc -> f () -> f ())
-> Bool -> String -> SDoc -> f () -> f ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => Bool -> String -> SDoc -> f () -> f ()
Bool -> String -> SDoc -> f () -> f ()
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
b String
s SDoc
doc (() -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | For when we want to show the user a non-fatal WARNING so that they can
-- report a GHC bug, but don't want to panic.
pprTraceUserWarning :: HasCallStack => SDoc -> a -> a
pprTraceUserWarning :: forall a. HasCallStack => SDoc -> a -> a
pprTraceUserWarning SDoc
msg a
x
  | Bool
unsafeHasNoDebugOutput = a
x
  | Bool
otherwise = SDocContext -> (String -> a -> a) -> SDoc -> SDoc -> a -> a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
traceSDocContext String -> a -> a
forall a. String -> a -> a
trace (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WARNING:")
                    (SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ (HasCallStack => SDoc) -> SDoc
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack SDoc
HasCallStack => SDoc
traceCallStackDoc )
                    a
x

traceCallStackDoc :: HasCallStack => SDoc
traceCallStackDoc :: HasCallStack => SDoc
traceCallStackDoc =
    SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Call stack:")
       Int
4 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text ([String] -> [SDoc]) -> [String] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack))