X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=fc4d919473bb19d71fcdb7a87f7b339548ffd647;hp=9e1e240866708ba3a8beea36ea23a172c18deeb3;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 9e1e240..fc4d919 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -3,78 +3,100 @@ % (c) The GRASP Project, Glasgow University, 1992-1998 % -Outputable: defines classes for pretty-printing and forcing, both -forms of ``output.'' - \begin{code} -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - +-- | This module defines classes and functions for pretty-printing. It also +-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. +-- +-- The interface to this module is very similar to the standard Hughes-PJ pretty printing +-- module, except that it exports a number of additional functions that are rarely used, +-- and works over the 'SDoc' type. module Outputable ( - Outputable(..), OutputableBndr(..), -- Class - - BindingSite(..), - - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, - getPprStyle, withPprStyle, withPprStyleDoc, - pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, - mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, + -- * Type classes + Outputable(..), OutputableBndr(..), - SDoc, -- Abstract + -- * Pretty printing combinators + SDoc, runSDoc, initSDocContext, docToSDoc, - interppSP, interpp'SP, pprQuotedList, pprWithCommas, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, empty, nest, - text, char, ftext, ptext, + char, + text, ftext, ptext, int, integer, float, double, rational, parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, arrow, + semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, + ($$), ($+$), vcat, sep, cat, fsep, fcat, - hang, punctuate, + hang, punctuate, ppWhen, ppUnless, speakNth, speakNTimes, speakN, speakNOf, plural, - printSDoc, printErrs, hPrintDump, printDump, - printForC, printForAsm, printForUser, + coloured, PprColour, colType, colCoerc, colDataCon, + colBinder, bold, keyword, + + -- * Converting 'SDoc' into strings and outputing it + printSDoc, printErrs, printOutput, hPrintDump, printDump, + printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, - showSDoc, showSDocForUser, showSDocDebug, showSDocDump, + showSDoc, showSDocOneLine, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showPpr, showSDocUnqual, showsPrecSDoc, - pprHsChar, pprHsString, + renderWithStyle, - -- error handling - pprPanic, assertPprPanic, pprPanic#, pprPgmError, - pprTrace, warnPprTrace, - trace, pgmError, panic, panic#, assertPanic - ) where + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsInfix, pprHsVar, + pprFastFilePath, -#include "HsVersions.h" + -- * Controlling the style in which output is printed + BindingSite(..), + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, + QualifyName(..), + getPprStyle, withPprStyle, withPprStyleDoc, + pprDeeper, pprDeeperList, pprSetDepth, + codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, + ifPprDebug, qualName, qualModule, + mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, + mkUserStyle, cmdlineParserStyle, Depth(..), + + -- * Error handling and debugging utilities + pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, + pprTrace, pprDefiniteTrace, warnPprTrace, + trace, pgmError, panic, sorry, panicFastInt, assertPanic + ) where -import {-# SOURCE #-} Module( Module, modulePackageId, - ModuleName, moduleName ) +import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) -import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength ) -import PackageConfig ( PackageId, packageIdString ) -import FastString +import StaticFlags +import FastString +import FastTypes import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic -import Data.Word ( Word32 ) +import Data.Char +import qualified Data.Map as M +import qualified Data.IntMap as IM +import Data.Word import System.IO ( Handle, stderr, stdout, hFlush ) -import Data.Char ( ord ) +import System.FilePath + + +#if __GLASGOW_HASKELL__ >= 701 +import GHC.Show ( showMultiLineString ) +#else +showMultiLineString :: String -> [String] +-- Crude version +showMultiLineString s = [ showList s "" ] +#endif \end{code} + %************************************************************************ %* * \subsection{The @PprStyle@ data type} @@ -121,30 +143,44 @@ data Depth = AllTheWay -- as @Exception.catch@, this fuction will return @Just "Exception"@. -- Note that the return value is a ModuleName, not a Module, because -- in source code, names are qualified by ModuleNames. -type QualifyName = Module -> OccName -> Maybe ModuleName +type QueryQualifyName = Module -> OccName -> QualifyName + +-- See Note [Printing original names] in HscTypes +data QualifyName -- given P:M.T + = NameUnqual -- refer to it as "T" + | NameQual ModuleName -- refer to it as "X.T" for the supplied X + | NameNotInScope1 + -- it is not in scope at all, but M.T is not bound in the current + -- scope, so we can refer to it as "M.T" + | NameNotInScope2 + -- it is not in scope at all, and M.T is already bound in the + -- current scope, so we must refer to it as "P:M.T" + -- | For a given module, we need to know whether to print it with --- a package name to disambiguate it, and if so which package name should --- we use. -type QualifyModule = Module -> Maybe PackageId +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool -type PrintUnqualified = (QualifyName, QualifyModule) +type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) -alwaysQualifyNames :: QualifyName -alwaysQualifyNames m n = Just (moduleName m) +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ = NameQual (moduleName m) -neverQualifyNames :: QualifyName -neverQualifyNames m n = Nothing +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ = NameUnqual -alwaysQualifyModules :: QualifyModule -alwaysQualifyModules m = Just (modulePackageId m) +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True -neverQualifyModules :: QualifyModule -neverQualifyModules m = Nothing +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False +alwaysQualify, neverQualify :: PrintUnqualified alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) neverQualify = (neverQualifyNames, neverQualifyModules) +defaultUserStyle, defaultDumpStyle :: PprStyle + defaultUserStyle = mkUserStyle alwaysQualify AllTheWay defaultDumpStyle | opt_PprStyle_Debug = PprDebug @@ -162,9 +198,13 @@ defaultErrStyle | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) +mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth + +cmdlineParserStyle :: PprStyle +cmdlineParserStyle = PprUser alwaysQualify AllTheWay \end{code} Orthogonal to the above printing styles are (possibly) some @@ -182,48 +222,66 @@ 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 d (PprUser q (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 i [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - -pprDeeperList f ds other_sty - = f ds other_sty - -pprSetDepth :: Int -> SDoc -> SDoc -pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n)) -pprSetDepth n d other_sty = d 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 = 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} -qualName :: PprStyle -> QualifyName -qualName (PprUser (qual_name,_) _) m n = qual_name m n -qualName other m n = Just (moduleName m) +qualName :: PprStyle -> QueryQualifyName +qualName (PprUser (qual_name,_) _) m n = qual_name m n +qualName _other m _n = NameQual (moduleName m) -qualModule :: PprStyle -> QualifyModule -qualModule (PprUser (_,qual_mod) _) m = qual_mod m -qualModule other m = Just (modulePackageId m) +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser (_,qual_mod) _) m = qual_mod m +qualModule _other _m = True codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True @@ -231,58 +289,74 @@ codeStyle _ = False asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True -asmStyle other = False +asmStyle _other = False dumpStyle :: PprStyle -> Bool dumpStyle PprDump = True -dumpStyle other = False +dumpStyle _other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True -debugStyle other = False +debugStyle _other = False userStyle :: PprStyle -> Bool userStyle (PprUser _ _) = True -userStyle other = False +userStyle _other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style -ifPprDebug d sty@PprDebug = d sty -ifPprDebug d sty = 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 printDump :: SDoc -> IO () 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 $$ text "" + 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 + (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 @@ -294,95 +368,221 @@ mkCodeStyle = PprCode -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = show (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 + (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 HsExpr.isOperator -showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) +-- Only used in the gruesome isOperator +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 = show (d PprDump) +showSDocDump d = + Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) + +showSDocDumpOneLine :: SDoc -> String +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 \end{code} \begin{code} docToSDoc :: Doc -> SDoc -docToSDoc d = \_ -> d - -empty sty = Pretty.empty -text s sty = Pretty.text s -char c sty = Pretty.char c -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 - -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 '>' - -cparen b d sty = Pretty.cparen b (d sty) +docToSDoc d = SDoc (\_ -> d) + +empty :: SDoc +char :: Char -> SDoc +text :: String -> SDoc +ftext :: FastString -> SDoc +ptext :: LitString -> SDoc +int :: Int -> SDoc +integer :: Integer -> SDoc +float :: Float -> SDoc +double :: Double -> SDoc +rational :: Rational -> SDoc + +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 = 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 = 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 - -semi sty = Pretty.semi -comma sty = Pretty.comma -colon sty = Pretty.colon -equals sty = Pretty.equals -space sty = Pretty.space -lparen sty = Pretty.lparen -rparen sty = Pretty.rparen -lbrack sty = Pretty.lbrack -rbrack sty = Pretty.rbrack -lbrace sty = Pretty.lbrace -rbrace sty = Pretty.rbrace -dcolon sty = Pretty.ptext SLIT("::") -arrow sty = Pretty.ptext SLIT("->") +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 = 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 '.' - -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) - -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] - -hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) - -punctuate :: SDoc -> [SDoc] -> [SDoc] -punctuate p [] = [] +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 +(<>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally without a gap +(<+>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally with a gap between them +($$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically; if there is +-- no vertical overlap it "dovetails" the two onto one line +($+$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically + +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 +hsep :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally with a space between each one +vcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' vertically with dovetailing +sep :: [SDoc] -> SDoc +-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits +cat :: [SDoc] -> SDoc +-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits +fsep :: [SDoc] -> SDoc +-- ^ A paragraph-fill combinator. It's much like sep, only it +-- keeps fitting things on one line until it can't fit any more. +fcat :: [SDoc] -> SDoc +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' + + +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 = 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 + -> [SDoc] -- ^ Punctuated list +punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen True doc = doc +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} @@ -393,18 +593,28 @@ punctuate p (d:ds) = go d ds %************************************************************************ \begin{code} +-- | Class designating that some type has an 'SDoc' representation class Outputable a where ppr :: a -> SDoc \end{code} \begin{code} instance Outputable Bool where - ppr True = ptext SLIT("True") - ppr False = ptext SLIT("False") + ppr True = ptext (sLit "True") + ppr False = ptext (sLit "False") instance Outputable Int where ppr n = int n +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + +instance Outputable Word where + ppr n = integer $ fromIntegral n + instance Outputable () where ppr _ = text "()" @@ -415,12 +625,12 @@ instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) instance Outputable a => Outputable (Maybe a) where - ppr Nothing = ptext SLIT("Nothing") - ppr (Just x) = ptext SLIT("Just") <+> ppr x + ppr Nothing = ptext (sLit "Nothing") + ppr (Just x) = ptext (sLit "Just") <+> ppr x instance (Outputable a, Outputable b) => Outputable (Either a b) where - ppr (Left x) = ptext SLIT("Left") <+> ppr x - ppr (Right y) = ptext SLIT("Right") <+> ppr y + ppr (Left x) = ptext (sLit "Left") <+> ppr x + ppr (Right y) = ptext (sLit "Right") <+> ppr y -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where @@ -431,44 +641,50 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher instance (Outputable a, Outputable b, Outputable c, Outputable d) => Outputable (a, b, c, d) where - ppr (x,y,z,w) = - parens (sep [ppr x <> comma, - ppr y <> comma, - ppr z <> comma, - ppr w]) + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything -instance Outputable PackageId where - ppr pid = text (packageIdString pid) +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) \end{code} - %************************************************************************ %* * \subsection{The @OutputableBndr@ class} %* * %************************************************************************ -When we print a binder, we often want to print its type too. -The @OutputableBndr@ class encapsulates this idea. - -@BindingSite@ is used to tell the thing that prints binder what -language construct is binding the identifier. This can be used -to decide how much info to print. - \begin{code} +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. data BindingSite = LambdaBind | CaseBind | LetBind +-- | When we print a binder, we often want to print its type too. +-- The @OutputableBndr@ class encapsulates this idea. class Outputable a => OutputableBndr a where pprBndr :: BindingSite -> a -> SDoc - pprBndr b x = ppr x + pprBndr _b x = ppr x \end{code} - - %************************************************************************ %* * \subsection{Random printing helpers} @@ -476,18 +692,56 @@ class Outputable a => OutputableBndr a where %************************************************************************ \begin{code} --- We have 31-bit Chars and will simply use Show instances --- of Char and String. +-- We have 31-bit Chars and will simply use Show instances of Char and String. +-- | Special combinator for showing character literals. pprHsChar :: Char -> SDoc pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) | otherwise = text (show c) +-- | Special combinator for showing string literals. pprHsString :: FastString -> SDoc -pprHsString fs = text (show (unpackFS fs)) +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +-- pprHsVar and pprHsInfix use the gruesome isOperator, which +-- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v). +-- Reason: it means that pprHsVar doesn't need a NamedThing context, +-- which none of the HsSyn printing functions do +pprHsVar, pprHsInfix :: Outputable name => name -> SDoc +pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v + where pp_v = ppr v +pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v + where pp_v = ppr v + +isOperator :: SDoc -> Bool +isOperator ppr_v + = case showSDocUnqual ppr_v of + ('(':_) -> False -- (), (,) etc + ('[':_) -> False -- [] + ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator + (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator + ('_':_) -> False -- Not an operator + (c:_) -> not (isAlpha c) -- Starts with non-alpha + _ -> False + +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path \end{code} - %************************************************************************ %* * \subsection{Other helper functions} @@ -495,18 +749,33 @@ pprHsString fs = text (show (unpackFS fs)) %************************************************************************ \begin{code} -pprWithCommas :: (a -> SDoc) -> [a] -> SDoc +pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- comma-separated and finally packed into a paragraph. pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) +-- | Returns the seperated concatenation of the pretty printed things. interppSP :: Outputable a => [a] -> SDoc interppSP xs = sep (map ppr xs) +-- | Returns the comma-seperated concatenation of the pretty printed things. interpp'SP :: Outputable a => [a] -> SDoc interpp'SP xs = sep (punctuate comma (map ppr xs)) +-- | Returns the comma-seperated concatenation of the quoted pretty printed things. +-- +-- > [x,y,z] ==> `x', `y', `z' pprQuotedList :: Outputable a => [a] -> SDoc --- [x,y,z] ==> `x', `y', `z' -pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) +pprQuotedList = quotedList . map ppr + +quotedList :: [SDoc] -> SDoc +quotedList xs = hsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs) +quotedListWithOr xs = quotedList xs \end{code} @@ -516,17 +785,19 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) %* * %************************************************************************ -@speakNth@ converts an integer to a verbal index; eg 1 maps to -``first'' etc. - \begin{code} +-- | Converts an integer to a verbal index: +-- +-- > speakNth 1 = text "first" +-- > speakNth 5 = text "fifth" +-- > speakNth 21 = text "21st" speakNth :: Int -> SDoc -speakNth 1 = ptext SLIT("first") -speakNth 2 = ptext SLIT("second") -speakNth 3 = ptext SLIT("third") -speakNth 4 = ptext SLIT("fourth") -speakNth 5 = ptext SLIT("fifth") -speakNth 6 = ptext SLIT("sixth") +speakNth 1 = ptext (sLit "first") +speakNth 2 = ptext (sLit "second") +speakNth 3 = ptext (sLit "third") +speakNth 4 = ptext (sLit "fourth") +speakNth 5 = ptext (sLit "fifth") +speakNth 6 = ptext (sLit "sixth") speakNth n = hcat [ int n, text suffix ] where suffix | n <= 20 = "th" -- 11,12,13 are non-std @@ -537,28 +808,50 @@ speakNth n = hcat [ int n, text suffix ] last_dig = n `rem` 10 +-- | Converts an integer to a verbal multiplicity: +-- +-- > speakN 0 = text "none" +-- > speakN 5 = text "five" +-- > speakN 10 = text "10" speakN :: Int -> SDoc -speakN 0 = ptext SLIT("none") -- E.g. "he has none" -speakN 1 = ptext SLIT("one") -- E.g. "he has one" -speakN 2 = ptext SLIT("two") -speakN 3 = ptext SLIT("three") -speakN 4 = ptext SLIT("four") -speakN 5 = ptext SLIT("five") -speakN 6 = ptext SLIT("six") +speakN 0 = ptext (sLit "none") -- E.g. "he has none" +speakN 1 = ptext (sLit "one") -- E.g. "he has one" +speakN 2 = ptext (sLit "two") +speakN 3 = ptext (sLit "three") +speakN 4 = ptext (sLit "four") +speakN 5 = ptext (sLit "five") +speakN 6 = ptext (sLit "six") speakN n = int n +-- | Converts an integer and object description to a statement about the +-- multiplicity of those objects: +-- +-- > speakNOf 0 (text "melon") = text "no melons" +-- > speakNOf 1 (text "melon") = text "one melon" +-- > speakNOf 3 (text "melon") = text "three melons" speakNOf :: Int -> SDoc -> SDoc -speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments" -speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument" +speakNOf 0 d = ptext (sLit "no") <+> d <> char 's' +speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument" speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" +-- | Converts a strictly positive integer into a number of times: +-- +-- > speakNTimes 1 = text "once" +-- > speakNTimes 2 = text "twice" +-- > speakNTimes 4 = text "4 times" speakNTimes :: Int {- >=1 -} -> SDoc -speakNTimes t | t == 1 = ptext SLIT("once") - | t == 2 = ptext SLIT("twice") - | otherwise = speakN t <+> ptext SLIT("times") - -plural [x] = empty -plural xs = char 's' +speakNTimes t | t == 1 = ptext (sLit "once") + | t == 2 = ptext (sLit "twice") + | otherwise = speakN t <+> ptext (sLit "times") + +-- | Determines the pluralisation suffix appropriate for the length of a list: +-- +-- > plural [] = char 's' +-- > plural ["Hello"] = empty +-- > plural ["Hello", "World"] = char 's' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' \end{code} @@ -569,26 +862,50 @@ plural xs = char 's' %************************************************************************ \begin{code} -pprPanic, pprPgmError :: String -> SDoc -> a -pprTrace :: String -> SDoc -> a -> a -pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC" -pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled" - -- (used for unusual pgm errors) -pprTrace = pprAndThen trace +pprPanic :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in GHC" +pprPanic = pprAndThen panic + +pprSorry :: String -> SDoc -> a +-- ^ Throw an exceptio saying "this isn't finished yet" +pprSorry = pprAndThen sorry + + +pprPgmError :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) +pprPgmError = pprAndThen pgmError + + +pprTrace :: String -> SDoc -> a -> a +-- ^ If debug output is on, show some 'SDoc' on the screen +pprTrace str doc x + | opt_NoDebugOutput = x + | otherwise = pprAndThen trace str doc x + +pprDefiniteTrace :: String -> SDoc -> a -> a +-- ^ Same as pprTrace, but show even if -dno-debug-output is on +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 (runSDoc doc (initSDocContext PprDebug))) + where + doc = text heading <+> pretty_msg -pprPanic# heading pretty_msg = panic# (show (doc 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, @@ -596,9 +913,12 @@ assertPprPanic file line msg msg] warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -warnPprTrace False file line msg x = x -warnPprTrace True file line msg x - = trace (show (doc PprDebug)) x +-- ^ Just warn about an assertion failure, recording the given file and line number. +-- Should typically be accessed with the WARN macros +warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x +warnPprTrace False _file _line _msg x = x +warnPprTrace True file line msg x + = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg]