%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1998
%
\section[Outputable]{Classes for pretty-printing}
``output.''
\begin{code}
-#include "HsVersions.h"
+{-# OPTIONS -fno-prune-tydecls #-}
+-- Hopefully temporary; 3.02 complained about not being able
+-- to see the consructors for ForeignObj
module Outputable (
- -- NAMED-THING-ERY
- NamedThing(..), -- class
- ExportFlag(..),
- isExported, getLocalName, ltLexical,
-
- -- PRINTERY AND FORCERY
- Outputable(..), -- class
- PprStyle(..), -- style-ry (re-exported)
-
- interppSP, interpp'SP,
---UNUSED: ifPprForUser,
- ifnotPprForUser,
- ifPprDebug, --UNUSED: ifnotPprDebug,
- ifPprShowAll, ifnotPprShowAll,
- ifPprInterface, --UNUSED: ifnotPprInterface,
---UNUSED: ifPprForC, ifnotPprForC,
---UNUSED: ifPprUnfolding, ifnotPprUnfolding,
-
- isOpLexeme, pprOp, pprNonOp,
- isConop, isAconop, isAvarid, isAvarop, --UNUSED: isAconid,
-
- -- and to make the interface self-sufficient...
- Pretty(..), GlobalSwitch,
- PrettyRep, UniType, Unique, SrcLoc
+ Outputable(..), -- Class
+
+ PprStyle, CodeStyle(..),
+ getPprStyle, withPprStyle, pprDeeper,
+ codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
+ ifPprDebug, ifNotPprForUser,
+
+ SDoc, -- Abstract
+ 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, showSDocDebug, showSDocIface, showsPrecSDoc,
+ pprHsChar, pprHsString,
+
+
+ -- error handling
+ pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
+ trace, panic, panic#, assertPanic
) where
-import AbsUniType ( UniType,
- TyCon, Class, TyVar, TyVarTemplate -- for SPECIALIZing
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpTyCon)
- )
-import Id ( Id ) -- for specialising
-import NameTypes -- for specialising
-import ProtoName -- for specialising
-import Pretty
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
+#include "HsVersions.h"
+
+
+import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
+import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
+import FastString
+import qualified Pretty
+import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
+import Panic
+import ST ( runST )
+import Foreign
+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
- getTheUnique :: a -> Unique
- hasType :: a -> Bool
- getType :: a -> UniType
- fromPreludeCore :: a -> Bool
- -- see also friendly functions that follow...
-\end{code}
+data PprStyle
+ = PprUser Depth -- Pretty-print in a way that will
+ -- make sense to the ordinary user;
+ -- must be very close to Haskell
+ -- syntax, etc.
-\begin{description}
-\item[@getExportFlag@:]
-Obvious.
+ | PprDebug -- Standard debugging output
-\item[@getOrigName@:]
-Obvious.
+ | PprInterface -- 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)...
-\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
+\end{code}
-\item[@hasType@ and @getType@:]
-In pretty-printing @AbsSyntax@, we need to query if a datatype has
-types attached yet or not. We use @hasType@ to see if there are types
-available; and @getType@ if we want to grab one... (Ugly but effective)
+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.
-\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}.
+The following test decides whether or not we are actually generating
+code (either C or assembly), or generating interface files.
-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}
+%************************************************************************
+%* *
+\subsection{The @SDoc@ data type}
+%* *
+%************************************************************************
-Some functions to go with:
\begin{code}
-isExported a
- = case (getExportFlag a) of
- NotExported -> False
- _ -> True
+type SDoc = PprStyle -> Doc
-getLocalName :: (NamedThing a) => a -> FAST_STRING
+withPprStyle :: PprStyle -> SDoc -> SDoc
+withPprStyle sty d sty' = d sty
-getLocalName = snd . getOrigName
+pprDeeper :: SDoc -> SDoc
+pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
+pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
+pprDeeper d other_sty = d other_sty
-#ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isExported :: Class -> Bool #-}
-{-# SPECIALIZE isExported :: Id -> Bool #-}
-{-# SPECIALIZE isExported :: TyCon -> Bool #-}
-{-# SPECIALIZE getLocalName :: ShortName -> FAST_STRING #-}
-#endif
+getPprStyle :: (PprStyle -> SDoc) -> SDoc
+getPprStyle df sty = df sty sty
\end{code}
-@ltLexical@ is used for sorting things into lexicographical order, so
-as to canonicalize interfaces. [Regular @(<)@ should be used for fast
-comparison.]
-
\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
+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
\end{code}
-%************************************************************************
-%* *
-\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
-%* *
-%************************************************************************
+\begin{code}
+ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
+ifNotPprForUser d sty@(PprUser _) = Pretty.empty
+ifNotPprForUser d sty = d sty
-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.
+ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
+ifPprDebug d sty@PprDebug = d sty
+ifPprDebug d sty = Pretty.empty
+\end{code}
\begin{code}
-data ExportFlag
- = ExportAll -- export with all constructors/methods
- | ExportAbs -- export abstractly
- | NotExported
+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 :: SDoc -> IO ()
+printErrs doc = printDoc PageMode stderr (final_doc user_style)
+ where
+ final_doc = doc -- $$ text ""
+ user_style = mkUserStyle (PartWay opt_PprUserLength)
+
+printDump :: SDoc -> IO ()
+printDump doc = printForUser stdout (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 -> SDoc -> IO ()
+printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
+
+-- 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))
+
+-- printForIface prints all on one line for interface files.
+-- It's called repeatedly for successive lines
+printForIface :: Handle -> SDoc -> IO ()
+printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
+
+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 (mkUserStyle AllTheWay))
+
+showSDocIface :: SDoc -> String
+showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
+
+showSDocDebug :: SDoc -> String
+showSDocDebug d = show (d PprDebug)
+
+showsPrecSDoc :: Int -> SDoc -> ShowS
+showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
+
+mkUserStyle depth | opt_PprStyle_Debug = PprDebug
+ | otherwise = PprUser depth
\end{code}
+\begin{code}
+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}
\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
+
+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 = text "Nothing"
+ ppr (Just x) = text "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 c $ 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 = text (show (chr c))
+
+pprHsString :: FastString -> SDoc
+pprHsString fs = text (show (unpackFS fs))
-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 -> [UniType] -> Pretty #-}
#endif
-\end{code}
-\begin{code}
---UNUSED: ifPprForUser sty p = case sty of PprForUser -> p ; _ -> ppNil
-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
---UNUSED: ifPprForC sty p = case sty of PprForC _ -> p ; _ -> ppNil
---UNUSED: ifPprUnfolding sty p = case sty of PprUnfolding _ -> p ; _ -> ppNil
-
-ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p
---UNUSED: ifnotPprDebug sty p = case sty of PprDebug -> ppNil ; _ -> p
-ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p
---UNUSED: ifnotPprInterface sty p = case sty of PprInterface _ -> ppNil; _ -> p
---UNUSED: ifnotPprForC sty p = case sty of PprForC _ -> ppNil; _ -> p
---UNUSED: ifnotPprUnfolding sty p = case sty of PprUnfolding _ -> 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]
-
-\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 == ':'
- where
- c = _HEAD_ cs
+%************************************************************************
+%* *
+\subsection{Other helper functions}
+%* *
+%************************************************************************
-{- UNUSED:
-isAconid [] = False
-isAconid ('_':cs) = isAconid cs
-isAconid (c:cs) = isUpper c
--}
+\begin{code}
+pprCols = (100 :: Int) -- could make configurable
-isAconop cs
- | _NULL_ cs = False
- | otherwise = c == ':'
+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
-isAvarid cs
- | _NULL_ cs = False
- | c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
- | otherwise = isLower c
- where
- c = _HEAD_ cs
+ done = hPutChar hdl '\n'
-isAvarop cs
- | _NULL_ cs = False
- | isLower c = False -- shortcut
- | isUpper c = False -- ditto
- | otherwise = c `elem` "!#$%&*+./<=>?@\\^|~-" -- symbol or minus
+showDocWith :: Mode -> Doc -> String
+showDocWith mode doc
+ = fullRender mode 100 1.5 put "" doc
where
- c = _HEAD_ cs
+ 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}