-- | Printing related functions that depend on session state (DynFlags)
module GHC.Driver.Ppr
   ( showSDoc
   , showSDocForUser
   , showSDocDebug
   , showSDocDump
   , showPpr
   , pprDebugAndThen
   , printForUser
   , printForC
   -- ** Trace
   , warnPprTrace
   , pprTrace
   , pprTraceWithFlags
   , pprTraceM
   , pprTraceDebug
   , pprTraceIt
   , pprSTrace
   , pprTraceException
   )
where

import GHC.Prelude

import {-# SOURCE #-} GHC.Driver.Session
import {-# SOURCE #-} GHC.Unit.State

import GHC.Utils.Exception
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.GlobalVars
import GHC.Utils.Ppr       ( Mode(..) )

import System.IO ( Handle )
import Control.Monad.IO.Class

-- | Show a SDoc as a String with the default user style
showSDoc :: DynFlags -> SDoc -> String
showSDoc :: DynFlags -> SDoc -> String
showSDoc DynFlags
dflags SDoc
sdoc = SDocContext -> SDoc -> String
renderWithContext (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle) SDoc
sdoc

showPpr :: Outputable a => DynFlags -> a -> String
showPpr :: forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags a
thing = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
thing)

-- | Allows caller to specify the PrintUnqualified to use
showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String
showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String
showSDocForUser DynFlags
dflags UnitState
unit_state PrintUnqualified
unqual SDoc
doc = SDocContext -> SDoc -> String
renderWithContext (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
sty) SDoc
doc'
   where
      sty :: PprStyle
sty  = PrintUnqualified -> Depth -> PprStyle
mkUserStyle PrintUnqualified
unqual Depth
AllTheWay
      doc' :: SDoc
doc' = UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state SDoc
doc

showSDocDump :: SDocContext -> SDoc -> String
showSDocDump :: SDocContext -> SDoc -> String
showSDocDump SDocContext
ctx SDoc
d = SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx (PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle SDoc
d)

showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug DynFlags
dflags SDoc
d = SDocContext -> SDoc -> String
renderWithContext SDocContext
ctx SDoc
d
   where
      ctx :: SDocContext
ctx = (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultDumpStyle)
               { sdocPprDebug :: Bool
sdocPprDebug = Bool
True
               }

printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()
printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()
printForUser DynFlags
dflags Handle
handle PrintUnqualified
unqual Depth
depth SDoc
doc
  = SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDocLn SDocContext
ctx (Bool -> Mode
PageMode Bool
False) Handle
handle SDoc
doc
    where ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (PrintUnqualified -> Depth -> PprStyle
mkUserStyle PrintUnqualified
unqual Depth
depth)

-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC DynFlags
dflags Handle
handle SDoc
doc =
  SDocContext -> Mode -> Handle -> SDoc -> IO ()
printSDocLn SDocContext
ctx Mode
LeftMode Handle
handle SDoc
doc
  where ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags (LabelStyle -> PprStyle
PprCode LabelStyle
CStyle)

pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen :: forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
ctx String -> a
cont SDoc
heading SDoc
pretty_msg
 = String -> a
cont (SDocContext -> SDoc -> String
showSDocDump SDocContext
ctx SDoc
doc)
 where
     doc :: SDoc
doc = [SDoc] -> SDoc
sep [SDoc
heading, Int -> SDoc -> SDoc
nest Int
2 SDoc
pretty_msg]

-- | If debug output is on, show some 'SDoc' on the screen
pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a
pprTraceWithFlags :: forall a. DynFlags -> String -> SDoc -> a -> a
pprTraceWithFlags DynFlags
dflags String
str SDoc
doc a
x
  | DynFlags -> Bool
hasNoDebugOutput DynFlags
dflags = a
x
  | Bool
otherwise               = SDocContext -> (String -> a -> a) -> SDoc -> SDoc -> a -> a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultDumpStyle)
                                              String -> a -> a
forall a. String -> a -> a
trace (String -> SDoc
text String
str) SDoc
doc a
x

-- | 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
defaultSDocContext String -> a -> a
forall a. String -> a -> a
trace (String -> SDoc
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 (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 (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
showSDocDump SDocContext
defaultSDocContext ([SDoc] -> SDoc
sep [String -> SDoc
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
$$ SDoc
HasCallStack => SDoc
callStackDoc)

warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a
-- ^ Just warn about an assertion failure, recording the given file and line number.
-- Should typically be accessed with the WARN macros
warnPprTrace :: forall a. HasCallStack => Bool -> String -> Int -> SDoc -> a -> a
warnPprTrace Bool
_     String
_     Int
_     SDoc
_    a
x | Bool -> Bool
not Bool
debugIsOn     = a
x
warnPprTrace Bool
_     String
_file Int
_line SDoc
_msg a
x
   | Bool
unsafeHasNoDebugOutput = a
x
warnPprTrace Bool
False String
_file Int
_line SDoc
_msg a
x = a
x
warnPprTrace Bool
True   String
file  Int
line  SDoc
msg a
x
  = SDocContext -> (String -> a -> a) -> SDoc -> SDoc -> a -> a
forall a. SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen SDocContext
defaultSDocContext String -> a -> a
forall a. String -> a -> a
trace SDoc
heading
                    (SDoc
msg SDoc -> SDoc -> SDoc
$$ SDoc
HasCallStack => SDoc
callStackDoc )
                    a
x
  where
    heading :: SDoc
heading = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"WARNING: file", String -> SDoc
text String
file SDoc -> SDoc -> SDoc
<> SDoc
comma, String -> SDoc
text String
"line", Int -> SDoc
int Int
line]