BindingSite(..),
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
- getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
- codeStyle, userStyle, debugStyle, asmStyle,
+ getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
+ codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
ifPprDebug, unqualStyle,
- mkErrStyle, defaultErrStyle,
+ mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
SDoc, -- Abstract
docToSDoc,
sep, cat,
fsep, fcat,
hang, punctuate,
- speakNth, speakNTimes,
+ speakNth, speakNTimes, speakN, speakNOf, plural,
printSDoc, printErrs, printDump,
printForC, printForAsm, printForUser,
pprCode, mkCodeStyle,
- showSDoc, showSDocForUser, showSDocDebug,
+ showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
showSDocUnqual, showsPrecSDoc,
pprHsChar, pprHsString,
#include "HsVersions.h"
-import {-# SOURCE #-} Module( ModuleName )
+import {-# SOURCE #-} Module( Module )
import {-# SOURCE #-} OccName( OccName )
-import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
+import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
+import PackageConfig ( PackageId, packageIdString )
import FastString
import qualified Pretty
import Pretty ( Doc, Mode(..) )
\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.
+ = 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.
- | PprCode CodeStyle -- Print code; either C or assembler
+ | PprCode CodeStyle
+ -- Print code; either C or assembler
- | PprDebug -- Standard debugging output
+ | PprDump -- For -ddump-foo; less verbose than PprDebug.
+ -- Does not assume tidied code: non-external names
+ -- are printed with uniques.
+
+ | PprDebug -- Full debugging output
data CodeStyle = CStyle -- The format of labels differs for C and assembler
| AsmStyle
| PartWay Int -- 0 => stop
-type PrintUnqualified = ModuleName -> OccName -> Bool
+type PrintUnqualified = Module -> OccName -> Bool
-- This function tells when it's ok to print
-- a (Global) name unqualified
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
+defaultDumpStyle | opt_PprStyle_Debug = PprDebug
+ | otherwise = PprDump
+
mkErrStyle :: PrintUnqualified -> PprStyle
-- Style for printing error messages
mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
pprDeeper d other_sty = d other_sty
+pprSetDepth :: Int -> SDoc -> SDoc
+pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n))
+pprSetDepth n d other_sty = d other_sty
+
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
\end{code}
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
printDump :: SDoc -> IO ()
printDump doc = do
- Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
+ Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
hFlush stdout
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
showsPrecSDoc :: Int -> SDoc -> ShowS
showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+showSDocDump :: SDoc -> String
+showSDocDump d = show (d PprDump)
+
showSDocDebug :: SDoc -> String
showSDocDebug d = show (d PprDebug)
\end{code}
ppr w])
instance Outputable FastString where
- ppr fs = text (unpackFS 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 PackageId where
+ ppr pid = text (packageIdString pid)
\end{code}
pprHsString :: FastString -> SDoc
pprHsString fs = text (show (unpackFS fs))
-
-instance Show FastString where
- showsPrec p fs = showsPrecSDoc p (ppr fs)
\end{code}
\begin{code}
speakNth :: Int -> SDoc
-
speakNth 1 = ptext SLIT("first")
speakNth 2 = ptext SLIT("second")
speakNth 3 = ptext SLIT("third")
| otherwise = "th"
last_dig = n `rem` 10
-\end{code}
-\begin{code}
+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 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 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 = int t <+> ptext SLIT("times")
+ | otherwise = speakN t <+> ptext SLIT("times")
+
+plural [x] = empty
+plural xs = char 's'
\end{code}