replace several 'fromJust's with 'expectJust's

[ghc-hetmet.git] / ghc / compiler / utils / Outputable.lhs

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index f870b65..cf99e12 100644 (file)
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -14,10 +14,10 @@ module Outputable (
        BindingSite(..),
 
        PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
-       getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
+       getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
        codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
        ifPprDebug, unqualStyle, 
-       mkErrStyle, defaultErrStyle,
+       mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
 
        SDoc,           -- Abstract
        docToSDoc,
@@ -33,7 +33,7 @@ module Outputable (
        sep, cat, 
        fsep, fcat, 
        hang, punctuate,
-       speakNth, speakNTimes,
+       speakNth, speakNTimes, speakN, speakNOf, plural,
 
        printSDoc, printErrs, printDump,
        printForC, printForAsm, printForUser,
@@ -156,6 +156,10 @@ 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
 
+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}
@@ -369,8 +373,8 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
                   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)
@@ -416,9 +420,6 @@ pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) ::
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))
-
-instance Show FastString  where
-    showsPrec p fs = showsPrecSDoc p (ppr fs)
 \end{code}
 
 
@@ -455,7 +456,6 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 
 \begin{code}
 speakNth :: Int -> SDoc
-
 speakNth 1 = ptext SLIT("first")
 speakNth 2 = ptext SLIT("second")
 speakNth 3 = ptext SLIT("third")
@@ -471,13 +471,29 @@ speakNth n = hcat [ int n, text suffix ]
           | 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}