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

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index ad6548b..4f8d320 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -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,
@@ -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