-- Class NamedThing and overloaded friends
NamedThing(..),
- getSrcLoc, getSrcSpan, getOccString
+ getSrcLoc, getSrcSpan, getOccString,
+ pprInfixName, pprPrefixName
) where
import {-# SOURCE #-} TypeRep( TyThing )
getSrcLoc = nameSrcLoc . getName
getSrcSpan = nameSrcSpan . getName
getOccString = occNameString . getOccName
+
+pprInfixName, pprPrefixName :: (Outputable a, NamedThing a) => a -> SDoc
+-- See Outputable.pprPrefixVar, pprInfixVar;
+-- add parens or back-quotes as appropriate
+pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n)
+pprPrefixName n = pprPrefixVar (isSymOcc (getOccName n)) (ppr n)
\end{code}
import HsBinds
import HsPat
-import HsImpExp
import HsTypes
import HsDoc
import NameSet
pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where
- ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsVar con, ppr t2]
+ ppr_details con (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
ppr_details con (PrefixCon tys) = hsep (pprHsVar con : map ppr tys)
ppr_details con (RecCon fields) = ppr con <+> ppr_fields fields
import HsPat
import HsLit
import HsTypes
-import HsImpExp
import HsBinds
-- others:
= hang (ppr op) 2 (sep [pp_e1, pp_e2])
pp_infixly v
- = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
+ = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2]
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
4 (hsep [pp_expr, ptext (sLit "x_ )")])
- pp_infixly v = (sep [pp_expr, pprInfix v])
+ pp_infixly v = (sep [pp_expr, pprHsInfix v])
ppr_expr (SectionR op expr)
= case unLoc op of
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
4 ((<>) pp_expr rparen)
pp_infixly v
- = (sep [pprInfix v, pp_expr])
+ = (sep [pprHsInfix v, pp_expr])
--avoid using PatternSignatures for stage1 code portability
ppr_expr exprType@(HsLam matches)
= hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
- = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]]
+ = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
instance OutputableBndr id => Outputable (HsCmdTop id) where
ppr = pprCmdArg
--- Put a var in backquotes if it's not an operator already
-pprInfix :: Outputable name => name -> SDoc
-pprInfix v | isOperator ppr_v = ppr_v
- | otherwise = char '`' <> ppr_v <> char '`'
- where ppr_v = ppr v
-
-- add parallel array brackets around a document
--
pa_brackets :: SDoc -> SDoc
import Outputable
import FastString
import SrcLoc ( Located(..) )
-import Char ( isAlpha )
\end{code}
%************************************************************************
ppr (IEDocNamed string) = text ("<IEDocNamed: " ++ string ++ ">")
\end{code}
-\begin{code}
-pprHsVar :: Outputable name => name -> SDoc
-pprHsVar v | isOperator ppr_v = parens ppr_v
- | otherwise = ppr_v
- where
- ppr_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
- -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so
- -- that we don't need NamedThing in the context of all these functions.
- -- Gruesome, but simple.
-\end{code}
pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
pprTyConHdr _ tyCon
| Just (_fam_tc, tys) <- tyConFamInst_maybe tyCon
- = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
+ = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp tyCon tys
| otherwise
= ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
where
ppr_fields [ty1, ty2]
| GHC.dataConIsInfix dataCon && null labels
- = sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2]
+ = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
ppr_fields fields
| null labels
= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
famInstNotFound :: TyCon -> [Type] -> TcM a
famInstNotFound tycon tys
= failWithTc (ptext (sLit "No family instance for")
- <+> quotes (pprTypeApp tycon (ppr tycon) tys))
+ <+> quotes (pprTypeApp tycon tys))
\end{code}
pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
= pprTyConSort <+> pprHead
where
- pprHead = pprTypeApp fam (ppr fam) tys
+ pprHead = pprTypeApp fam tys
pprTyConSort | isDataTyCon tycon = ptext (sLit "data instance")
| isNewTyCon tycon = ptext (sLit "newtype instance")
| isSynTyCon tycon = ptext (sLit "type instance")
pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
-pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc
--- The first arg is the tycon; it's used to arrange printing infix
--- if it looks like an operator
--- Second arg is the pretty-printed tycon
-pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_tc tys
+pprTypeApp :: NamedThing a => a -> [Type] -> SDoc
+-- The first arg is the tycon, or sometimes class
+-- Print infix if the tycon/class looks like an operator
+pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
------------------
pprPred :: PredType -> SDoc
pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2]
pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr_type_app TopPrec (getName clas) (ppr clas) tys
+pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
- = ppr_type_app p (getName tc) (ppr_naked_tc tc) tys
+ = ppr_type_app p (getName tc) tys
-ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc
-ppr_type_app p tc pp_tc tys
+ppr_type_app :: Prec -> Name -> [Type] -> SDoc
+-- Used for classes as well as types; that's why it's separate from ppr_tc_app
+ppr_type_app p tc tys
| is_sym_occ -- Print infix if possible
, [ty1,ty2] <- tys -- We know nothing of precedence though
= maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
- pp_tc <+> ppr_type FunPrec ty2])
+ pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2])
| otherwise
- = maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys)))
+ = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc))
+ 2 (sep (map pprParendType tys)))
where
is_sym_occ = isSymOcc (getOccName tc)
- paren_tc | is_sym_occ = parens pp_tc
- | otherwise = pp_tc
-ppr_tc :: TyCon -> SDoc
-ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc)
-
-ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc
-ppr_naked_tc tc
+ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc
+ppr_tc tc
= pp_nt_debug <> ppr tc
where
pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
pprCode, mkCodeStyle,
showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
showSDocUnqual, showsPrecSDoc,
- pprHsChar, pprHsString,
+
+ pprInfixVar, pprPrefixVar,
+ pprHsChar, pprHsString, pprHsInfix, pprHsVar,
-- error handling
pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
import {-# SOURCE #-} OccName( OccName )
import StaticFlags
-import FastString
+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
%************************************************************************
\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}
projects / ghc-hetmet.git / commitdiff