X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=6d9132e105f2a3bee60c649bebe3e96abab5592a;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=52262ec02e8ab366965a461034aa2ec288eb48c3;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 52262ec..6d9132e 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -1,10 +1,10 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP Project, Glasgow University, 1992-1998
 %
-\section[Outputable]{Classes for pretty-printing}
 
-Defines classes for pretty-printing and forcing, both forms of
-``output.''
+Outputable: defines classes for pretty-printing and forcing, both
+forms of ``output.''
 
 \begin{code}
 
@@ -14,7 +14,8 @@ module Outputable (
 	BindingSite(..),
 
 	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
-	getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
+	getPprStyle, withPprStyle, withPprStyleDoc, 
+	pprDeeper, pprDeeperList, pprSetDepth,
 	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
 	ifPprDebug, qualName, qualModule,
 	mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
@@ -25,7 +26,7 @@ module Outputable (
 	empty, nest,
 	text, char, ftext, ptext,
 	int, integer, float, double, rational,
-	parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
+	parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
 	semi, comma, colon, dcolon, space, equals, dot, arrow,
 	lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
 	(<>), (<+>), hcat, hsep, 
@@ -62,10 +63,9 @@ import qualified Pretty
 import Pretty		( Doc, Mode(..) )
 import Panic
 
-import DATA_WORD	( Word32 )
-
-import IO		( Handle, stderr, stdout, hFlush )
-import Char             ( ord )
+import Data.Word	( Word32 )
+import System.IO	( Handle, stderr, stdout, hFlush )
+import Data.Char        ( ord )
 \end{code}
 
 
@@ -76,6 +76,7 @@ import Char             ( ord )
 %************************************************************************
 
 \begin{code}
+
 data PprStyle
   = PprUser PrintUnqualified Depth
 		-- Pretty-print in a way that will make sense to the
@@ -188,6 +189,19 @@ pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
 pprDeeper d other_sty        	    = d other_sty
 
+pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
+-- Truncate a list that list that is longer than the current depth
+pprDeeperList f ds (PprUser q (PartWay n))
+  | n==0      = Pretty.text "..."
+  | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
+  where
+    go i [] = []
+    go i (d:ds) | i >= n    = [text "...."]
+		| otherwise = d : go (i+1) ds
+
+pprDeeperList f ds other_sty
+  = f ds other_sty
+
 pprSetDepth :: Int -> SDoc -> SDoc
 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
 pprSetDepth n d other_sty     = d other_sty
@@ -311,6 +325,8 @@ brackets d sty     = Pretty.brackets (d sty)
 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 angleBrackets d    = char '<' <> d <> char '>'
 
+cparen b d sty       = Pretty.cparen b (d sty)
+
 -- 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'.
@@ -393,6 +409,10 @@ 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
+
 -- ToDo: may not be used
 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
     ppr (x,y,z) =