X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=1c989b4bad58cbfb08fee953fdfc32621b88e707;hb=562926d74281d08113893e72edcafaf39b52dafe;hp=5f38e9b896f177da64eaa57dc78b68afee99a2f6;hpb=4b17269854ccf10df8b3ca1711410a5ca439ea8a;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 5f38e9b8..1c989b4 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -14,10 +14,10 @@ Defines classes for pretty-printing and forcing, both forms of module Outputable ( Outputable(..), -- Class - PprStyle, CodeStyle(..), + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, getPprStyle, withPprStyle, pprDeeper, codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, - ifPprDebug, ifNotPprForUser, + ifPprDebug, unqualStyle, SDoc, -- Abstract interppSP, interpp'SP, pprQuotedList, pprWithCommas, @@ -37,7 +37,7 @@ module Outputable ( printSDoc, printErrs, printDump, printForC, printForAsm, printForIface, printForUser, pprCode, pprCols, - showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc, + showSDoc, showSDocDebug, showSDocIface, showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, @@ -49,14 +49,14 @@ module Outputable ( #include "HsVersions.h" +import {-# SOURCE #-} Name( Name ) + import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString import qualified Pretty import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) import Panic -import ST ( runST ) -import Foreign import Char ( chr, ord, isDigit ) \end{code} @@ -69,23 +69,36 @@ import Char ( chr, ord, isDigit ) \begin{code} data PprStyle - = PprUser Depth -- Pretty-print in a way that will - -- make sense to the ordinary user; - -- must be very close to Haskell - -- syntax, etc. - - | PprDebug -- Standard debugging output + = PprUser PrintUnqualified Depth -- Pretty-print in a way that will + -- make sense to the ordinary user; + -- must be very close to Haskell + -- syntax, etc. - | PprInterface -- Interface generation + | PprInterface PrintUnqualified -- Interface generation | PprCode CodeStyle -- Print code; either C or assembler + | PprDebug -- Standard debugging output data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle data Depth = AllTheWay | PartWay Int -- 0 => stop + + +type PrintUnqualified = Name -> Bool + -- This function tells when it's ok to print + -- a (Global) name unqualified + +alwaysQualify,neverQualify :: PrintUnqualified +alwaysQualify n = False +neverQualify n = True + +defaultUserStyle = mkUserStyle alwaysQualify AllTheWay + +mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth \end{code} Orthogonal to the above printing styles are (possibly) some @@ -109,15 +122,20 @@ withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d sty' = d sty pprDeeper :: SDoc -> SDoc -pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +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 getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df sty = df sty sty \end{code} \begin{code} +unqualStyle :: PprStyle -> Name -> Bool +unqualStyle (PprUser unqual _) n = unqual n +unqualStyle (PprInterface unqual) n = unqual n +unqualStyle other n = False + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False @@ -127,22 +145,16 @@ asmStyle (PprCode AsmStyle) = True asmStyle other = False ifaceStyle :: PprStyle -> Bool -ifaceStyle PprInterface = True -ifaceStyle other = False +ifaceStyle (PprInterface _) = True +ifaceStyle other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle other = False userStyle :: PprStyle -> Bool -userStyle (PprUser _) = True -userStyle other = False -\end{code} - -\begin{code} -ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style -ifNotPprForUser d sty@(PprUser _) = Pretty.empty -ifNotPprForUser d sty = d sty +userStyle (PprUser _ _) = True +userStyle other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style ifPprDebug d sty@PprDebug = d sty @@ -155,20 +167,28 @@ printSDoc d sty = printDoc PageMode stdout (d sty) -- I'm not sure whether the direct-IO approach of printDoc -- above is better or worse than the put-big-string approach here -printErrs :: SDoc -> IO () -printErrs doc = printDoc PageMode stderr (final_doc user_style) - where - final_doc = doc -- $$ text "" - user_style = mkUserStyle (PartWay opt_PprUserLength) +printErrs :: PrintUnqualified -> SDoc -> IO () +printErrs unqual doc = printDoc PageMode stderr (doc style) + where + style = mkUserStyle unqual (PartWay opt_PprUserLength) printDump :: SDoc -> IO () -printDump doc = printForUser stdout (doc $$ text "") - -- We used to always print in debug style, but I want - -- to try the effect of a more user-ish style (unless you - -- say -dppr-debug +printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle) + where + better_doc = doc $$ text "" + -- We used to always print in debug style, but I want + -- to try the effect of a more user-ish style (unless you + -- say -dppr-debug -printForUser :: Handle -> SDoc -> IO () -printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay)) +printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () +printForUser handle unqual doc + = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + +-- printForIface prints all on one line for interface files. +-- It's called repeatedly for successive lines +printForIface :: Handle -> PrintUnqualified -> SDoc -> IO () +printForIface handle unqual doc + = printDoc LeftMode handle (doc (PprInterface unqual)) -- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () @@ -177,11 +197,6 @@ printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle)) printForAsm :: Handle -> SDoc -> IO () printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) --- printForIface prints all on one line for interface files. --- It's called repeatedly for successive lines -printForIface :: Handle -> SDoc -> IO () -printForIface handle doc = printDoc LeftMode handle (doc PprInterface) - pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -189,19 +204,20 @@ pprCode cs d = withPprStyle (PprCode cs) d -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = show (d (mkUserStyle AllTheWay)) +showSDoc d = show (d defaultUserStyle) + +showSDocUnqual :: SDoc -> String +-- Only used in the gruesome HsExpr.isOperator +showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) + +showsPrecSDoc :: Int -> SDoc -> ShowS +showsPrecSDoc p d = showsPrec p (d defaultUserStyle) showSDocIface :: SDoc -> String -showSDocIface doc = showDocWith OneLineMode (doc PprInterface) +showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify)) showSDocDebug :: SDoc -> String showSDocDebug d = show (d PprDebug) - -showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay)) - -mkUserStyle depth | opt_PprStyle_Debug = PprDebug - | otherwise = PprUser depth \end{code} \begin{code} @@ -289,6 +305,9 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n +instance Outputable () where + ppr _ = text "()" + instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) @@ -296,8 +315,8 @@ instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) instance Outputable a => Outputable (Maybe a) where - ppr Nothing = text "Nothing" - ppr (Just x) = text "Just" <+> ppr x + ppr Nothing = ptext SLIT("Nothing") + ppr (Just x) = ptext SLIT("Just") <+> ppr x -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where