%
% (c) The University of Glasgow 2006
% (c) The GRASP Project, Glasgow University, 1992-1998
%
\begin{code}
module Outputable (
Outputable(..), OutputableBndr(..),
SDoc,
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
empty, nest,
char,
text, ftext, ptext,
int, integer, float, double, rational,
parens, cparen, brackets, braces, quotes, 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,
printSDoc, printErrs, printOutput, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
showSDoc, showSDocOneLine,
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showPpr,
showSDocUnqual, showsPrecSDoc,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsInfix, pprHsVar,
pprFastFilePath,
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(..),
pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
pprTrace, warnPprTrace,
trace, pgmError, panic, sorry, panicFastInt, assertPanic
) where
import Module( Module, ModuleName, moduleName )
import OccName( OccName )
import StaticFlags
import FastString
import FastTypes
import qualified Pretty
import Pretty ( Doc, Mode(..) )
import Panic
import Data.Char
import Data.Map (Map)
import qualified Data.Map as M
import Data.Word
import System.IO ( Handle, stderr, stdout, hFlush )
import System.FilePath
\end{code}
%************************************************************************
%* *
\subsection{The @PprStyle@ data type}
%* *
%************************************************************************
\begin{code}
data PprStyle
= PprUser PrintUnqualified Depth
| PprCode CodeStyle
| PprDump
| PprDebug
data CodeStyle = CStyle
| AsmStyle
data Depth = AllTheWay
| PartWay Int
type QueryQualifyName = Module -> OccName -> QualifyName
data QualifyName
= NameUnqual
| NameQual ModuleName
| NameNotInScope1
| NameNotInScope2
type QueryQualifyModule = Module -> Bool
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
alwaysQualifyNames :: QueryQualifyName
alwaysQualifyNames m _ = NameQual (moduleName m)
neverQualifyNames :: QueryQualifyName
neverQualifyNames _ _ = NameUnqual
alwaysQualifyModules :: QueryQualifyModule
alwaysQualifyModules _ = True
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
| otherwise = PprDump
mkErrStyle :: PrintUnqualified -> PprStyle
mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
defaultErrStyle :: PprStyle
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
command-line flags that affect printing (often carried with the
style). The most likely ones are variations on how much type info is
shown.
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}
type SDoc = PprStyle -> Doc
withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d _sty' = d sty
withPprStyleDoc :: PprStyle -> SDoc -> Doc
withPprStyleDoc sty d = d sty
pprDeeper :: SDoc -> SDoc
pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n1)))
pprDeeper d other_sty = d other_sty
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
pprDeeperList f ds (PprUser q (PartWay n))
| n==0 = Pretty.text "..."
| otherwise = f (go 0 ds) (PprUser q (PartWay (n1)))
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 :: Depth -> SDoc -> SDoc
pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
pprSetDepth _depth doc other_sty = doc other_sty
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
\end{code}
\begin{code}
qualName :: PprStyle -> QueryQualifyName
qualName (PprUser (qual_name,_) _) m n = qual_name m n
qualName _other m _n = NameQual (moduleName m)
qualModule :: PprStyle -> QueryQualifyModule
qualModule (PprUser (_,qual_mod) _) m = qual_mod m
qualModule _other _m = True
codeStyle :: PprStyle -> Bool
codeStyle (PprCode _) = True
codeStyle _ = False
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle) = True
asmStyle _other = False
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
dumpStyle _other = False
debugStyle :: PprStyle -> Bool
debugStyle PprDebug = True
debugStyle _other = False
userStyle :: PprStyle -> Bool
userStyle (PprUser _ _) = True
userStyle _other = False
ifPprDebug :: SDoc -> SDoc
ifPprDebug d sty@PprDebug = d sty
ifPprDebug _ _ = Pretty.empty
\end{code}
\begin{code}
printSDoc :: SDoc -> PprStyle -> IO ()
printSDoc d sty = do
Pretty.printDoc PageMode stdout (d sty)
hFlush stdout
printErrs :: Doc -> IO ()
printErrs doc = do Pretty.printDoc PageMode stderr doc
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)
hFlush h
where
better_doc = doc $$ blankLine
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 :: Handle -> SDoc -> IO ()
printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
printForAsm :: Handle -> SDoc -> IO ()
printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode
showSDoc :: SDoc -> String
showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle)
showSDocOneLine :: SDoc -> String
showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
showSDocForUser :: PrintUnqualified -> SDoc -> String
showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
showSDocUnqual :: SDoc -> String
showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
showsPrecSDoc :: Int -> SDoc -> ShowS
showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
showSDocDump :: SDoc -> String
showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
showSDocDumpOneLine :: SDoc -> String
showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
showSDocDebug :: SDoc -> String
showSDocDebug d = show (d PprDebug)
showPpr :: Outputable a => a -> String
showPpr = showSDoc . ppr
\end{code}
\begin{code}
docToSDoc :: Doc -> SDoc
docToSDoc d = \_ -> 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 _sty = Pretty.empty
char c _sty = Pretty.char c
text s _sty = Pretty.text s
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)
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 d sty = case show pp_d of
('\'' : _) -> pp_d
_other -> Pretty.quotes pp_d
where
pp_d = d sty
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
blankLine _sty = Pretty.ptext (sLit "")
dcolon _sty = Pretty.ptext (sLit "::")
arrow _sty = Pretty.ptext (sLit "->")
darrow _sty = Pretty.ptext (sLit "=>")
semi _sty = Pretty.semi
comma _sty = Pretty.comma
colon _sty = Pretty.colon
equals _sty = Pretty.equals
space _sty = Pretty.space
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
(<+>) :: SDoc -> SDoc -> SDoc
($$) :: SDoc -> SDoc -> SDoc
($+$) :: SDoc -> SDoc -> SDoc
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 :: [SDoc] -> SDoc
hsep :: [SDoc] -> SDoc
vcat :: [SDoc] -> SDoc
sep :: [SDoc] -> SDoc
cat :: [SDoc] -> SDoc
fsep :: [SDoc] -> SDoc
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]
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 :: SDoc
-> Int
-> SDoc
-> SDoc
hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
punctuate :: SDoc
-> [SDoc]
-> [SDoc]
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
\end{code}
%************************************************************************
%* *
\subsection[Outputable-class]{The @Outputable@ class}
%* *
%************************************************************************
\begin{code}
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")
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 "()"
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
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
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 (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
instance (Outputable key, Outputable elt) => Outputable (Map key elt) where
ppr m = ppr (M.toList m)
\end{code}
%************************************************************************
%* *
\subsection{The @OutputableBndr@ class}
%* *
%************************************************************************
\begin{code}
data BindingSite = LambdaBind | CaseBind | LetBind
class Outputable a => OutputableBndr a where
pprBndr :: BindingSite -> a -> SDoc
pprBndr _b x = ppr x
\end{code}
%************************************************************************
%* *
\subsection{Random printing helpers}
%* *
%************************************************************************
\begin{code}
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
| otherwise = text (show c)
pprHsString :: FastString -> SDoc
pprHsString fs = text (show (unpackFS fs))
pprPrefixVar :: Bool -> SDoc -> SDoc
pprPrefixVar is_operator pp_v
| is_operator = parens pp_v
| otherwise = pp_v
pprInfixVar :: Bool -> SDoc -> SDoc
pprInfixVar is_operator pp_v
| is_operator = pp_v
| otherwise = char '`' <> pp_v <> char '`'
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
('[':_) -> False
('$':c:_) -> not (isAlpha c)
(':':c:_) -> not (isAlpha c)
('_':_) -> False
(c:_) -> not (isAlpha c)
_ -> False
pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
\end{code}
%************************************************************************
%* *
\subsection{Other helper functions}
%* *
%************************************************************************
\begin{code}
pprWithCommas :: (a -> SDoc)
-> [a]
-> SDoc
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
interppSP :: Outputable a => [a] -> SDoc
interppSP xs = sep (map ppr xs)
interpp'SP :: Outputable a => [a] -> SDoc
interpp'SP xs = sep (punctuate comma (map ppr xs))
pprQuotedList :: Outputable a => [a] -> SDoc
pprQuotedList = quotedList . map ppr
quotedList :: [SDoc] -> SDoc
quotedList xs = hsep (punctuate comma (map quotes xs))
quotedListWithOr :: [SDoc] -> SDoc
quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
quotedListWithOr xs = quotedList xs
\end{code}
%************************************************************************
%* *
\subsection{Printing numbers verbally}
%* *
%************************************************************************
\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 suffix ]
where
suffix | n <= 20 = "th"
| last_dig == 1 = "st"
| last_dig == 2 = "nd"
| last_dig == 3 = "rd"
| otherwise = "th"
last_dig = n `rem` 10
speakN :: Int -> SDoc
speakN 0 = ptext (sLit "none")
speakN 1 = ptext (sLit "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'
speakNOf 1 d = ptext (sLit "one") <+> d
speakNOf n d = speakN n <+> d <> char 's'
speakNTimes :: Int -> SDoc
speakNTimes t | t == 1 = ptext (sLit "once")
| t == 2 = ptext (sLit "twice")
| otherwise = speakN t <+> ptext (sLit "times")
plural :: [a] -> SDoc
plural [_] = empty
plural _ = char 's'
\end{code}
%************************************************************************
%* *
\subsection{Error handling}
%* *
%************************************************************************
\begin{code}
pprPanic :: String -> SDoc -> a
pprPanic = pprAndThen panic
pprSorry :: String -> SDoc -> a
pprSorry = pprAndThen sorry
pprPgmError :: String -> SDoc -> a
pprPgmError = pprAndThen pgmError
pprTrace :: String -> SDoc -> a -> a
pprTrace str doc x
| opt_NoDebugOutput = x
| otherwise = pprAndThen trace str doc x
pprPanicFastInt :: String -> SDoc -> FastInt
pprPanicFastInt heading pretty_msg = panicFastInt (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 _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
= trace (show (doc defaultDumpStyle)) x
where
doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
msg]
\end{code}