X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=2bf1b9cc4a4a35d8f1bd989b5391b245c8d0fa37;hb=9259deb86455a17c05ea7ba982f7d400ac69e3f6;hp=cf99e12bcf1b8f95084038c8cece8645fee64e33;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index cf99e12..2bf1b9c 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -1,22 +1,29 @@ % +% (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, + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..), + getPprStyle, withPprStyle, withPprStyleDoc, + pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, unqualStyle, + ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, SDoc, -- Abstract @@ -25,7 +32,7 @@ module Outputable ( 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, @@ -35,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, @@ -51,7 +58,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 +69,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 +82,7 @@ import Char ( ord ) %************************************************************************ \begin{code} + data PprStyle = PprUser PrintUnqualified Depth -- Pretty-print in a way that will make sense to the @@ -99,33 +107,74 @@ 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 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. +type QueryQualifyModule = Module -> Bool + +type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) + +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m n = NameQual (moduleName m) -alwaysQualify,neverQualify :: PrintUnqualified -alwaysQualify m n = False -neverQualify m n = True +neverQualifyNames :: QueryQualifyName +neverQualifyNames m n = NameUnqual + +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules m = True + +neverQualifyModules :: QueryQualifyModule +neverQualifyModules m = False + +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 +201,39 @@ 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 + +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 -> QueryQualifyName +qualName (PprUser (qual_name,_) _) m n = qual_name m n +qualName other m n = NameQual (moduleName m) + +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser (_,qual_mod) _) m = qual_mod m +qualModule other m = True codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True @@ -208,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 "" @@ -275,6 +344,8 @@ brackets d sty = Pretty.brackets (d sty) 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'. @@ -357,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) =