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

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 4f8d320..2bf1b9c 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -7,13 +7,19 @@ 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,
+	PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..),
 	getPprStyle, withPprStyle, withPprStyleDoc, 
 	pprDeeper, pprDeeperList, pprSetDepth,
 	codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
@@ -36,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,
@@ -115,26 +121,36 @@ data Depth = AllTheWay
 -- 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
+type QueryQualifyName = Module -> OccName -> QualifyName
+
+data QualifyName                        -- given P:M.T
+        = NameUnqual                    -- refer to it as "T"
+        | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
+        | NameNotInScope1               
+                -- it is not in scope at all, but M.T is not bound in the current
+                -- scope, so we can refer to it as "M.T"
+        | NameNotInScope2
+                -- it is not in scope at all, and M.T is already bound in the
+                -- current scope, so we must refer to it as "P:M.T"
+
 
 -- | 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
+-- a package name to disambiguate it.
+type QueryQualifyModule = Module -> Bool
 
-type PrintUnqualified = (QualifyName, QualifyModule)
+type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
 
-alwaysQualifyNames :: QualifyName
-alwaysQualifyNames m n = Just (moduleName m)
+alwaysQualifyNames :: QueryQualifyName
+alwaysQualifyNames m n = NameQual (moduleName m)
 
-neverQualifyNames :: QualifyName
-neverQualifyNames m n = Nothing
+neverQualifyNames :: QueryQualifyName
+neverQualifyNames m n = NameUnqual
 
-alwaysQualifyModules :: QualifyModule
-alwaysQualifyModules m = Just (modulePackageId m)
+alwaysQualifyModules :: QueryQualifyModule
+alwaysQualifyModules m = True
 
-neverQualifyModules :: QualifyModule
-neverQualifyModules m = Nothing
+neverQualifyModules :: QueryQualifyModule
+neverQualifyModules m = False
 
 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
 neverQualify  = (neverQualifyNames,  neverQualifyModules)
@@ -211,13 +227,13 @@ getPprStyle df sty = df sty sty
 \end{code}
 
 \begin{code}
-qualName :: PprStyle -> QualifyName
+qualName :: PprStyle -> QueryQualifyName
 qualName (PprUser (qual_name,_) _) m n = qual_name m n
-qualName other		           m n = Just (moduleName m)
+qualName other		           m n = NameQual (moduleName m)
 
-qualModule :: PprStyle -> QualifyModule
+qualModule :: PprStyle -> QueryQualifyModule
 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
-qualModule other                    m = Just (modulePackageId m)
+qualModule other                    m = True
 
 codeStyle :: PprStyle -> Bool
 codeStyle (PprCode _)	  = True
@@ -258,9 +274,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 ""
 
@@ -409,6 +428,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) =