pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
showSDocUnqual, showsPrecSDoc,
- pprHsChar, pprHsString,
+
+ pprInfixVar, pprPrefixVar,
+ pprHsChar, pprHsString, pprHsInfix, pprHsVar,
-- error handling
pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
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 )
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
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
\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
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
%************************************************************************
\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}
\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
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
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))
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
projects / ghc-hetmet.git / blobdiff