%
-% (c) The AQUA Project, Glasgow University, 1996
+% (c) The AQUA Project, Glasgow University, 1996-1998
%
%************************************************************************
%* *
%************************************************************************
\begin{code}
-#include "HsVersions.h"
-
module PprCore (
- pprCoreExpr,
- pprCoreBinding,
- pprBigCoreBinder,
- pprTypedCoreBinder,
- pprPlainCoreBinding
-
- -- these are here to make the instances go in 0.26:
-#if __GLASGOW_HASKELL__ <= 26
- , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
- , GenCoreCaseDefault, GenCoreArg
-#endif
+ pprCoreExpr, pprParendExpr,
+ pprCoreBinding, pprCoreBindings, pprCoreAlt,
+ pprIdRules
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
import CoreSyn
-import CostCentre ( showCostCentre )
-import Id ( idType, getIdInfo, getIdStrictness,
- nullIdEnv, DataCon(..), GenId{-instances-}
+import CostCentre ( pprCostCentreCore )
+import Var ( Var )
+import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
+ idInfo, idInlinePragma, idOccInfo,
+ globalIdDetails, isGlobalId, isExportedId,
+ isSpecPragmaId, idNewDemandInfo
)
-import IdInfo ( ppIdInfo, StrictnessInfo(..) )
-import Literal ( Literal{-instances-} )
-import Outputable -- quite a few things
-import PprType ( pprType_Internal,
- GenType{-instances-}, GenTyVar{-instance-}
+import Var ( TyVar, isTyVar, tyVarKind )
+import IdInfo ( IdInfo, megaSeqIdInfo,
+ arityInfo, ppArityInfo,
+ specInfo, pprNewStrictness,
+ workerInfo, ppWorkerInfo,
+ newStrictnessInfo, cafInfo, ppCafInfo,
)
-import PprStyle ( PprStyle(..) )
-import Pretty
-import PrimOp ( PrimOp{-instances-} )
-import TyVar ( GenTyVar{-instances-} )
-import Unique ( Unique{-instances-} )
-import Usage ( GenUsage{-instances-} )
-import Util ( panic{-ToDo:rm-} )
+
+#ifdef OLD_STRICTNESS
+import Id ( idDemandInfo )
+import IdInfo ( cprInfo, ppCprInfo, strictnessInfo, ppStrictnessInfo )
+#endif
+
+import DataCon ( dataConTyCon )
+import TyCon ( tupleTyConBoxity, isTupleTyCon )
+import Type ( pprParendType, pprType, pprParendKind )
+import BasicTypes ( tupleParens )
+import Util ( lengthIs )
+import Outputable
+import FastString ( mkFastString )
\end{code}
%************************************************************************
%* *
%************************************************************************
-@pprCoreBinding@ and @pprCoreExpr@ let you give special printing
-function for ``major'' val_bdrs (those next to equal signs :-),
-``minor'' ones (lambda-bound, case-bound), and bindees. They would
-usually be called through some intermediary.
-
-The binder/occ printers take the default ``homogenized'' (see
-@PrintEnv@...) @Pretty@ and the binder/occ. They can either use the
-homogenized one, or they can ignore it completely. In other words,
-the things passed in act as ``hooks'', getting the last word on how to
-print something.
-
@pprParendCoreExpr@ puts parens around non-atomic Core expressions.
\begin{code}
-pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
-
-pprCoreBinding
- :: (Eq tyvar, Outputable tyvar,
- Eq uvar, Outputable uvar,
- Outputable bndr,
- Outputable occ)
- => PprStyle
- -> (bndr -> Pretty) -- to print "major" val_bdrs
- -> (bndr -> Pretty) -- to print "minor" val_bdrs
- -> (occ -> Pretty) -- to print bindees
- -> GenCoreBinding bndr occ tyvar uvar
- -> Pretty
-
-pprCoreBinding sty pbdr1 pbdr2 pocc bind
- = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
-
-pprPlainCoreBinding sty (NonRec binder expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
- 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
-
-pprPlainCoreBinding sty (Rec binds)
- = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"),
- ppAboves (map ppr_bind binds),
- ifPprDebug sty (ppStr "{- end plain Rec -}")]
- where
- ppr_bind (binder, expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
- 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
-\end{code}
+pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc
+pprCoreBinding :: OutputableBndr b => Bind b -> SDoc
+pprCoreExpr :: OutputableBndr b => Expr b -> SDoc
+pprParendExpr :: OutputableBndr b => Expr b -> SDoc
-\begin{code}
-pprCoreExpr, pprParendCoreExpr
- :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
- Outputable bndr,
- Outputable occ)
- => PprStyle
- -> (bndr -> Pretty) -- to print "major" val_bdrs
- -> (bndr -> Pretty) -- to print "minor" val_bdrs
- -> (occ -> Pretty) -- to print bindees
- -> GenCoreExpr bndr occ tyvar uvar
- -> Pretty
-
-pprCoreExpr sty pbdr1 pbdr2 pocc expr
- = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
-
-pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
- = let
- parenify
- = case expr of
- Var _ -> id -- leave unchanged
- Lit _ -> id
- _ -> ppParens -- wraps in parens
- in
- parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
+pprCoreBindings = pprTopBinds
+pprCoreBinding = pprTopBind
-ppr_core_arg sty pocc arg
- = ppr_arg (initial_pe sty (Left (pocc, pocc, pocc))) arg
+instance OutputableBndr b => Outputable (Bind b) where
+ ppr bind = ppr_bind bind
-ppr_core_alts sty pbdr1 pbdr2 pocc alts
- = ppr_alts (initial_pe sty (Left (pbdr1, pbdr2, pocc))) alts
-
-ppr_core_default sty pbdr1 pbdr2 pocc deflt
- = ppr_default (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
+instance OutputableBndr b => Outputable (Expr b) where
+ ppr expr = pprCoreExpr expr
\end{code}
-%************************************************************************
-%* *
-\subsection{Instance declarations for Core printing}
-%* *
-%************************************************************************
-
-\begin{code}
-instance
- (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
- Eq uvar, Outputable uvar)
- =>
- Outputable (GenCoreBinding bndr occ tyvar uvar) where
- ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
-
-instance
- (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
- Eq uvar, Outputable uvar)
- =>
- Outputable (GenCoreExpr bndr occ tyvar uvar) where
- ppr sty expr = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
-
-instance
- (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- =>
- Outputable (GenCoreArg occ tyvar uvar) where
- ppr sty arg = ppr_core_arg sty (ppr sty) arg
-
-instance
- (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
- Eq uvar, Outputable uvar)
- =>
- Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where
- ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts
-
-instance
- (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar,
- Eq uvar, Outputable uvar)
- =>
- Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where
- ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
-\end{code}
%************************************************************************
%* *
-\subsection{Core printing environment (purely local)}
+\subsection{The guts}
%* *
%************************************************************************
-Similar to @VE@ in @PprType@. The ``values'' we print here
-are locally-defined nested-scope names; callers to @pprCoreBinding@,
-etc., can override these.
-
-For tyvars and uvars, we {\em do} normally use these homogenized
-names; for values, we {\em don't}. In printing interfaces, though,
-we use homogenized value names, so that interfaces don't wobble
-uncontrollably from changing Unique-based names.
-
\begin{code}
-data PrintEnv tyvar uvar bndr occ
- = PE (Literal -> Pretty) -- Doing these this way saves
- (DataCon -> Pretty) -- carrying around a PprStyle
- (PrimOp -> Pretty)
- (CostCentre -> Pretty)
-
- [Pretty] -- Tyvar pretty names
- (tyvar -> Pretty) -- Tyvar lookup function
- [Pretty] -- Uvar pretty names
- (uvar -> Pretty) -- Uvar lookup function
-
- (GenType tyvar uvar -> Pretty)
- (GenUsage uvar -> Pretty)
-
- (ValPrinters bndr occ)
-
-data ValPrinters bndr occ
- = BOPE -- print binders/occs differently
- (bndr -> Pretty) -- to print "major" val_bdrs
- (bndr -> Pretty) -- to print "minor" val_bdrs
- (occ -> Pretty) -- to print bindees
-
- | VPE -- print all values the same way
- [Pretty] -- Value pretty names
- (bndr -> Pretty) -- Binder lookup function
- (occ -> Pretty) -- Occurrence lookup function
-\end{code}
+pprTopBinds binds = vcat (map pprTopBind binds)
-\begin{code}
-initial_pe :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
- Outputable bndr, Outputable occ)
- => PprStyle
- -> Either
- (bndr -> Pretty, bndr -> Pretty, occ -> Pretty)
- ()
- -> PrintEnv tyvar uvar bndr occ
-
-initial_pe sty val_printing
- = PE (ppr sty) -- for a Literal
- (ppr sty) -- for a DataCon
- (ppr sty) -- for a PrimOp
- (\ cc -> ppStr (showCostCentre sty True cc)) -- CostCentre
-
- tv_pretties ppr_tv -- for a TyVar
- uv_pretties ppr_uv -- for a UsageVar
-
- (\ ty -> pprType_Internal sty tv_pretties ppr_tv uv_pretties ppr_uv ty)
- (ppr sty) -- for a Usage
-
- val_printing_stuff
- where
- ppr_tv = ppr sty -- to print a tyvar
- ppr_uv = ppr sty -- to print a uvar
-
- tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
- ++
- map (\ n -> ppBeside (ppChar 'a') (ppInt n))
- ([0 .. ] :: [Int]) -- a0 ... aN
-
- uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
- ++
- map (\ n -> ppBeside (ppChar 'u') (ppInt n))
- ([0 .. ] :: [Int]) -- u0 ... uN
-
- val_pretties = map (\ c -> ppChar c ) ['i' .. 'k']
- ++ map (\ n -> ppBeside (ppChar 'v') (ppInt n))
- ([0 .. ] :: [Int]) -- v0 ... vN
-
- ------------------------
- val_printing_stuff
- = case val_printing of
- Left (pbdr1, pbdr2, pocc) -> BOPE pbdr1 pbdr2 pocc
- Right () -> VPE val_pretties (ppr sty) (ppr sty)
+pprTopBind (NonRec binder expr)
+ = ppr_binding (binder,expr) $$ text ""
+pprTopBind (Rec binds)
+ = vcat [ptext SLIT("Rec {"),
+ vcat (map ppr_binding binds),
+ ptext SLIT("end Rec }"),
+ text ""]
\end{code}
\begin{code}
-plit (PE pp _ _ _ _ _ _ _ _ _ _) = pp
-pcon (PE _ pp _ _ _ _ _ _ _ _ _) = pp
-pprim (PE _ _ pp _ _ _ _ _ _ _ _) = pp
-pscc (PE _ _ _ pp _ _ _ _ _ _ _) = pp
-ptyvar (PE _ _ _ _ _ pp _ _ _ _ _) = pp
-puvar (PE _ _ _ _ _ _ _ pp _ _ _) = pp
-
-pty (PE _ _ _ _ _ _ _ _ pp _ _) = pp
-puse (PE _ _ _ _ _ _ _ _ _ pp _) = pp
-
-pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE pp _ _)) = pp
-pmaj_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
-
-pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ pp _)) = pp
-pmin_bdr (PE _ _ _ _ _ _ _ _ _ _ (VPE _ pp _)) = pp
-
-pocc (PE _ _ _ _ _ _ _ _ _ _ (BOPE _ _ pp)) = pp
-pocc (PE _ _ _ _ _ _ _ _ _ _ (VPE _ _ pp)) = pp
-\end{code}
+ppr_bind :: OutputableBndr b => Bind b -> SDoc
-%************************************************************************
-%* *
-\subsection{Workhorse routines (...????...)}
-%* *
-%************************************************************************
+ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr)
+ppr_bind (Rec binds) = vcat (map pp binds)
+ where
+ pp bind = ppr_binding bind <> semi
-\begin{code}
-ppr_bind pe (NonRec val_bdr expr)
- = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr)
-
-ppr_bind pe (Rec binds)
- = ppAboves [ ppStr "{- Rec -}",
- ppAboves (map ppr_pair binds),
- ppStr "{- end Rec -}" ]
- where
- ppr_pair (val_bdr, expr)
- = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr)
+ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc
+ppr_binding (val_bdr, expr)
+ = pprBndr LetBind val_bdr $$
+ (ppr val_bdr <+> equals <+> pprCoreExpr expr)
\end{code}
\begin{code}
-ppr_parend_expr pe expr
- = let
- parenify
- = case expr of
- Var _ -> id -- leave unchanged
- Lit _ -> id
- _ -> ppParens -- wraps in parens
- in
- parenify (ppr_expr pe expr)
+pprParendExpr expr = ppr_expr parens expr
+pprCoreExpr expr = ppr_expr noParens expr
+
+noParens :: SDoc -> SDoc
+noParens pp = pp
\end{code}
\begin{code}
-ppr_expr pe (Var name) = pocc pe name
-ppr_expr pe (Lit lit) = plit pe lit
-ppr_expr pe (Con con []) = pcon pe con
-
-ppr_expr pe (Con con args)
- = ppHang (ppBesides [pcon pe con, ppChar '!'])
- 4 (ppSep (map (ppr_arg pe) args))
+ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
+ -- The function adds parens in context that need
+ -- an atomic value (e.g. function args)
-ppr_expr pe (Prim prim args)
- = ppHang (ppBesides [pprim pe prim, ppChar '!'])
- 4 (ppSep (map (ppr_arg pe) args))
+ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd
+
+ppr_expr add_par (Var name) = ppr name
+ppr_expr add_par (Lit lit) = ppr lit
-ppr_expr pe expr@(Lam _ _)
+ppr_expr add_par expr@(Lam _ _)
= let
- (uvars, tyvars, vars, body) = collectBinders expr
+ (bndrs, body) = collectBinders expr
in
- ppHang (ppCat [pp_vars SLIT("_/u\\_") (puvar pe) uvars,
- pp_vars SLIT("_/\\_") (ptyvar pe) tyvars,
- pp_vars SLIT("\\") (pmin_bdr pe) vars])
- 4 (ppr_expr pe body)
- where
- pp_vars lam pp [] = ppNil
- pp_vars lam pp vs
- = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
-
-ppr_expr pe expr@(App _ _)
- = let
- (fun, args) = collectArgs expr
+ add_par $
+ hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
+ 2 (pprCoreExpr body)
+
+ppr_expr add_par expr@(App fun arg)
+ = case collectArgs expr of { (fun, args) ->
+ let
+ pp_args = sep (map pprArg args)
+ val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
+ pp_tup_args = sep (punctuate comma (map pprArg val_args))
in
- ppHang (ppr_parend_expr pe fun)
- 4 (ppSep (map (ppr_arg pe) args))
-
-ppr_expr pe (Case expr alts)
- = ppSep
- [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
- ppNest 2 (ppr_alts pe alts),
- ppStr "}"]
+ case fun of
+ Var f -> case isDataConWorkId_maybe f of
+ -- Notice that we print the *worker*
+ -- for tuples in paren'd format.
+ Just dc | saturated && isTupleTyCon tc
+ -> tupleParens (tupleTyConBoxity tc) pp_tup_args
+ where
+ tc = dataConTyCon dc
+ saturated = val_args `lengthIs` idArity f
+
+ other -> add_par (hang (ppr f) 2 pp_args)
+
+ other -> add_par (hang (pprParendExpr fun) 2 pp_args)
+ }
+
+ppr_expr add_par (Case expr var ty [(con,args,rhs)])
+ = add_par $
+ sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
+ hsep [ptext SLIT("of"),
+ ppr_bndr var,
+ char '{',
+ ppr_case_pat con args
+ ]],
+ pprCoreExpr rhs,
+ char '}'
+ ]
+ where
+ ppr_bndr = pprBndr CaseBind
+
+ppr_expr add_par (Case expr var ty alts)
+ = add_par $
+ sep [sep [ptext SLIT("case") <+> pprParendType ty <+> pprCoreExpr expr,
+ ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
+ nest 2 (sep (punctuate semi (map pprCoreAlt alts))),
+ char '}'
+ ]
+ where
+ ppr_bndr = pprBndr CaseBind
+
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
-ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
- = ppAboves [
- ppCat [ppStr "let {", pmaj_bdr pe val_bdr, ppEquals],
- ppNest 2 (ppr_expr pe rhs),
- ppStr "} in",
- ppr_expr pe body ]
-
-ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
- = ppAbove
- (ppHang (ppStr "let {")
- 2 (ppCat [ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
- 4 (ppr_expr pe rhs),
- ppStr "} in"]))
- (ppr_expr pe expr)
+{-
+ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
+ = add_par $
+ vcat [
+ hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],
+ nest 2 (pprCoreExpr rhs),
+ ptext SLIT("} in"),
+ pprCoreExpr body ]
+-}
+
+ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
+ = add_par
+ (hang (ptext SLIT("let {"))
+ 2 (hsep [ppr_binding (val_bdr,rhs),
+ ptext SLIT("} in")])
+ $$
+ pprCoreExpr expr)
-- general case (recursive case, too)
-ppr_expr pe (Let bind expr)
- = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
- ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
+ppr_expr add_par (Let bind expr)
+ = add_par $
+ sep [hang (ptext keyword) 2 (ppr_bind bind),
+ hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)]
+ where
+ keyword = case bind of
+ Rec _ -> SLIT("__letrec {")
+ NonRec _ _ -> SLIT("let {")
+
+ppr_expr add_par (Note (SCC cc) expr)
+ = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr])
+
+#ifdef DEBUG
+ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
+ = add_par $
+ getPprStyle $ \ sty ->
+ if debugStyle sty then
+ sep [ptext SLIT("__coerce") <+>
+ sep [pprParendType to_ty, pprParendType from_ty],
+ pprParendExpr expr]
+ else
+ sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty],
+ pprParendExpr expr]
+#else
+ppr_expr add_par (Note (Coerce to_ty from_ty) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__coerce"), nest 2 (pprParendType to_ty)],
+ pprParendExpr expr]
+#endif
-ppr_expr pe (SCC cc expr)
- = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
- ppr_parend_expr pe expr ]
-\end{code}
+ppr_expr add_par (Note InlineCall expr)
+ = add_par (ptext SLIT("__inline_call") <+> pprParendExpr expr)
-\begin{code}
-ppr_alts pe (AlgAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
- where
- ppr_alt (con, params, expr)
- = ppHang (ppCat [ppr_con con (pcon pe con),
- ppInterleave ppSP (map (pmin_bdr pe) params),
- ppStr "->"])
- 4 (ppr_expr pe expr)
- where
- ppr_con con pp_con
- = if isOpLexeme con then ppParens pp_con else pp_con
-
-ppr_alts pe (PrimAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
- where
- ppr_alt (lit, expr)
- = ppHang (ppCat [plit pe lit, ppStr "->"])
- 4 (ppr_expr pe expr)
-\end{code}
+ppr_expr add_par (Note InlineMe expr)
+ = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr
-\begin{code}
-ppr_default pe NoDefault = ppNil
+ppr_expr add_par (Note (CoreNote s) expr)
+ = add_par $
+ sep [sep [ptext SLIT("__core_note"), pprHsString (mkFastString s)],
+ pprParendExpr expr]
-ppr_default pe (BindDefault val_bdr expr)
- = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
- 4 (ppr_expr pe expr)
-\end{code}
+pprCoreAlt (con, args, rhs)
+ = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
-\begin{code}
-ppr_arg pe (LitArg lit) = plit pe lit
-ppr_arg pe (VarArg v) = pocc pe v
-ppr_arg pe (TyArg ty) = pty pe ty
-ppr_arg pe (UsageArg use) = puse pe use
+ppr_case_pat con@(DataAlt dc) args
+ | isTupleTyCon tc
+ = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
+ where
+ ppr_bndr = pprBndr CaseBind
+ tc = dataConTyCon dc
+
+ppr_case_pat con args
+ = ppr con <+> hsep (map ppr_bndr args) <+> arrow
+ where
+ ppr_bndr = pprBndr CaseBind
+
+pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty
+pprArg expr = pprParendExpr expr
\end{code}
Other printing bits-and-bobs used with the general @pprCoreBinding@
and @pprCoreExpr@ functions.
\begin{code}
-pprBigCoreBinder sty binder
- = ppAboves [sig, pragmas, ppr sty binder]
+instance OutputableBndr Var where
+ pprBndr = pprCoreBinder
+
+pprCoreBinder :: BindingSite -> Var -> SDoc
+pprCoreBinder LetBind binder
+ = vcat [sig, pprIdDetails binder, pragmas]
where
- sig = ifnotPprShowAll sty (
- ppHang (ppCat [ppr sty binder, ppStr "::"])
- 4 (ppr sty (idType binder)))
+ sig = pprTypedBinder binder
+ pragmas = ppIdInfo binder (idInfo binder)
+
+-- Lambda bound type variables are preceded by "@"
+pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
+
+-- Case bound things don't get a signature or a herald
+pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
+
+pprUntypedBinder binder
+ | isTyVar binder = ptext SLIT("@") <+> ppr binder -- NB: don't print kind
+ | otherwise = pprIdBndr binder
+
+pprTypedBinder binder
+ | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder
+ | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
+
+pprTyVarBndr :: TyVar -> SDoc
+pprTyVarBndr tyvar
+ = getPprStyle $ \ sty ->
+ if debugStyle sty then
+ hsep [ppr tyvar, dcolon, pprParendKind kind]
+ -- See comments with ppDcolon in PprCore.lhs
+ else
+ ppr tyvar
+ where
+ kind = tyVarKind tyvar
+
+-- pprIdBndr does *not* print the type
+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
+pprIdBndr id = ppr id <+>
+ (megaSeqIdInfo (idInfo id) `seq`
+ -- Useful for poking on black holes
+ ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
+#ifdef OLD_STRICTNESS
+ ppr (idDemandInfo id) <+>
+#endif
+ ppr (idNewDemandInfo id) <+>
+ ppr (idLBVarInfo id)))
+\end{code}
- pragmas =
- ifnotPprForUser sty
- (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
- (getIdInfo binder))
-pprBabyCoreBinder sty binder
- = ppCat [ppr sty binder, pp_strictness]
+\begin{code}
+pprIdDetails :: Id -> SDoc
+pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
+ | isExportedId id = ptext SLIT("[Exported]")
+ | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
+ | otherwise = empty
+
+ppIdInfo :: Id -> IdInfo -> SDoc
+ppIdInfo b info
+ = brackets $
+ vcat [ ppArityInfo a,
+ ppWorkerInfo (workerInfo info),
+ ppCafInfo (cafInfo info),
+#ifdef OLD_STRICTNESS
+ ppStrictnessInfo s,
+ ppCprInfo m,
+#endif
+ pprNewStrictness (newStrictnessInfo info),
+ if null rules then empty
+ else ptext SLIT("RULES:") <+> vcat (map (pprCoreRule (ppr b)) rules)
+ -- Inline pragma, occ, demand, lbvar info
+ -- printed out with all binders (when debug is on);
+ -- see PprCore.pprIdBndr
+ ]
where
- pp_strictness
- = case (getIdStrictness binder) of
- NoStrictnessInfo -> ppNil
- BottomGuaranteed -> ppStr "{- _!_ -}"
- StrictnessInfo xx _ ->
- panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
- -- ppStr ("{- " ++ (showList xx "") ++ " -}")
-
-pprTypedCoreBinder sty binder
- = ppBesides [ppLparen, ppCat [ppr sty binder,
- ppStr "::", ppr sty (idType binder)],
- ppRparen]
+ a = arityInfo info
+#ifdef OLD_STRICTNESS
+ s = strictnessInfo info
+ m = cprInfo info
+#endif
+ rules = rulesRules (specInfo info)
+\end{code}
+
+
+\begin{code}
+pprIdRules :: [IdCoreRule] -> SDoc
+pprIdRules rules = vcat (map pprIdRule rules)
+
+pprIdRule :: IdCoreRule -> SDoc
+pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule
+
+pprCoreRule :: SDoc -> CoreRule -> SDoc
+pprCoreRule pp_fn (BuiltinRule name _)
+ = ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name)
+
+pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
+ = doubleQuotes (ftext name) <+> ppr act <+>
+ sep [
+ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
+ nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
+ nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
+ ] <+> semi
\end{code}
projects / ghc-hetmet.git / blobdiff