-- | 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 dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc

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

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

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

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

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

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

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

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

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

pprTraceM :: Applicative f => String -> SDoc -> f ()
pprTraceM str doc = pprTrace str doc (pure ())

pprTraceDebug :: String -> SDoc -> a -> a
pprTraceDebug str doc x
   | debugIsOn && unsafeHasPprDebug = pprTrace str doc x
   | otherwise                      = 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 desc f x = pprTrace desc (f x) x

-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
pprTraceIt :: Outputable a => String -> a -> a
pprTraceIt desc x = pprTraceWith desc ppr 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 heading doc =
    handleGhcException $ \exc -> liftIO $ do
        putStrLn $ showSDocDump defaultSDocContext (sep [text heading, nest 2 doc])
        throwGhcExceptionIO 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 doc = pprTrace "" (doc $$ 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 _     _     _     _    x | not debugIsOn     = x
warnPprTrace _     _file _line _msg x
   | unsafeHasNoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True   file  line  msg x
  = pprDebugAndThen defaultSDocContext trace heading
                    (msg $$ callStackDoc )
                    x
  where
    heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]