-- | Tracing utilities
module GHC.Utils.Trace
  ( pprTrace
  , pprTraceM
  , pprTraceDebug
  , pprTraceIt
  , pprTraceWith
  , pprSTrace
  , pprTraceException
  , warnPprTrace
  , 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              = forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
traceSDocContext forall a. String -> a -> a
trace (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 = forall a. String -> SDoc -> a -> a
pprTrace String
str SDoc
doc (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 = 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 = 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 = forall a. String -> (a -> SDoc) -> a -> a
pprTraceWith String
desc 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 =
    forall (m :: * -> *) a.
ExceptionMonad m =>
(GhcException -> m a) -> m a -> m a
handleGhcException forall a b. (a -> b) -> a -> b
$ \GhcException
exc -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext
                 forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle
                 forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [doc] -> doc
sep [forall doc. IsLine doc => String -> doc
text String
heading, Int -> SDoc -> SDoc
nest Int
2 SDoc
doc]
        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 = forall a. String -> SDoc -> a -> a
pprTrace String
"" (SDoc
doc forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
  = forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
traceSDocContext forall a. String -> a -> a
trace (forall doc. IsLine doc => String -> doc
text String
"WARNING:")
                    (forall doc. IsLine doc => String -> doc
text String
s forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
msg forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => SDoc
traceCallStackDoc )
                    a
x

-- | 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 = forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
traceSDocContext forall a. String -> a -> a
trace (forall doc. IsLine doc => String -> doc
text String
"WARNING:")
                    (SDoc
msg forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => SDoc
traceCallStackDoc )
                    a
x

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