X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=7aa2461851ecd132579aabf73144ee5cb4464afc;hb=6dad6315d07e715151164e3202a98110a641218a;hp=3ba5f55b7379d0daaea12c4cdf101a830b441c8c;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 3ba5f55..7aa2461 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1996 +% (c) The GRASP Project, Glasgow University, 1992-1998 % \section[Outputable]{Classes for pretty-printing} @@ -7,150 +7,292 @@ Defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} -#include "HsVersions.h" module Outputable ( - -- NAMED-THING-ERY - NamedThing(..), -- class - ExportFlag(..), - isExported, getLocalName, ltLexical, - - -- PRINTERY AND FORCERY - Outputable(..), -- class + Outputable(..), -- Class + + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, + getPprStyle, withPprStyle, pprDeeper, + codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, + ifPprDebug, unqualStyle, + + SDoc, -- Abstract + docToSDoc, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, + empty, nest, + text, char, ptext, + int, integer, float, double, rational, + parens, brackets, braces, quotes, doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, punctuate, + speakNth, speakNTimes, + + printSDoc, printErrs, printDump, + printForC, printForAsm, printForIface, printForUser, + pprCode, pprCols, + showSDoc, showSDocForUser, showSDocDebug, showSDocIface, + showSDocUnqual, showsPrecSDoc, + pprHsChar, pprHsString, + + + -- error handling + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, + trace, panic, panic#, assertPanic + ) where - interppSP, interpp'SP, - ifnotPprForUser, - ifPprDebug, - ifPprShowAll, ifnotPprShowAll, - ifPprInterface, +#include "HsVersions.h" - isOpLexeme, pprOp, pprNonOp, - isConop, isAconop, isAvarid, isAvarop - -- and to make the interface self-sufficient... - ) where +import {-# SOURCE #-} Name( Name ) -import Ubiq{-uitous-} +import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) +import FastString +import qualified Pretty +import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) +import Panic -import PprStyle ( PprStyle(..) ) -import Pretty -import Util ( cmpPString ) +import Word ( Word32 ) +import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) +import Char ( chr, ord, isDigit ) \end{code} + %************************************************************************ %* * -\subsection[NamedThing-class]{The @NamedThing@ class} +\subsection{The @PprStyle@ data type} %* * %************************************************************************ \begin{code} -class NamedThing a where - getExportFlag :: a -> ExportFlag - isLocallyDefined :: a -> Bool - getOrigName :: a -> (FAST_STRING{-module-}, FAST_STRING{-name therein-}) - getOccurrenceName :: a -> FAST_STRING - getInformingModules :: a -> [FAST_STRING] - getSrcLoc :: a -> SrcLoc - getItsUnique :: a -> Unique - fromPreludeCore :: a -> Bool - -- see also friendly functions that follow... -\end{code} - -\begin{description} -\item[@getExportFlag@:] -Obvious. +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. -\item[@getOrigName@:] -Obvious. + | PprInterface PrintUnqualified -- Interface generation -\item[@isLocallyDefined@:] -Whether the thing is defined in this module or not. + | PprCode CodeStyle -- Print code; either C or assembler -\item[@getOccurrenceName@:] -Gets the name by which a thing is known in this module (e.g., if -renamed, or whatever)... + | PprDebug -- Standard debugging output -\item[@getInformingModules@:] -Gets the name of the modules that told me about this @NamedThing@. +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle -\item[@getSrcLoc@:] -Obvious. +data Depth = AllTheWay + | PartWay Int -- 0 => stop -\item[@fromPreludeCore@:] -Tests a quite-delicate property: it is \tr{True} iff the entity is -actually defined in \tr{PreludeCore} (or \tr{PreludeBuiltin}), or if -it is re-exported by \tr{PreludeCore}. See the @FullName@ type in -module \tr{NameTypes}. -NB: Some of the types in, e.g., \tr{PreludeGlaST} {\em fail} this test. -This is a bummer for types that are wired into the compiler. -\end{description} - -Some functions to go with: -\begin{code} -isExported a - = case (getExportFlag a) of - NotExported -> False - _ -> True +type PrintUnqualified = Name -> Bool + -- This function tells when it's ok to print + -- a (Global) name unqualified -getLocalName :: (NamedThing a) => a -> FAST_STRING +alwaysQualify,neverQualify :: PrintUnqualified +alwaysQualify n = False +neverQualify n = True -getLocalName = snd . getOrigName +defaultUserStyle = mkUserStyle alwaysQualify AllTheWay -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isExported :: Class -> Bool #-} -{-# SPECIALIZE isExported :: Id -> Bool #-} -{-# SPECIALIZE isExported :: TyCon -> Bool #-} -{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-} -#endif +mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth \end{code} -@ltLexical@ is used for sorting things into lexicographical order, so -as to canonicalize interfaces. [Regular @(<)@ should be used for fast -comparison.] +Orthogonal to the above printing styles are (possibly) some +command-line flags that affect printing (often carried with the +style). The most likely ones are variations on how much type info is +shown. -\begin{code} -a `ltLexical` b - = BIND isLocallyDefined a _TO_ a_local -> - BIND isLocallyDefined b _TO_ b_local -> - BIND getOrigName a _TO_ (a_mod, a_name) -> - BIND getOrigName b _TO_ (b_mod, b_name) -> - if a_local || b_local then - a_name < b_name -- can't compare module names - else - case _CMP_STRING_ a_mod b_mod of - LT_ -> True - EQ_ -> a_name < b_name - GT__ -> False - BEND BEND BEND BEND - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-} -{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-} -{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-} -#endif -\end{code} +The following test decides whether or not we are actually generating +code (either C or assembly), or generating interface files. %************************************************************************ %* * -\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype} +\subsection{The @SDoc@ data type} %* * %************************************************************************ -The export flag @ExportAll@ means `export all there is', so there are -times when it is attached to a class or data type which has no -ops/constructors (if the class/type was imported abstractly). In -fact, @ExportAll@ is attached to everything except to classes/types -which are being {\em exported} abstractly, regardless of how they were -imported. +\begin{code} +type SDoc = PprStyle -> Doc + +withPprStyle :: PprStyle -> SDoc -> SDoc +withPprStyle sty d sty' = d sty + +pprDeeper :: SDoc -> SDoc +pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..." +pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1))) +pprDeeper d other_sty = d other_sty + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df sty = df sty sty +\end{code} \begin{code} -data ExportFlag - = ExportAll -- export with all constructors/methods - | ExportAbs -- export abstractly - | NotExported +unqualStyle :: PprStyle -> Name -> Bool +unqualStyle (PprUser unqual _) n = unqual n +unqualStyle (PprInterface unqual) n = unqual n +unqualStyle other n = False + +codeStyle :: PprStyle -> Bool +codeStyle (PprCode _) = True +codeStyle _ = False + +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle other = False + +ifaceStyle :: PprStyle -> Bool +ifaceStyle (PprInterface _) = True +ifaceStyle other = False + +debugStyle :: PprStyle -> Bool +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 sty@PprDebug = d sty +ifPprDebug d sty = Pretty.empty \end{code} +\begin{code} +printSDoc :: SDoc -> PprStyle -> IO () +printSDoc d sty = printDoc PageMode stdout (d sty) + +-- I'm not sure whether the direct-IO approach of printDoc +-- above is better or worse than the put-big-string approach here +printErrs :: PrintUnqualified -> SDoc -> IO () +printErrs unqual doc = printDoc PageMode stderr (doc style) + where + style = mkUserStyle unqual (PartWay opt_PprUserLength) + +printDump :: SDoc -> IO () +printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle) + where + better_doc = doc $$ text "" + -- We used to always print in debug style, but I want + -- to try the effect of a more user-ish style (unless you + -- say -dppr-debug + +printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () +printForUser handle unqual doc + = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + +-- printForIface prints all on one line for interface files. +-- It's called repeatedly for successive lines +printForIface :: Handle -> PrintUnqualified -> SDoc -> IO () +printForIface handle unqual doc + = printDoc LeftMode handle (doc (PprInterface unqual)) + +-- printForC, printForAsm do what they sound like +printForC :: Handle -> SDoc -> IO () +printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle)) + +printForAsm :: Handle -> SDoc -> IO () +printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) + +pprCode :: CodeStyle -> SDoc -> SDoc +pprCode cs d = withPprStyle (PprCode cs) d + +-- Can't make SDoc an instance of Show because SDoc is just a function type +-- However, Doc *is* an instance of Show +-- showSDoc just blasts it out as a string +showSDoc :: SDoc -> String +showSDoc d = show (d defaultUserStyle) + +showSDocForUser :: PrintUnqualified -> SDoc -> String +showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) + +showSDocUnqual :: SDoc -> String +-- Only used in the gruesome HsExpr.isOperator +showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) + +showsPrecSDoc :: Int -> SDoc -> ShowS +showsPrecSDoc p d = showsPrec p (d defaultUserStyle) + +showSDocIface :: SDoc -> String +showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify)) + +showSDocDebug :: SDoc -> String +showSDocDebug d = show (d PprDebug) +\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 +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 '>' + +-- 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("::") +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 [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es +\end{code} + + %************************************************************************ %* * \subsection[Outputable-class]{The @Outputable@ class} @@ -159,136 +301,211 @@ data ExportFlag \begin{code} class Outputable a where - ppr :: PprStyle -> a -> Pretty + ppr :: a -> SDoc \end{code} \begin{code} --- the ppSep in the ppInterleave puts in the spaces --- Death to ppSep! (WDP 94/11) +instance Outputable Bool where + ppr True = ptext SLIT("True") + ppr False = ptext SLIT("False") -interppSP :: Outputable a => PprStyle -> [a] -> Pretty -interppSP sty xs = ppIntersperse ppSP (map (ppr sty) xs) +instance Outputable Int where + ppr n = int n -interpp'SP :: Outputable a => PprStyle -> [a] -> Pretty -interpp'SP sty xs - = ppInterleave sep (map (ppr sty) xs) - where - sep = ppBeside ppComma ppSP - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE interppSP :: PprStyle -> [Id] -> Pretty #-} -{-# SPECIALIZE interppSP :: PprStyle -> [TyVar] -> Pretty #-} - -{-# SPECIALIZE interpp'SP :: PprStyle -> [(Id, Id)] -> Pretty #-} -{-# SPECIALIZE interpp'SP :: PprStyle -> [Id] -> Pretty #-} -{-# SPECIALIZE interpp'SP :: PprStyle -> [ProtoName] -> Pretty #-} -{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVarTemplate] -> Pretty #-} -{-# SPECIALIZE interpp'SP :: PprStyle -> [TyVar] -> Pretty #-} -{-# SPECIALIZE interpp'SP :: PprStyle -> [Type] -> Pretty #-} -#endif -\end{code} +instance Outputable () where + ppr _ = text "()" -\begin{code} -ifPprDebug sty p = case sty of PprDebug -> p ; _ -> ppNil -ifPprShowAll sty p = case sty of PprShowAll -> p ; _ -> ppNil -ifPprInterface sty p = case sty of PprInterface -> p ; _ -> ppNil +instance (Outputable a) => Outputable [a] where + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + +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 + +-- ToDo: may not be used +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 ]) + +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]) + +instance Outputable FastString where + ppr fs = text (unpackFS fs) -- Prints an unadorned string, + -- no double quotes or anything + +#if __GLASGOW_HASKELL__ < 410 +-- Assume we have only 8-bit Chars. + +pprHsChar :: Int -> SDoc +pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\'' + +pprHsString :: FAST_STRING -> SDoc +pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs))) + +showCharLit :: Int -> String -> String +showCharLit c rest + | c == ord '\"' = "\\\"" ++ rest + | c == ord '\'' = "\\\'" ++ rest + | c == ord '\\' = "\\\\" ++ rest + | c >= 0x20 && c <= 0x7E = chr c : rest + | c == ord '\a' = "\\a" ++ rest + | c == ord '\b' = "\\b" ++ rest + | c == ord '\f' = "\\f" ++ rest + | c == ord '\n' = "\\n" ++ rest + | c == ord '\r' = "\\r" ++ rest + | c == ord '\t' = "\\t" ++ rest + | c == ord '\v' = "\\v" ++ rest + | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of + d:_ | isDigit d -> "\\&" ++ rest + _ -> rest + +#else +-- We have 31-bit Chars and will simply use Show instances +-- of Char and String. + +pprHsChar :: Int -> SDoc +pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32)) + | otherwise = text (show (chr c)) + +pprHsString :: FastString -> SDoc +pprHsString fs = text (show (unpackFS fs)) + +#endif -ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p -ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p +instance Show FastString where + showsPrec p fs = showsPrecSDoc p (ppr fs) \end{code} -These functions test strings to see if they fit the lexical categories -defined in the Haskell report. Normally applied as in, e.g., -@isConop (getOccurrenceName foo)@... [just for pretty-printing] + +%************************************************************************ +%* * +\subsection{Other helper functions} +%* * +%************************************************************************ \begin{code} -isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool - -isConop cs - | _NULL_ cs = False - | c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s - | otherwise = isUpper c || c == ':' - || c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!! - || isUpperISO c - where - c = _HEAD_ cs - -isAconop cs - | _NULL_ cs = False - | otherwise = c == ':' - where - c = _HEAD_ cs - -isAvarid cs - | _NULL_ cs = False - | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s - | isLower c = True - | isLowerISO c = True - | otherwise = False - where - c = _HEAD_ cs - -isAvarop cs - | _NULL_ cs = False - | isLower c = False - | isUpper c = False - | c `elem` "!#$%&*+./<=>?@\\^|~-" = True - | isSymbolISO c = True - | otherwise = False +pprCols = (100 :: Int) -- could make configurable + +printDoc :: Mode -> Handle -> Doc -> IO () +printDoc mode hdl doc + = fullRender mode pprCols 1.5 put done doc where - c = _HEAD_ cs + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutFS hdl s >> next + + done = hPutChar hdl '\n' -isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf]) -isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c -isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c +showDocWith :: Mode -> Doc -> String +showDocWith mode doc + = fullRender mode 100 1.5 put "" doc + where + put (Chr c) s = c:s + put (Str s1) s2 = s1 ++ s2 + put (PStr s1) s2 = _UNPK_ s1 ++ s2 \end{code} -And one ``higher-level'' interface to those: \begin{code} -isOpLexeme :: NamedThing a => a -> Bool +pprWithCommas :: (a -> SDoc) -> [a] -> SDoc +pprWithCommas pp xs = hsep (punctuate comma (map pp xs)) -isOpLexeme v - = let str = getOccurrenceName v in isAvarop str || isAconop str +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = hsep (map ppr xs) --- print `vars`, (op) correctly -pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = hsep (punctuate comma (map ppr xs)) -pprOp sty var - = if isOpLexeme var - then ppr sty var - else ppBesides [ppChar '`', ppr sty var, ppChar '`'] +pprQuotedList :: Outputable a => [a] -> SDoc +-- [x,y,z] ==> `x', `y', `z' +pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) +\end{code} -pprNonOp sty var - = if isOpLexeme var - then ppBesides [ppLparen, ppr sty var, ppRparen] - else ppr sty var -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isOpLexeme :: Id -> Bool #-} -{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-} -{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-} -{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-} -#endif +%************************************************************************ +%* * +\subsection{Printing numbers verbally} +%* * +%************************************************************************ + +@speakNth@ converts an integer to a verbal index; eg 1 maps to +``first'' etc. + +\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 n = hcat [ int n, text st_nd_rd_th ] + where + st_nd_rd_th | n_rem_10 == 1 = "st" + | n_rem_10 == 2 = "nd" + | n_rem_10 == 3 = "rd" + | otherwise = "th" + + n_rem_10 = n `rem` 10 \end{code} \begin{code} -instance Outputable Bool where - ppr sty True = ppPStr SLIT("True") - ppr sty False = ppPStr SLIT("False") +speakNTimes :: Int {- >=1 -} -> SDoc +speakNTimes t | t == 1 = ptext SLIT("once") + | t == 2 = ptext SLIT("twice") + | otherwise = int t <+> ptext SLIT("times") +\end{code} -instance (Outputable a) => Outputable [a] where - ppr sty xs = - ppBesides [ ppLbrack, ppInterleave ppComma (map (ppr sty) xs), ppRbrack ] -instance (Outputable a, Outputable b) => Outputable (a, b) where - ppr sty (x,y) = - ppHang (ppBesides [ppLparen, ppr sty x, ppComma]) 4 (ppBeside (ppr sty y) ppRparen) +%************************************************************************ +%* * +\subsection{Error handling} +%* * +%************************************************************************ --- ToDo: may not be used -instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where - ppr sty (x,y,z) = - ppSep [ ppBesides [ppLparen, ppr sty x, ppComma], - ppBeside (ppr sty y) ppComma, - ppBeside (ppr sty z) ppRparen ] +\begin{code} +pprPanic :: String -> SDoc -> a +pprError :: String -> SDoc -> a +pprTrace :: String -> SDoc -> a -> a +pprPanic = pprAndThen panic +pprError = pprAndThen error +pprTrace = pprAndThen trace + +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 + doc = sep [text heading, nest 4 pretty_msg] + +assertPprPanic :: String -> Int -> SDoc -> a +assertPprPanic file line msg + = panic (show (doc PprDebug)) + where + doc = sep [hsep[text "ASSERT failed! file", + text file, + text "line", int line], + 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 + where + doc = sep [hsep [text "WARNING: file", text file, text "line", int line], + msg] \end{code}