Start support for coloured SDoc output.

The SDoc type now passes around an abstract SDocContext rather than
just a PprStyle which required touching a few more files.  This should
also make it easier to integrate DynFlags passing, so that we can get
rid of global variables.

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index c4bdba2..108bd8d 100644 (file)
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -73,7 +73,6 @@ module Module
 
 import Config
 import Outputable
-import qualified Pretty
 import Unique
 import UniqFM
 import FastString
@@ -256,9 +255,10 @@ mkModule :: PackageId -> ModuleName -> Module
 mkModule = Module
 
 pprModule :: Module -> SDoc
-pprModule mod@(Module p n)  = pprPackagePrefix p mod <> pprModuleName n
+pprModule mod@(Module p n)  =
+  pprPackagePrefix p mod <> pprModuleName n
 
-pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc
+pprPackagePrefix :: PackageId -> Module -> SDoc
 pprPackagePrefix p mod = getPprStyle doc
  where
    doc sty

diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs
index 67515e5..372bd35 100644 (file)
--- a/compiler/main/CmdLineParser.hs
+++ b/compiler/main/CmdLineParser.hs
@@ -233,5 +233,5 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
 errorsToGhcException :: [Located String] -> GhcException
 errorsToGhcException errs =
    let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ]
-   in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors)
+   in UsageError (renderWithStyle errors cmdlineParserStyle)
 

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 706ded8..9eac33c 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -760,12 +760,12 @@ defaultDynFlags =
 
         log_action = \severity srcSpan style msg ->
                         case severity of
-                          SevOutput -> printOutput (msg style)
-                          SevInfo   -> printErrs (msg style)
-                          SevFatal  -> printErrs (msg style)
+                          SevOutput -> printSDoc msg style
+                          SevInfo   -> printErrs msg style
+                          SevFatal  -> printErrs msg style
                           _         -> do 
                                 hPutChar stderr '\n'
-                                printErrs ((mkLocMessage srcSpan msg) style)
+                                printErrs (mkLocMessage srcSpan msg) style
                      -- careful (#2302): printErrs prints in UTF-8, whereas
                      -- converting to string first and using hPutStr would
                      -- just emit the low 8 bits of each unicode char.

diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index d0a8a86..b6297a2 100644 (file)
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -67,7 +67,8 @@ mkLocMessage locn msg
   -- would look strange.  Better to say explicitly "<no location info>".
 
 printError :: SrcSpan -> Message -> IO ()
-printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle)
+printError span msg =
+  printErrs (mkLocMessage span msg) defaultErrStyle
 
 
 -- -----------------------------------------------------------------------------

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7a38540..0ce95ef 100644 (file)
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -480,7 +480,7 @@ makeImportsDoc dflags imports
                | otherwise
                = Pretty.empty
 
-       doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
+       doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
        astyle = mkCodeStyle AsmStyle
 
 

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index ad2405b..f105e62 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -1152,7 +1152,7 @@ failIfM :: Message -> IfL a
 failIfM msg
   = do         { env <- getLclEnv
        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
-       ; liftIO (printErrs (full_msg defaultErrStyle))
+       ; liftIO (printErrs full_msg defaultErrStyle)
        ; failM }
 
 --------------------
@@ -1187,7 +1187,7 @@ forkM_maybe doc thing_inside
                    ; return Nothing }
        }}
   where
