%
+% (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}
+{-# 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/Commentary/CodingStyle#Warnings
+-- for details
module Outputable (
Outputable(..), OutputableBndr(..), -- Class
BindingSite(..),
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
- getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
+ getPprStyle, withPprStyle, withPprStyleDoc,
+ pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
- ifPprDebug, unqualStyle,
+ ifPprDebug, qualName, qualModule,
mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
SDoc, -- Abstract
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,
hang, punctuate,
speakNth, speakNTimes, speakN, speakNOf, plural,
- printSDoc, printErrs, printDump,
+ printSDoc, printErrs, hPrintDump, printDump,
printForC, printForAsm, printForUser,
pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
#include "HsVersions.h"
-import {-# SOURCE #-} Module( Module )
+import {-# SOURCE #-} Module( Module, modulePackageId,
+ ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
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}
%************************************************************************
\begin{code}
+
data PprStyle
= PprUser PrintUnqualified Depth
-- Pretty-print in a way that will make sense to the
| PartWay Int -- 0 => stop
-type PrintUnqualified = Module -> OccName -> Bool
- -- This function tells when it's ok to print
- -- a (Global) name unqualified
+-- -----------------------------------------------------------------------------
+-- Printing original names
+
+-- When printing code that contains original names, we need to map the
+-- original names back to something the user understands. This is the
+-- purpose of the pair of functions that gets passed around
+-- when rendering 'SDoc'.
+
+-- | given an /original/ name, this function tells you which module
+-- name it should be qualified with when printing for the user, if
+-- any. For example, given @Control.Exception.catch@, which is in scope
+-- as @Exception.catch@, this fuction will return @Just "Exception"@.
+-- Note that the return value is a ModuleName, not a Module, because
+-- in source code, names are qualified by ModuleNames.
+type QualifyName = Module -> OccName -> Maybe ModuleName
+
+-- | For a given module, we need to know whether to print it with
+-- a package name to disambiguate it, and if so which package name should
+-- we use.
+type QualifyModule = Module -> Maybe PackageId
+
+type PrintUnqualified = (QualifyName, QualifyModule)
+
+alwaysQualifyNames :: QualifyName
+alwaysQualifyNames m n = Just (moduleName m)
+
+neverQualifyNames :: QualifyName
+neverQualifyNames m n = Nothing
-alwaysQualify,neverQualify :: PrintUnqualified
-alwaysQualify m n = False
-neverQualify m n = True
+alwaysQualifyModules :: QualifyModule
+alwaysQualifyModules m = Just (modulePackageId m)
+
+neverQualifyModules :: QualifyModule
+neverQualifyModules m = Nothing
+
+alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
+neverQualify = (neverQualifyNames, neverQualifyModules)
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
defaultDumpStyle | opt_PprStyle_Debug = PprDebug
| otherwise = PprDump
+-- | Style for printing error messages
mkErrStyle :: PrintUnqualified -> PprStyle
--- Style for printing error messages
-mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
+mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
defaultErrStyle :: PprStyle
-- Default style for error messages
-- It's a bit of a hack because it doesn't take into account what's in scope
-- Only used for desugarer warnings, and typechecker errors in interface sigs
defaultErrStyle
- | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
- | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
+ | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
+ | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
-mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
- | otherwise = PprUser unqual depth
+mkUserStyle unqual depth
+ | opt_PprStyle_Debug = PprDebug
+ | otherwise = PprUser unqual depth
\end{code}
Orthogonal to the above printing styles are (possibly) some
withPprStyleDoc sty d = d sty
pprDeeper :: SDoc -> SDoc
-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
+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 unqual _) = d (PprUser unqual (PartWay n))
-pprSetDepth n d other_sty = d other_sty
+pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
+pprSetDepth n d other_sty = d other_sty
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
\end{code}
\begin{code}
-unqualStyle :: PprStyle -> PrintUnqualified
-unqualStyle (PprUser unqual _) m n = unqual m n
-unqualStyle other m n = False
+qualName :: PprStyle -> QualifyName
+qualName (PprUser (qual_name,_) _) m n = qual_name m n
+qualName other m n = Just (moduleName m)
+
+qualModule :: PprStyle -> QualifyModule
+qualModule (PprUser (_,qual_mod) _) m = qual_mod m
+qualModule other m = Just (modulePackageId m)
codeStyle :: PprStyle -> Bool
codeStyle (PprCode _) = True
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 ""
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'.
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) =
projects / ghc-hetmet.git / blobdiff