X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=ebf8416b2961a40f37be373da80b13a8d8d37e08;hb=f9cde00b2e1a078e433af81bf9021a96cc613976;hp=8380c76fdec4f2085ca5e7722375d9e7c4343a58;hpb=f53056962c6d5d465001560a5b2afd8edf67517b;p=ghc-hetmet.git

diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 8380c76..ebf8416 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -42,7 +42,9 @@ module Outputable (
 	pprCode, mkCodeStyle,
 	showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
 	showSDocUnqual, showsPrecSDoc,
-	pprHsChar, pprHsString,
+
+	pprInfixVar, pprPrefixVar,
+	pprHsChar, pprHsString, pprHsInfix, pprHsVar,
 
 	-- error handling
 	pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, 
@@ -50,17 +52,15 @@ module Outputable (
 	trace, pgmError, panic, panicFastInt, assertPanic
     ) where
 
-#include "HsVersions.h"
-
-
 import {-# SOURCE #-} 	Module( Module, ModuleName, moduleName )
 import {-# SOURCE #-} 	OccName( OccName )
 
-import StaticFlags	( opt_PprStyle_Debug, opt_PprUserLength )
-import FastString
+import StaticFlags
+import FastString 
 import FastTypes
 import qualified Pretty
 import Pretty		( Doc, Mode(..) )
+import Char		( isAlpha )
 import Panic
 
 import Data.Word	( Word32 )
@@ -314,7 +314,7 @@ showSDocForUser :: PrintUnqualified -> SDoc -> String
 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 
 showSDocUnqual :: SDoc -> String
--- Only used in the gruesome HsExpr.isOperator
+-- Only used in the gruesome isOperator
 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
@@ -382,8 +382,8 @@ comma _sty  = Pretty.comma
 colon _sty  = Pretty.colon
 equals _sty = Pretty.equals
 space _sty  = Pretty.space
-dcolon _sty = Pretty.ptext SLIT("::")
-arrow  _sty = Pretty.ptext SLIT("->")
+dcolon _sty = Pretty.ptext (sLit "::")
+arrow  _sty = Pretty.ptext (sLit "->")
 underscore  = char '_'
 dot	    = char '.'
 lparen _sty = Pretty.lparen
@@ -439,8 +439,8 @@ class Outputable a where
 
 \begin{code}
 instance Outputable Bool where
-    ppr True  = ptext SLIT("True")
-    ppr False = ptext SLIT("False")
+    ppr True  = ptext (sLit "True")
+    ppr False = ptext (sLit "False")
 
 instance Outputable Int where
    ppr n = int n
@@ -458,12 +458,12 @@ 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 = ptext SLIT("Nothing")
-  ppr (Just x) = ptext SLIT("Just") <+> ppr x
+  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
+  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
@@ -525,15 +525,48 @@ class Outputable a => OutputableBndr a where
 %************************************************************************
 
 \begin{code}
--- We have 31-bit Chars and will simply use Show instances
--- of Char and String.
-
+-- We have 31-bit Chars and will simply use Show instances of Char and String.
 pprHsChar :: Char -> SDoc
 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
             | otherwise      = text (show c)
 
 pprHsString :: FastString -> SDoc
 pprHsString fs = text (show (unpackFS fs))
+
+---------------------
+-- Put a name in parens if it's an operator
+pprPrefixVar :: Bool -> SDoc -> SDoc
+pprPrefixVar is_operator pp_v
+  | is_operator = parens pp_v
+  | otherwise	= pp_v
+
+-- Put a name in backquotes if it's not an operator
+pprInfixVar :: Bool -> SDoc -> SDoc
+pprInfixVar is_operator pp_v 
+  | is_operator = pp_v
+  | otherwise   = char '`' <> pp_v <> char '`'
+
+---------------------
+-- pprHsVar and pprHsInfix use the gruesome isOperator, which
+-- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
+-- Reason: it means that pprHsVar doesn't need a NamedThing context,
+--         which none of the HsSyn printing functions do
+pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
+pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v  
+	     where pp_v = ppr v
+pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
+	     where pp_v = ppr v
+
+isOperator :: SDoc -> Bool
+isOperator ppr_v 
+  = case showSDocUnqual ppr_v of
+        ('(':_)   -> False              -- (), (,) etc
+        ('[':_)   -> False              -- []
+        ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
+        (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
+        ('_':_)   -> False              -- Not an operator
+        (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
+        _         -> False
 \end{code}
 
 
@@ -570,12 +603,12 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 
 \begin{code}
 speakNth :: Int -> SDoc
-speakNth 1 = ptext SLIT("first")
-speakNth 2 = ptext SLIT("second")
-speakNth 3 = ptext SLIT("third")
-speakNth 4 = ptext SLIT("fourth")
-speakNth 5 = ptext SLIT("fifth")
-speakNth 6 = ptext SLIT("sixth")
+speakNth 1 = ptext (sLit "first")
+speakNth 2 = ptext (sLit "second")
+speakNth 3 = ptext (sLit "third")
+speakNth 4 = ptext (sLit "fourth")
+speakNth 5 = ptext (sLit "fifth")
+speakNth 6 = ptext (sLit "sixth")
 speakNth n = hcat [ int n, text suffix ]
   where
     suffix | n <= 20       = "th"	-- 11,12,13 are non-std
@@ -587,24 +620,24 @@ speakNth n = hcat [ int n, text suffix ]
     last_dig = n `rem` 10
 
 speakN :: Int -> SDoc
-speakN 0 = ptext SLIT("none")	-- E.g.  "he has none"
-speakN 1 = ptext SLIT("one")	-- E.g.  "he has one"
-speakN 2 = ptext SLIT("two")
-speakN 3 = ptext SLIT("three")
-speakN 4 = ptext SLIT("four")
-speakN 5 = ptext SLIT("five")
-speakN 6 = ptext SLIT("six")
+speakN 0 = ptext (sLit "none")	-- E.g.  "he has none"
+speakN 1 = ptext (sLit "one")	-- E.g.  "he has one"
+speakN 2 = ptext (sLit "two")
+speakN 3 = ptext (sLit "three")
+speakN 4 = ptext (sLit "four")
+speakN 5 = ptext (sLit "five")
+speakN 6 = ptext (sLit "six")
 speakN n = int n
 
 speakNOf :: Int -> SDoc -> SDoc
-speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'	-- E.g. "no arguments"
-speakNOf 1 d = ptext SLIT("one") <+> d			-- E.g. "one argument"
+speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'	-- E.g. "no arguments"
+speakNOf 1 d = ptext (sLit "one") <+> d			-- E.g. "one argument"
 speakNOf n d = speakN n <+> d <> char 's'		-- E.g. "three arguments"
 
 speakNTimes :: Int {- >=1 -} -> SDoc
-speakNTimes t | t == 1 	   = ptext SLIT("once")
-              | t == 2 	   = ptext SLIT("twice")
-              | otherwise  = speakN t <+> ptext SLIT("times")
+speakNTimes t | t == 1 	   = ptext (sLit "once")
+              | t == 2 	   = ptext (sLit "twice")
+              | otherwise  = speakN t <+> ptext (sLit "times")
 
 plural :: [a] -> SDoc
 plural [_] = empty  -- a bit frightening, but there you are
@@ -625,7 +658,9 @@ pprPanic    = pprAndThen panic		-- Throw an exn saying "bug in GHC"
 
 pprPgmError = pprAndThen pgmError	-- Throw an exn saying "bug in pgm being compiled"
 					--	(used for unusual pgm errors)
-pprTrace    = pprAndThen trace
+pprTrace str doc x
+   | opt_NoDebugOutput = x
+   | otherwise         = pprAndThen trace str doc x
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
@@ -647,6 +682,7 @@ assertPprPanic file line msg
 		    msg]
 
 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
+warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
   = trace (show (doc PprDebug)) x