Put tracing functions into their own module

Now that Outputable is independent of DynFlags, we can put tracing
functions using SDocs into their own module that doesn't transitively
depend on any GHC.Driver.* module.

A few modules needed to be moved to avoid loops in DEBUG mode.

7 files changed, 93 insertions, 56 deletions

diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs
index 9a1ea88aa7..93ab233788 100644
--- a/compiler/GHC/Utils/Error.hs
+++ b/compiler/GHC/Utils/Error.hs
@@ -64,7 +64,6 @@ module GHC.Utils.Error (
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Driver.Ppr
 
 import GHC.Data.Bag
 import GHC.Utils.Exception
diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs
index 77506682bd..e497b8c965 100644
--- a/compiler/GHC/Utils/Logger.hs
+++ b/compiler/GHC/Utils/Logger.hs
@@ -77,7 +77,6 @@ where
 
 import GHC.Prelude
 import GHC.Driver.Flags
-import GHC.Driver.Ppr
 import GHC.Types.Error
 import GHC.Types.SrcLoc
 
@@ -101,6 +100,7 @@ import System.IO
 import Control.Monad
 import Control.Concurrent.MVar
 import System.IO.Unsafe
+import Debug.Trace (trace)
 
 ---------------------------------------------------------------
 -- Log flags
@@ -528,7 +528,7 @@ defaultTraceAction :: TraceAction a
 defaultTraceAction logflags title doc x =
   if not (log_enable_debug logflags)
     then x
-    else trace (showSDocDump (log_default_dump_context logflags)
+    else trace (renderWithContext (log_default_dump_context logflags)
                              (sep [text title, nest 2 doc])) x
 
 
diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs
index d19d78c876..181d6c91e7 100644
--- a/compiler/GHC/Utils/Misc.hs
+++ b/compiler/GHC/Utils/Misc.hs
@@ -42,8 +42,6 @@ module GHC.Utils.Misc (
         isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,
         notNull, snocView,
 
-        isIn, isn'tIn,
-
         chunkList,
 
         changeLast,
@@ -122,10 +120,6 @@ module GHC.Utils.Misc (
         -- * Call stacks
         HasCallStack,
         HasDebugCallStack,
-
-        -- * Utils for flags
-        OverridingBool(..),
-        overrideWith,
     ) where
 
 import GHC.Prelude
@@ -160,11 +154,6 @@ import qualified Data.Set as Set
 
 import Data.Time
 
-#if defined(DEBUG)
-import {-# SOURCE #-} GHC.Utils.Outputable ( text )
-import {-# SOURCE #-} GHC.Driver.Ppr ( warnPprTrace )
-#endif
-
 infixr 9 `thenCmp`
 
 
@@ -524,34 +513,6 @@ expectOnly _   (a:_) = a
 #endif
 expectOnly msg _     = panic ("expectOnly: " ++ msg)
 
--- Debugging/specialising versions of \tr{elem} and \tr{notElem}
-
-# if !defined(DEBUG)
-isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
-isIn    _msg x ys = x `elem` ys
-isn'tIn _msg x ys = x `notElem` ys
-
-# else /* DEBUG */
-isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool
-isIn msg x ys
-  = elem100 0 x ys
-  where
-    elem100 :: Eq a => Int -> a -> [a] -> Bool
-    elem100 _ _ [] = False
-    elem100 i x (y:ys)
-      | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
-      | otherwise = x == y || elem100 (i + 1) x ys
-
-isn'tIn msg x ys
-  = notElem100 0 x ys
-  where
-    notElem100 :: Eq a => Int -> a -> [a] -> Bool
-    notElem100 _ _ [] =  True
-    notElem100 i x (y:ys)
-      | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
-      | otherwise = x /= y && notElem100 (i + 1) x ys
-# endif /* DEBUG */
-
 
 -- | Split a list into chunks of /n/ elements
 chunkList :: Int -> [a] -> [[a]]
@@ -1486,14 +1447,3 @@ type HasDebugCallStack = HasCallStack
 #else
 type HasDebugCallStack = (() :: Constraint)
 #endif
-
-data OverridingBool
-  = Auto
-  | Always
-  | Never
-  deriving Show
-
-overrideWith :: Bool -> OverridingBool -> Bool
-overrideWith b Auto   = b
-overrideWith _ Always = True
-overrideWith _ Never  = False
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 7d33007ead..7d0436f2f2 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -57,6 +57,7 @@ module GHC.Utils.Outputable (
         showSDocUnsafe,
         showPprUnsafe,
         renderWithContext,
+        pprDebugAndThen,
 
         pprInfixVar, pprPrefixVar,
         pprHsChar, pprHsString, pprHsBytes,
@@ -607,6 +608,13 @@ showPprUnsafe :: Outputable a => a -> String
 showPprUnsafe a = renderWithContext defaultSDocContext (ppr a)
 
 
+pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a
+pprDebugAndThen ctx cont heading pretty_msg
+ = cont (renderWithContext ctx doc)
+ where
+     doc = withPprStyle defaultDumpStyle (sep [heading, nest 2 pretty_msg])
+
+
 isEmpty :: SDocContext -> SDoc -> Bool
 isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True})
 
diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs
index fb72886be7..497ea65003 100644
--- a/compiler/GHC/Utils/Panic.hs
+++ b/compiler/GHC/Utils/Panic.hs
@@ -29,7 +29,6 @@ module GHC.Utils.Panic
    , assertPprM
    , massertPpr
    , sorry
-   , trace
    , panicDoc
    , sorryDoc
    , pgmErrorDoc
@@ -60,7 +59,6 @@ import Control.Monad.IO.Class
 import qualified Control.Monad.Catch as MC
 import Control.Concurrent
 import Data.Typeable      ( cast )
-import Debug.Trace        ( trace )
 import System.IO.Unsafe
 
 #if !defined(mingw32_HOST_OS)
diff --git a/compiler/GHC/Utils/Ppr/Colour.hs b/compiler/GHC/Utils/Ppr/Colour.hs
index 7283edd182..92044d96e4 100644
--- a/compiler/GHC/Utils/Ppr/Colour.hs
+++ b/compiler/GHC/Utils/Ppr/Colour.hs
@@ -2,7 +2,7 @@ module GHC.Utils.Ppr.Colour where
 import GHC.Prelude
 
 import Data.Maybe (fromMaybe)
-import GHC.Utils.Misc (OverridingBool(..), split)
+import GHC.Data.Bool
 import Data.Semigroup as Semi
 
 -- | A colour\/style for use with 'coloured'.
@@ -93,6 +93,11 @@ parseScheme input    (b, cs) =
     }
   )
   where
+    split :: Char -> String -> [String]
+    split c s = case break (==c) s of
+        (chunk,[])     -> [chunk]
+        (chunk,_:rest) -> chunk : split c rest
+
     table = do
       w <- split ':' input
       let (k, v') = break (== '=') w
diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs
new file mode 100644
index 0000000000..ac29cd6fd8
--- /dev/null
+++ b/compiler/GHC/Utils/Trace.hs
@@ -0,0 +1,77 @@
+-- | Tracing utilities
+module GHC.Utils.Trace
+  ( pprTrace
+  , pprTraceM
+  , pprTraceDebug
+  , pprTraceIt
+  , pprSTrace
+  , pprTraceException
+  , warnPprTrace
+  , trace
+  )
+where
+
+import GHC.Prelude
+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 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 $ renderWithContext defaultSDocContext
+                 $ withPprStyle defaultDumpStyle
+                 $ 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 $$ traceCallStackDoc)
+
+-- | Just warn about an assertion failure, recording the given file and line number.
+warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
+warnPprTrace _     _    x | not debugIsOn     = x
+warnPprTrace _     _msg x | unsafeHasNoDebugOutput = x
+warnPprTrace False _msg x = x
+warnPprTrace True   msg x
+  = pprDebugAndThen defaultSDocContext trace (text "WARNING:")
+                    (msg $$ withFrozenCallStack traceCallStackDoc )
+                    x
+
+traceCallStackDoc :: HasCallStack => SDoc
+traceCallStackDoc =
+    hang (text "Call stack:")
+       4 (vcat $ map text $ lines (prettyCallStack callStack))