X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=01db06fd7291e1f15c5b7f22368dfe5653597ca9;hp=ad6548bd62cc1a15be316bbccfbfa4445f42f576;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=36f77deda25312534200f10ccdb18528b6ee6e27

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index ad6548b..01db06f 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -7,6 +7,12 @@ Outputable: defines classes for pretty-printing and forcing, both
 forms of ``output.''
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
 
 module Outputable (
 	Outputable(..), OutputableBndr(..),	-- Class
@@ -14,7 +20,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,
@@ -35,7 +42,7 @@ module Outputable (
 	hang, punctuate,
 	speakNth, speakNTimes, speakN, speakNOf, plural,
 
-	printSDoc, printErrs, printDump,
+	printSDoc, printErrs, hPrintDump, printDump,
 	printForC, printForAsm, printForUser,
 	pprCode, mkCodeStyle,
 	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
@@ -188,6 +195,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
@@ -244,9 +264,12 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc
 		   hFlush stderr
 
 printDump :: SDoc -> IO ()
-printDump doc = do
-   Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
-   hFlush stdout
+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 $$ text ""
 
@@ -395,6 +418,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) =