X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=db744b1a059ce0cec7d62534a3a6429318d9993e;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hp=cf99e12bcf1b8f95084038c8cece8645fee64e33;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index cf99e12..db744b1 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -1,10 +1,10 @@ % +% (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} @@ -16,7 +16,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, unqualStyle, + ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, SDoc, -- Abstract @@ -51,7 +51,8 @@ module Outputable ( #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 ) @@ -61,10 +62,9 @@ import qualified Pretty 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} @@ -75,6 +75,7 @@ import Char ( ord ) %************************************************************************ \begin{code} + data PprStyle = PprUser PrintUnqualified Depth -- Pretty-print in a way that will make sense to the @@ -99,33 +100,64 @@ data Depth = AllTheWay | 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) -alwaysQualify,neverQualify :: PrintUnqualified -alwaysQualify m n = False -neverQualify m n = True +alwaysQualifyNames :: QualifyName +alwaysQualifyNames m n = Just (moduleName m) + +neverQualifyNames :: QualifyName +neverQualifyNames m n = Nothing + +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 @@ -152,22 +184,26 @@ withPprStyleDoc :: PprStyle -> SDoc -> Doc 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 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