X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=61ad4ddd22216a6465956639cb539d2f66480260;hb=268377f59589e6afec1048458c350011ebb74afe;hp=ad6548bd62cc1a15be316bbccfbfa4445f42f576;hpb=36f77deda25312534200f10ccdb18528b6ee6e27;p=ghc-hetmet.git diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index ad6548b..61ad4dd 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -7,17 +7,19 @@ Outputable: defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} - module Outputable ( Outputable(..), OutputableBndr(..), -- Class BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, - getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth, + 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, SDoc, -- Abstract docToSDoc, @@ -35,29 +37,25 @@ module Outputable ( hang, punctuate, speakNth, speakNTimes, speakN, speakNOf, plural, - printSDoc, printErrs, printDump, - printForC, printForAsm, printForUser, + printSDoc, printErrs, hPrintDump, printDump, + printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, -- error handling - pprPanic, assertPprPanic, pprPanic#, pprPgmError, + pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, warnPprTrace, - trace, pgmError, panic, panic#, assertPanic + trace, pgmError, panic, panicFastInt, assertPanic ) where -#include "HsVersions.h" - - -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 StaticFlags import FastString +import FastTypes import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -114,30 +112,45 @@ 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 + +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 = (QueryQualifyName, QueryQualifyModule) -type PrintUnqualified = (QualifyName, QualifyModule) +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ = NameQual (moduleName m) -alwaysQualifyNames :: QualifyName -alwaysQualifyNames m n = Just (moduleName m) +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ = NameUnqual -neverQualifyNames :: QualifyName -neverQualifyNames m n = Nothing +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True -alwaysQualifyModules :: QualifyModule -alwaysQualifyModules m = Just (modulePackageId m) +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False -neverQualifyModules :: QualifyModule -neverQualifyModules m = Nothing +type QueryQualifies = (QueryQualifyName, QueryQualifyModule) +alwaysQualify, neverQualify :: QueryQualifies alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) neverQualify = (neverQualifyNames, neverQualifyModules) +defaultUserStyle, defaultDumpStyle :: PprStyle + defaultUserStyle = mkUserStyle alwaysQualify AllTheWay defaultDumpStyle | opt_PprStyle_Debug = PprDebug @@ -155,6 +168,7 @@ defaultErrStyle | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) +mkUserStyle :: QueryQualifies -> Depth -> PprStyle mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth @@ -178,32 +192,45 @@ code (either C or assembly), or generating interface files. type SDoc = PprStyle -> Doc withPprStyle :: PprStyle -> SDoc -> SDoc -withPprStyle sty d sty' = d sty +withPprStyle sty d _sty' = d sty withPprStyleDoc :: PprStyle -> SDoc -> Doc withPprStyleDoc sty d = d sty pprDeeper :: SDoc -> SDoc -pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..." +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 +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 + pprSetDepth :: Int -> SDoc -> SDoc -pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n)) -pprSetDepth n d other_sty = d other_sty +pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n)) +pprSetDepth _n d other_sty = d other_sty getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df sty = df sty sty \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 @@ -211,23 +238,23 @@ 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 _ _ = Pretty.empty \end{code} \begin{code} @@ -244,9 +271,12 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc hFlush stderr printDump :: SDoc -> IO () -printDump doc = do - Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle) - hFlush stdout +printDump doc = hPrintDump stdout doc + +hPrintDump :: Handle -> SDoc -> IO () +hPrintDump h doc = do + Pretty.printDoc PageMode h (better_doc defaultDumpStyle) + hFlush h where better_doc = doc $$ text "" @@ -254,6 +284,10 @@ printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) +printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () +printForUserPartWay handle d unqual doc + = Pretty.printDoc PageMode handle (doc (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)) @@ -294,16 +328,29 @@ showSDocDebug d = show (d PprDebug) 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 +empty :: SDoc +text :: String -> SDoc +char :: Char -> SDoc +ftext :: FastString -> SDoc +ptext :: LitString -> SDoc +int :: Int -> SDoc +integer :: Integer -> SDoc +float :: Float -> SDoc +double :: Double -> SDoc +rational :: Rational -> SDoc + +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, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc parens d sty = Pretty.parens (d sty) braces d sty = Pretty.braces (d sty) @@ -311,6 +358,8 @@ brackets d sty = Pretty.brackets (d sty) doubleQuotes d sty = Pretty.doubleQuotes (d sty) angleBrackets d = char '<' <> d <> char '>' +cparen :: Bool -> SDoc -> SDoc + cparen b d sty = Pretty.cparen b (d sty) -- quotes encloses something in single quotes... @@ -318,25 +367,31 @@ cparen b d sty = Pretty.cparen b (d sty) -- 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 + _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("->") -underscore = char '_' -dot = char '.' +semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc + +semi _sty = Pretty.semi +comma _sty = Pretty.comma +colon _sty = Pretty.colon +equals _sty = Pretty.equals +space _sty = Pretty.space +dcolon _sty = Pretty.ptext (sLit "::") +arrow _sty = Pretty.ptext (sLit "->") +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 + +nest :: Int -> SDoc -> SDoc +(<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc nest n d sty = Pretty.nest n (d sty) (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty) @@ -344,6 +399,9 @@ 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) +hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc + + 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] @@ -352,10 +410,12 @@ 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 :: SDoc -> Int -> SDoc -> SDoc + hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) punctuate :: SDoc -> [SDoc] -> [SDoc] -punctuate p [] = [] +punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] @@ -376,12 +436,15 @@ class Outputable a where \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 Word32 where + ppr n = integer $ fromIntegral n + instance Outputable () where ppr _ = text "()" @@ -392,8 +455,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 -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where @@ -404,18 +471,24 @@ 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) \end{code} @@ -437,7 +510,7 @@ data BindingSite = LambdaBind | CaseBind | LetBind class Outputable a => OutputableBndr a where pprBndr :: BindingSite -> a -> SDoc - pprBndr b x = ppr x + pprBndr _b x = ppr x \end{code} @@ -494,12 +567,12 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \begin{code} 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 @@ -511,27 +584,28 @@ speakNth n = hcat [ int n, text suffix ] last_dig = n `rem` 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 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' -- E.g. "no arguments" +speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument" speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" speakNTimes :: Int {- >=1 -} -> SDoc -speakNTimes t | t == 1 = ptext SLIT("once") - | t == 2 = ptext SLIT("twice") - | otherwise = speakN t <+> ptext SLIT("times") +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' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' \end{code} @@ -548,9 +622,12 @@ 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 +pprTrace str doc x + | opt_NoDebugOutput = x + | otherwise = pprAndThen trace str doc x -pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) +pprPanicFastInt :: String -> SDoc -> FastInt +pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug)) where doc = text heading <+> pretty_msg @@ -569,8 +646,9 @@ 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 +warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x +warnPprTrace False _file _line _msg x = x +warnPprTrace True file line msg x = trace (show (doc PprDebug)) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line],