From: Ian Lynagh Date: Sun, 8 May 2011 15:13:33 +0000 (+0100) Subject: Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d45197aabb22178066a8ec50d29331786a0c518c;hp=c5f7496604b096277e3ba57fcb6ed85422613c75 Merge branch 'coloured-core' of https://github.com/nominolo/ghc into coloured-core --- diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index 03f541e..89b3edd 100644 --- 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 @@ -253,9 +252,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 --- 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 2f3e9f4..e405aea 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -804,12 +804,12 @@ defaultDynFlags mySettings = 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 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -67,7 +67,8 @@ mkLocMessage locn msg -- would look strange. Better to say explicitly "". 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 c99629c..07acbbb 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -484,7 +484,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 826c09b..bd48872 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1147,7 +1147,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 } -------------------- @@ -1182,7 +1182,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 c4a685b..fc4d919 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -15,7 +15,7 @@ module Outputable ( Outputable(..), OutputableBndr(..), -- * Pretty printing combinators - SDoc, + SDoc, runSDoc, initSDocContext, docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, empty, nest, @@ -33,6 +33,9 @@ module Outputable ( hang, punctuate, ppWhen, ppUnless, speakNth, speakNTimes, speakN, speakNOf, plural, + coloured, PprColour, colType, colCoerc, colDataCon, + colBinder, 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,38 +222,56 @@ code (either C or assembly), or generating interface files. %************************************************************************ \begin{code} -type SDoc = PprStyle -> Doc +newtype SDoc = SDoc { runSDoc :: 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 = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} withPprStyleDoc :: PprStyle -> SDoc -> Doc -withPprStyleDoc sty d = d sty +withPprStyleDoc sty d = runSDoc 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 d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..." + SDC{sdocStyle=PprUser q (PartWay n)} -> + runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))} + _ -> runSDoc d ctx pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth -pprDeeperList f ds (PprUser q (PartWay n)) - | n==0 = Pretty.text "..." - | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1))) - where - go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - -pprDeeperList f ds other_sty - = f ds other_sty +pprDeeperList f ds = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q (PartWay n)} + | n==0 = Pretty.text "..." + | otherwise = + runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))} + where + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + work other_ctx = runSDoc (f ds) other_ctx pprSetDepth :: Depth -> SDoc -> SDoc -pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth) -pprSetDepth _depth doc other_sty = doc other_sty +pprSetDepth depth doc = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser q _} -> + runSDoc doc ctx{sdocStyle = PprUser q depth} + _ -> + runSDoc doc ctx getPprStyle :: (PprStyle -> SDoc) -> SDoc -getPprStyle df sty = df sty sty +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx \end{code} \begin{code} @@ -282,22 +304,24 @@ 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 = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprDebug} -> runSDoc d ctx + _ -> 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 (runSDoc 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 (runSDoc doc (initSDocContext sty)) + hFlush stderr printOutput :: Doc -> IO () printOutput doc = Pretty.printDoc PageMode stdout doc @@ -307,25 +331,32 @@ printDump doc = hPrintDump stdout doc hPrintDump :: Handle -> SDoc -> IO () hPrintDump h doc = do - Pretty.printDoc PageMode h (better_doc defaultDumpStyle) + Pretty.printDoc PageMode h + (runSDoc 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 + (runSDoc 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 + (runSDoc 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 + (runSDoc 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 + (runSDoc doc (initSDocContext (PprCode AsmStyle))) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -337,32 +368,44 @@ 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 + (runSDoc d (initSDocContext defaultUserStyle)) + +renderWithStyle :: SDoc -> PprStyle -> String +renderWithStyle sdoc sty = + Pretty.render (runSDoc 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 + (runSDoc d (initSDocContext defaultUserStyle)) showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) +showSDocForUser unqual doc = + show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) showSDocUnqual :: SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) +showSDocUnqual d = + show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (d defaultUserStyle) +showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) showSDocDump :: SDoc -> String -showSDocDump d = Pretty.showDocWith PageMode (d PprDump) +showSDocDump d = + Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump) +showSDocDumpOneLine d = + Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) showSDocDebug :: SDoc -> String -showSDocDebug d = show (d PprDebug) +showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) showPpr :: Outputable a => a -> String showPpr = showSDoc . ppr @@ -370,7 +413,7 @@ showPpr = showSDoc . ppr \begin{code} docToSDoc :: Doc -> SDoc -docToSDoc d = \_ -> d +docToSDoc d = SDoc (\_ -> d) empty :: SDoc char :: Char -> SDoc @@ -383,58 +426,58 @@ float :: Float -> SDoc double :: Double -> SDoc rational :: Rational -> SDoc -empty _sty = Pretty.empty -char c _sty = Pretty.char c -text s _sty = Pretty.text s -ftext s _sty = Pretty.ftext s -ptext s _sty = Pretty.ptext s -int n _sty = Pretty.int n -integer n _sty = Pretty.integer n -float n _sty = Pretty.float n -double n _sty = Pretty.double n -rational n _sty = Pretty.rational n +empty = docToSDoc $ Pretty.empty +char c = docToSDoc $ Pretty.char c +text s = docToSDoc $ Pretty.text s +ftext s = docToSDoc $ Pretty.ftext s +ptext s = docToSDoc $ Pretty.ptext s +int n = docToSDoc $ Pretty.int n +integer n = docToSDoc $ Pretty.integer n +float n = docToSDoc $ Pretty.float n +double n = docToSDoc $ Pretty.double n +rational n = docToSDoc $ Pretty.rational n parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc -parens d sty = Pretty.parens (d sty) -braces d sty = Pretty.braces (d sty) -brackets d sty = Pretty.brackets (d sty) -doubleQuotes d sty = Pretty.doubleQuotes (d sty) -angleBrackets d = char '<' <> d <> char '>' +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +angleBrackets d = char '<' <> d <> char '>' cparen :: Bool -> SDoc -> SDoc -cparen b d sty = Pretty.cparen b (d sty) +cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- quotes encloses something in single quotes... -- but it omits them if the thing ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. -quotes d sty = case show pp_d of - ('\'' : _) -> pp_d - _other -> Pretty.quotes pp_d - where - pp_d = d sty +quotes d = SDoc $ \sty -> + let pp_d = runSDoc d sty in + case show pp_d of + ('\'' : _) -> pp_d + _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc -blankLine _sty = Pretty.ptext (sLit "") -dcolon _sty = Pretty.ptext (sLit "::") -arrow _sty = Pretty.ptext (sLit "->") -darrow _sty = Pretty.ptext (sLit "=>") -semi _sty = Pretty.semi -comma _sty = Pretty.comma -colon _sty = Pretty.colon -equals _sty = Pretty.equals -space _sty = Pretty.space -underscore = char '_' -dot = char '.' -lparen _sty = Pretty.lparen -rparen _sty = Pretty.rparen -lbrack _sty = Pretty.lbrack -rbrack _sty = Pretty.rbrack -lbrace _sty = Pretty.lbrace -rbrace _sty = Pretty.rbrace +blankLine = docToSDoc $ Pretty.ptext (sLit "") +dcolon = docToSDoc $ Pretty.ptext (sLit "::") +arrow = docToSDoc $ Pretty.ptext (sLit "->") +darrow = docToSDoc $ Pretty.ptext (sLit "=>") +semi = docToSDoc $ Pretty.semi +comma = docToSDoc $ Pretty.comma +colon = docToSDoc $ Pretty.colon +equals = docToSDoc $ Pretty.equals +space = docToSDoc $ Pretty.space +underscore = char '_' +dot = char '.' +lparen = docToSDoc $ Pretty.lparen +rparen = docToSDoc $ Pretty.rparen +lbrack = docToSDoc $ Pretty.lbrack +rbrack = docToSDoc $ Pretty.rbrack +lbrace = docToSDoc $ Pretty.lbrace +rbrace = docToSDoc $ Pretty.rbrace nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount @@ -448,11 +491,11 @@ nest :: Int -> SDoc -> SDoc ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically -nest n d sty = Pretty.nest n (d sty) -(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty) -(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty) -($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty) -($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty) +nest n d = SDoc $ Pretty.nest n . runSDoc d +(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) +(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) +($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) +($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally @@ -471,19 +514,19 @@ fcat :: [SDoc] -> SDoc -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' -hcat ds sty = Pretty.hcat [d sty | d <- ds] -hsep ds sty = Pretty.hsep [d sty | d <- ds] -vcat ds sty = Pretty.vcat [d sty | d <- ds] -sep ds sty = Pretty.sep [d sty | d <- ds] -cat ds sty = Pretty.cat [d sty | d <- ds] -fsep ds sty = Pretty.fsep [d sty | d <- ds] -fcat ds sty = Pretty.fcat [d sty | d <- ds] +hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] +hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] +vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] +sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] +cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] +fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] +fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] hang :: SDoc -- ^ The header -> Int -- ^ Amount to indent the hung body -> SDoc -- ^ The hung body, indented and placed below the header -> SDoc -hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) punctuate :: SDoc -- ^ The punctuation -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements @@ -500,6 +543,46 @@ 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[31m" + +colBinder :: PprColour +colBinder = PprColour "\27[32m" + +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 = + SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } -> + let ctx' = ctx{ sdocLastColour = col } in + Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc + +bold :: SDoc -> SDoc +bold = coloured colBold + +keyword :: SDoc -> SDoc +keyword = bold + \end{code} @@ -806,21 +889,23 @@ pprDefiniteTrace str doc x = pprAndThen trace 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 (runSDoc 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 (runSDoc 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 (runSDoc doc (initSDocContext PprDebug))) where doc = sep [hsep[text "ASSERT failed! file", text file, @@ -833,7 +918,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 (runSDoc doc (initSDocContext defaultDumpStyle))) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg] diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs index a518c0b..f0ca69c 100644 --- a/compiler/utils/Pretty.lhs +++ b/compiler/utils/Pretty.lhs @@ -163,7 +163,7 @@ module Pretty ( empty, isEmpty, nest, - char, text, ftext, ptext, + char, text, ftext, ptext, zeroWidthText, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, semi, comma, colon, space, equals, @@ -224,6 +224,10 @@ The primitive @Doc@ values \begin{code} empty :: Doc isEmpty :: Doc -> Bool +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc + text :: String -> Doc char :: Char -> Doc @@ -560,6 +564,7 @@ ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} ptext :: LitString -> Doc ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} where s = {-castPtr-} s_ +zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty #if defined(__GLASGOW_HASKELL__) -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 2685377..0f68607 100644 --- 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