-    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+    print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
 
 forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index e178e99..1dbb0c3 100644 (file)
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -33,6 +33,9 @@ module Outputable (
        hang, punctuate, ppWhen, ppUnless,
        speakNth, speakNTimes, speakN, speakNOf, plural,
 
+        coloured, PprColour, colType, colCoerc, colDataCon,
+        colGlobal, colLocal, bold, keyword,
+
         -- * Converting 'SDoc' into strings and outputing it
        printSDoc, printErrs, printOutput, hPrintDump, printDump,
        printForC, printForAsm, printForUser, printForUserPartWay,
@@ -41,6 +44,7 @@ module Outputable (
         showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
         showPpr,
        showSDocUnqual, showsPrecSDoc,
+        renderWithStyle,
 
        pprInfixVar, pprPrefixVar,
        pprHsChar, pprHsString, pprHsInfix, pprHsVar,
@@ -218,24 +222,39 @@ code (either C or assembly), or generating interface files.
 %************************************************************************
 
 \begin{code}
-type SDoc = PprStyle -> Doc
+type SDoc = SDocContext -> Doc
+
+data SDocContext = SDC
+  { sdocStyle      :: !PprStyle
+  , sdocLastColour :: !PprColour
+    -- ^ The most recently used colour.  This allows nesting colours.
+  }
+
+initSDocContext :: PprStyle -> SDocContext
+initSDocContext sty = SDC
+  { sdocStyle = sty
+  , sdocLastColour = colReset
+  }
 
 withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d _sty' = d sty
+withPprStyle sty d ctxt = d ctxt{sdocStyle=sty}
 
 withPprStyleDoc :: PprStyle -> SDoc -> Doc
-withPprStyleDoc sty d = d sty
+withPprStyleDoc sty d = d (initSDocContext sty)
 
 pprDeeper :: SDoc -> SDoc
-pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
-pprDeeper d other_sty              = d other_sty
+pprDeeper _ SDC{sdocStyle=PprUser _ (PartWay 0)} =
+  Pretty.text "..."
+pprDeeper d ctx@SDC{sdocStyle=PprUser q (PartWay n)} =
+  d ctx{sdocStyle = PprUser q (PartWay (n-1))}
+pprDeeper d other_sty =
+  d other_sty
 
 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 -- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds (PprUser q (PartWay n))
+pprDeeperList f ds ctx@SDC{sdocStyle=PprUser q (PartWay n)}
   | n==0      = Pretty.text "..."
-  | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
+  | otherwise = f (go 0 ds) ctx{sdocStyle = PprUser q (PartWay (n-1))}
   where
     go _ [] = []
     go i (d:ds) | i >= n    = [text "...."]
@@ -245,11 +264,12 @@ pprDeeperList f ds other_sty
   = f ds other_sty
 
 pprSetDepth :: Depth -> SDoc -> SDoc
-pprSetDepth depth  doc (PprUser q _) = doc (PprUser q depth)
+pprSetDepth depth  doc ctx@SDC{sdocStyle=PprUser q _} =
+  doc ctx{sdocStyle = PprUser q depth}
 pprSetDepth _depth doc other_sty     = doc other_sty
 
 getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df sty = df sty sty
+getPprStyle df sty = df (sdocStyle sty) sty
 \end{code}
 
 \begin{code}
@@ -282,22 +302,23 @@ userStyle (PprUser _ _) = True
 userStyle _other        = False
 
 ifPprDebug :: SDoc -> SDoc       -- Empty for non-debug style
-ifPprDebug d sty@PprDebug = d sty
-ifPprDebug _ _           = Pretty.empty
+ifPprDebug d ctx@SDC{sdocStyle=PprDebug} = d ctx
+ifPprDebug _ _                          = Pretty.empty
 \end{code}
 
 \begin{code}
 -- Unused [7/02 sof]
 printSDoc :: SDoc -> PprStyle -> IO ()
 printSDoc d sty = do
-  Pretty.printDoc PageMode stdout (d sty)
+  Pretty.printDoc PageMode stdout (d (initSDocContext sty))
   hFlush stdout
 
 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 -- above is better or worse than the put-big-string approach here
-printErrs :: Doc -> IO ()
-printErrs doc = do Pretty.printDoc PageMode stderr doc
-                  hFlush stderr
+printErrs :: SDoc -> PprStyle -> IO ()
+printErrs doc sty = do
+  Pretty.printDoc PageMode stderr (doc (initSDocContext sty))
+  hFlush stderr
 
 printOutput :: Doc -> IO ()
 printOutput doc = Pretty.printDoc PageMode stdout doc
@@ -307,25 +328,27 @@ printDump doc = hPrintDump stdout doc
 
 hPrintDump :: Handle -> SDoc -> IO ()
 hPrintDump h doc = do
-   Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+   Pretty.printDoc PageMode h (better_doc (initSDocContext defaultDumpStyle))
    hFlush h
  where
    better_doc = doc $$ blankLine
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
-  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+  = Pretty.printDoc PageMode handle (doc (initSDocContext (mkUserStyle unqual AllTheWay)))
 
 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
 printForUserPartWay handle d unqual doc
-  = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+  = Pretty.printDoc PageMode handle (doc (initSDocContext (mkUserStyle unqual (PartWay d))))
 
 -- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
-printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+printForC handle doc =
+  Pretty.printDoc LeftMode handle (doc (initSDocContext (PprCode CStyle)))
 
 printForAsm :: Handle -> SDoc -> IO ()
-printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+printForAsm handle doc =
+  Pretty.printDoc LeftMode handle (doc (initSDocContext (PprCode AsmStyle)))
 
 pprCode :: CodeStyle -> SDoc -> SDoc
 pprCode cs d = withPprStyle (PprCode cs) d
@@ -337,32 +360,40 @@ mkCodeStyle = PprCode
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
 showSDoc :: SDoc -> String
-showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDoc d = Pretty.showDocWith PageMode (d (initSDocContext defaultUserStyle))
+
+renderWithStyle :: SDoc -> PprStyle -> String
+renderWithStyle sdoc sty =
+  Pretty.render (sdoc (initSDocContext sty))
 
 -- This shows an SDoc, but on one line only. It's cheaper than a full
 -- showSDoc, designed for when we're getting results like "Foo.bar"
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 showSDocOneLine :: SDoc -> String
-showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+showSDocOneLine d =
+  Pretty.showDocWith PageMode (d (initSDocContext defaultUserStyle))
 
 showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+showSDocForUser unqual doc =
+  show (doc (initSDocContext (mkUserStyle unqual AllTheWay)))
 
 showSDocUnqual :: SDoc -> String
 -- Only used in the gruesome isOperator
-showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+showSDocUnqual d =
+  show (d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
-showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showsPrecSDoc p d = showsPrec p (d (initSDocContext defaultUserStyle))
 
 showSDocDump :: SDoc -> String
-showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+showSDocDump d = Pretty.showDocWith PageMode (d (initSDocContext PprDump))
 
 showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+showSDocDumpOneLine d =
+  Pretty.showDocWith OneLineMode (d (initSDocContext PprDump))
 
 showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
+showSDocDebug d = show (d (initSDocContext PprDebug))
 
 showPpr :: Outputable a => a -> String
 showPpr = showSDoc . ppr
@@ -500,6 +531,50 @@ ppWhen False _   = empty
 
 ppUnless True  _   = empty
 ppUnless False doc = doc
+
+-- | A colour\/style for use with 'coloured'.
+newtype PprColour = PprColour String
+
+-- Colours
+
+colType :: PprColour
+colType = PprColour "\27[34m"
+
+colBold :: PprColour
+colBold = PprColour "\27[;1m"
+
+colCoerc :: PprColour
+colCoerc = PprColour "\27[34m"
+
+colDataCon :: PprColour
+colDataCon = PprColour "\27[31;1m"
+
+colGlobal :: PprColour
+colGlobal = PprColour "\27[32m"
+
+colLocal :: PprColour
+colLocal = PprColour "\27[35m"
+
+colReset :: PprColour
+colReset = PprColour "\27[0m"
+
+-- | Apply the given colour\/style for the argument.
+--
+-- Only takes effect if colours are enabled.
+coloured :: PprColour -> SDoc -> SDoc
+-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
+coloured col@(PprColour c) sdoc
+         ctx@SDC{ sdocLastColour = PprColour lc } =
+  Pretty.zeroWidthText c Pretty.<> sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+ where
+   ctx' = ctx{ sdocLastColour = col }
+
+bold :: SDoc -> SDoc
+bold = coloured colBold
+
+keyword :: SDoc -> SDoc
+keyword = bold
+
 \end{code}
 
 
@@ -803,21 +878,23 @@ pprTrace str doc x
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
-                            where
-                              doc = text heading <+> pretty_msg
+pprPanicFastInt heading pretty_msg =
+    panicFastInt (show (doc (initSDocContext PprDebug)))
+  where
+    doc = text heading <+> pretty_msg
 
 
 pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
-    where
+pprAndThen cont heading pretty_msg =
+  cont (show (doc (initSDocContext PprDebug)))
+ where
      doc = sep [text heading, nest 4 pretty_msg]
 
 assertPprPanic :: String -> Int -> SDoc -> a
 -- ^ Panic with an assertation failure, recording the given file and line number.
 -- Should typically be accessed with the ASSERT family of macros
 assertPprPanic file line msg
-  = panic (show (doc PprDebug))
+  = panic (show (doc (initSDocContext PprDebug)))
   where
     doc = sep [hsep[text "ASSERT failed! file", 
                           text file, 
@@ -830,7 +907,7 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
-  = trace (show (doc defaultDumpStyle)) x
+  = trace (show (doc (initSDocContext defaultDumpStyle))) x
   where
     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
               msg]

diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 2685377..0f68607 100644 (file)
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -38,7 +38,7 @@ import HscTypes ( handleFlagWarnings )
 import HsImpExp
 import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
 import RdrName (RdrName)
-import Outputable       hiding (printForUser, printForUserPartWay)
+import Outputable       hiding (printForUser, printForUserPartWay, bold)
 import Module           -- for ModuleEnv
 import Name
 import SrcLoc