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,
hang, punctuate,
speakNth, speakNTimes, speakN, speakNOf, plural,
- printSDoc, printErrs, printDump,
+ printSDoc, printErrs, hPrintDump, printDump,
printForC, printForAsm, printForUser,
pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
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
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 ""
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) =