\begin{code}
module Outputable (
- Outputable(..), -- Class
+ Outputable(..), OutputableBndr(..), -- Class
+
+ BindingSite(..),
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
codeStyle, userStyle, debugStyle, asmStyle,
- ifPprDebug, unqualStyle,
+ ifPprDebug, unqualStyle,
+ mkErrStyle, defaultErrStyle,
SDoc, -- Abstract
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas,
empty, nest,
- text, char, ptext,
+ text, char, ftext, ptext,
int, integer, float, double, rational,
parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
semi, comma, colon, dcolon, space, equals, dot,
import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
import FastString
import qualified Pretty
-import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
+import Pretty ( Doc, Mode(..) )
import Panic
-import Word ( Word32 )
-import IO ( Handle, stderr, stdout )
+import DATA_WORD ( Word32 )
+
+import IO ( Handle, stderr, stdout, hFlush )
import Char ( chr )
#if __GLASGOW_HASKELL__ < 410
import Char ( ord, isDigit )
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
+mkErrStyle :: PrintUnqualified -> PprStyle
+-- Style for printing error messages
+mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
+
+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
+ | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
+ | otherwise = mkUserStyle neverQualify (PartWay opt_PprUserLength)
+
mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
| otherwise = PprUser unqual depth
\end{code}
\end{code}
\begin{code}
+-- Unused [7/02 sof]
printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = Pretty.printDoc PageMode stdout (d sty)
+printSDoc d sty = do
+ Pretty.printDoc PageMode stdout (d sty)
+ hFlush stdout
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
-- above is better or worse than the put-big-string approach here
-printErrs :: PrintUnqualified -> SDoc -> IO ()
-printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
- where
- style = mkUserStyle unqual (PartWay opt_PprUserLength)
+printErrs :: Doc -> IO ()
+printErrs doc = do Pretty.printDoc PageMode stderr doc
+ hFlush stderr
printDump :: SDoc -> IO ()
-printDump doc = Pretty.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
+printDump doc = do
+ Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
+ 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
empty sty = Pretty.empty
text s sty = Pretty.text s
char c sty = Pretty.char c
+ftext s sty = Pretty.ftext s
ptext s sty = Pretty.ptext s
int n sty = Pretty.int n
integer n sty = Pretty.integer n
instance Outputable FastString where
ppr fs = text (unpackFS fs) -- Prints an unadorned string,
-- no double quotes or anything
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The @OutputableBndr@ class}
+%* *
+%************************************************************************
+
+When we print a binder, we often want to print its type too.
+The @OutputableBndr@ class encapsulates this idea.
+@BindingSite@ is used to tell the thing that prints binder what
+language construct is binding the identifier. This can be used
+to decide how much info to print.
+
+\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}
#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)))
+pprHsString :: FastString -> SDoc
+pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs)))
showCharLit :: Int -> String -> String
showCharLit c rest
%************************************************************************
\begin{code}
-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}
-
-
-\begin{code}
pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
-pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
+pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
interppSP :: Outputable a => [a] -> SDoc
interppSP xs = hsep (map ppr xs)
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 ]
+speakNth n = hcat [ int n, text suffix ]
where
- st_nd_rd_th | n_rem_10 == 1 = "st"
- | n_rem_10 == 2 = "nd"
- | n_rem_10 == 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"
- n_rem_10 = n `rem` 10
+ last_dig = n `rem` 10
\end{code}
\begin{code}
projects / ghc-hetmet.git / blobdiff