diff options
Diffstat (limited to 'compiler/utils')
-rw-r--r-- | compiler/utils/Bag.lhs | 7 | ||||
-rw-r--r-- | compiler/utils/Outputable.lhs | 322 |
2 files changed, 163 insertions, 166 deletions
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index 700878aea6..a32991b97d 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -16,7 +16,7 @@ module Bag ( concatBag, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, - foldrBagM, foldlBagM, mapBagM, mapBagM_, + foldrBagM, foldlBagM, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM ) where @@ -120,13 +120,13 @@ partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats, fails) = partition pred vs -partitionBagWith :: (a -> Either b c) -> Bag a +partitionBagWith :: (a -> Either b c) -> Bag a -> (Bag b {- Left -}, Bag c {- Right -}) partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) partitionBagWith pred (UnitBag val) = case pred val of - Left a -> (UnitBag a, EmptyBag) + Left a -> (UnitBag a, EmptyBag) Right b -> (EmptyBag, UnitBag b) partitionBagWith pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) @@ -269,3 +269,4 @@ instance Data a => Data (Bag a) where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Bag" \end{code} + diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 60fbe5b29a..5263081c9a 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -4,13 +4,6 @@ % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- 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'. -- @@ -18,74 +11,74 @@ -- module, except that it exports a number of additional functions that are rarely used, -- and works over the 'SDoc' type. module Outputable ( - -- * Type classes - Outputable(..), OutputableBndr(..), - PlatformOutputable(..), + -- * Type classes + Outputable(..), OutputableBndr(..), + PlatformOutputable(..), -- * Pretty printing combinators - SDoc, runSDoc, initSDocContext, - docToSDoc, - interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, - empty, nest, - char, - text, ftext, ptext, - int, integer, float, double, rational, - parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, - blankLine, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - hang, punctuate, ppWhen, ppUnless, - speakNth, speakNTimes, speakN, speakNOf, plural, + SDoc, runSDoc, initSDocContext, + docToSDoc, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, + empty, nest, + char, + text, ftext, ptext, + int, integer, float, double, rational, + parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + 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, - pprCode, mkCodeStyle, - showSDoc, showSDocOneLine, + printSDoc, printErrs, printOutput, hPrintDump, printDump, + printForC, printForAsm, printForUser, printForUserPartWay, + pprCode, mkCodeStyle, + showSDoc, showSDocOneLine, showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showPpr, - showSDocUnqual, showsPrecSDoc, + showSDocUnqual, showsPrecSDoc, renderWithStyle, - pprInfixVar, pprPrefixVar, - pprHsChar, pprHsString, pprHsInfix, pprHsVar, + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsInfix, pprHsVar, pprFastFilePath, -- * Controlling the style in which output is printed - BindingSite(..), + BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, QualifyName(..), - getPprStyle, withPprStyle, withPprStyleDoc, - pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, - mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, + 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 + + -- * Error handling and debugging utilities + pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, + pprTrace, pprDefiniteTrace, warnPprTrace, + trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where -import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) +import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} Name( Name, nameModule ) import StaticFlags -import FastString +import FastString import FastTypes import Platform import qualified Pretty -import Util ( snocView ) -import Pretty ( Doc, Mode(..) ) +import Util ( snocView ) +import Pretty ( Doc, Mode(..) ) import Panic import Data.Char @@ -94,7 +87,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set import Data.Word -import System.IO ( Handle, stderr, stdout, hFlush ) +import System.IO ( Handle, stderr, stdout, hFlush ) import System.FilePath @@ -110,35 +103,35 @@ showMultiLineString s = [ showList s "" ] %************************************************************************ -%* * +%* * \subsection{The @PprStyle@ data type} -%* * +%* * %************************************************************************ \begin{code} data PprStyle = PprUser PrintUnqualified Depth - -- Pretty-print in a way that will make sense to the - -- ordinary user; must be very close to Haskell - -- syntax, etc. - -- Assumes printing tidied code: non-system names are - -- printed without uniques. + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. | PprCode CodeStyle - -- Print code; either C or assembler + -- Print code; either C or assembler - | PprDump -- For -ddump-foo; less verbose than PprDebug. - -- Does not assume tidied code: non-external names - -- are printed with uniques. + | PprDump -- For -ddump-foo; less verbose than PprDebug. + -- Does not assume tidied code: non-external names + -- are printed with uniques. - | PprDebug -- Full debugging output + | PprDebug -- Full debugging output -data CodeStyle = CStyle -- The format of labels differs for C and assembler - | AsmStyle +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle data Depth = AllTheWay - | PartWay Int -- 0 => stop + | PartWay Int -- 0 => stop -- ----------------------------------------------------------------------------- @@ -161,7 +154,7 @@ type QueryQualifyName = Name -> 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 + | 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 @@ -196,7 +189,7 @@ defaultUserStyle, defaultDumpStyle :: PprStyle defaultUserStyle = mkUserStyle alwaysQualify AllTheWay defaultDumpStyle | opt_PprStyle_Debug = PprDebug - | otherwise = PprDump + | otherwise = PprDump -- | Style for printing error messages mkErrStyle :: PrintUnqualified -> PprStyle @@ -206,7 +199,7 @@ defaultErrStyle :: PprStyle -- Default style for error messages -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs -defaultErrStyle +defaultErrStyle | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) @@ -228,9 +221,9 @@ The following test decides whether or not we are actually generating code (either C or assembly), or generating interface files. %************************************************************************ -%* * +%* * \subsection{The @SDoc@ data type} -%* * +%* * %************************************************************************ \begin{code} @@ -276,11 +269,12 @@ pprDeeperList f ds = SDoc work 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 +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 = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx @@ -296,8 +290,8 @@ qualModule (PprUser (_,qual_mod) _) m = qual_mod m qualModule _other _m = True codeStyle :: PprStyle -> Bool -codeStyle (PprCode _) = True -codeStyle _ = False +codeStyle (PprCode _) = True +codeStyle _ = False asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True @@ -308,17 +302,18 @@ dumpStyle PprDump = True dumpStyle _other = False debugStyle :: PprStyle -> Bool -debugStyle PprDebug = True -debugStyle _other = False +debugStyle PprDebug = True +debugStyle _other = False userStyle :: PprStyle -> Bool userStyle (PprUser _ _) = True userStyle _other = False -ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style -ifPprDebug d = SDoc $ \ctx -> case ctx of - SDC{sdocStyle=PprDebug} -> runSDoc d ctx - _ -> Pretty.empty +ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style +ifPprDebug d = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprDebug} -> runSDoc d ctx + _ -> Pretty.empty \end{code} \begin{code} @@ -350,7 +345,7 @@ hPrintDump h doc = do better_doc = doc $$ blankLine printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () -printForUser handle unqual doc +printForUser handle unqual doc = Pretty.printDoc PageMode handle (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) @@ -465,7 +460,7 @@ 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 = SDoc $ \sty -> +quotes d = SDoc $ \sty -> let pp_d = runSDoc d sty in case snocView (show pp_d) of Just (_, '\'') -> pp_d @@ -499,7 +494,7 @@ nest :: Int -> SDoc -> SDoc (<+>) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together horizontally with a gap between them ($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is +-- ^ 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 @@ -546,9 +541,9 @@ punctuate :: SDoc -- ^ The punctuation -> [SDoc] -- ^ Punctuated list punctuate _ [] = [] punctuate p (d:ds) = go d ds - where - go d [] = [d] - go d (e:es) = (d <> p) : go e es + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es ppWhen, ppUnless :: Bool -> SDoc -> SDoc ppWhen True doc = doc @@ -600,29 +595,29 @@ keyword = bold %************************************************************************ -%* * +%* * \subsection[Outputable-class]{The @Outputable@ class} -%* * +%* * %************************************************************************ \begin{code} -- | Class designating that some type has an 'SDoc' representation class Outputable a where - ppr :: a -> SDoc - pprPrec :: Rational -> a -> SDoc - -- 0 binds least tightly - -- We use Rational because there is always a - -- Rational between any other two Rationals + ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals - ppr = pprPrec 0 - pprPrec _ = ppr + ppr = pprPrec 0 + pprPrec _ = ppr class PlatformOutputable a where - pprPlatform :: Platform -> a -> SDoc - pprPlatformPrec :: Platform -> Rational -> a -> SDoc - - pprPlatform platform = pprPlatformPrec platform 0 - pprPlatformPrec platform _ = pprPlatform platform + pprPlatform :: Platform -> a -> SDoc + pprPlatformPrec :: Platform -> Rational -> a -> SDoc + + pprPlatform platform = pprPlatformPrec platform 0 + pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -678,50 +673,50 @@ instance (Outputable a, Outputable b) => Outputable (Either a b) where instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where ppr (x,y,z) = parens (sep [ppr x <> comma, - ppr y <> comma, - ppr z ]) + ppr y <> comma, + ppr z ]) instance (Outputable a, Outputable b, Outputable c, Outputable d) => - Outputable (a, b, c, d) where + Outputable (a, b, c, d) where ppr (a,b,c,d) = parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d]) + 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 + 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]) + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => - Outputable (a, b, c, d, e, f) where + Outputable (a, b, c, d, e, f) where ppr (a,b,c,d,e,f) = parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f]) + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => - Outputable (a, b, c, d, e, f, g) where + Outputable (a, b, c, d, e, f, g) where ppr (a,b,c,d,e,f,g) = parens (sep [ppr a <> comma, - ppr b <> comma, - ppr c <> comma, - ppr d <> comma, - ppr e <> comma, - ppr f <> comma, - ppr g]) + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) instance Outputable FastString where - ppr fs = ftext fs -- Prints an unadorned string, - -- no double quotes or anything + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) @@ -732,9 +727,9 @@ instance (Outputable elt) => Outputable (IM.IntMap elt) where \end{code} %************************************************************************ -%* * +%* * \subsection{The @OutputableBndr@ class} -%* * +%* * %************************************************************************ \begin{code} @@ -751,9 +746,9 @@ class Outputable a => OutputableBndr a where \end{code} %************************************************************************ -%* * +%* * \subsection{Random printing helpers} -%* * +%* * %************************************************************************ \begin{code} @@ -773,11 +768,11 @@ pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) pprPrefixVar :: Bool -> SDoc -> SDoc pprPrefixVar is_operator pp_v | is_operator = parens pp_v - | otherwise = 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 +pprInfixVar is_operator pp_v | is_operator = pp_v | otherwise = char '`' <> pp_v <> char '`' @@ -787,13 +782,13 @@ pprInfixVar is_operator pp_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 +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 + where pp_v = ppr v isOperator :: SDoc -> Bool -isOperator ppr_v +isOperator ppr_v = case showSDocUnqual ppr_v of ('(':_) -> False -- (), (,) etc ('[':_) -> False -- [] @@ -808,9 +803,9 @@ pprFastFilePath path = text $ normalise $ unpackFS path \end{code} %************************************************************************ -%* * +%* * \subsection{Other helper functions} -%* * +%* * %************************************************************************ \begin{code} @@ -845,9 +840,9 @@ quotedListWithOr xs = quotedList xs %************************************************************************ -%* * +%* * \subsection{Printing numbers verbally} -%* * +%* * %************************************************************************ \begin{code} @@ -865,22 +860,22 @@ 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 - | last_dig == 1 = "st" - | last_dig == 2 = "nd" - | last_dig == 3 = "rd" - | otherwise = "th" + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" 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 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") @@ -896,8 +891,8 @@ speakN n = int n -- > speakNOf 3 (text "melon") = text "three melons" speakNOf :: Int -> SDoc -> SDoc 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" +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: -- @@ -905,8 +900,8 @@ speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" -- > 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") +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: @@ -921,9 +916,9 @@ plural _ = char 's' %************************************************************************ -%* * +%* * \subsection{Error handling} -%* * +%* * %************************************************************************ \begin{code} @@ -972,10 +967,10 @@ assertPprPanic :: String -> Int -> SDoc -> a assertPprPanic file line msg = panic (show (runSDoc doc (initSDocContext PprDebug))) where - doc = sep [hsep[text "ASSERT failed! file", - text file, - text "line", int line], - msg] + doc = sep [hsep[text "ASSERT failed! file", + text file, + text "line", int line], + msg] warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a -- ^ Just warn about an assertion failure, recording the given file and line number. @@ -986,5 +981,6 @@ 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] + msg] \end{code} + |