Printing of Core syntax
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
import TyCon
import Type
import Coercion
+import StaticFlags
import BasicTypes
import Util
import Outputable
%************************************************************************
\begin{code}
+pprTopBinds :: OutputableBndr a => [Bind a] -> SDoc
pprTopBinds binds = vcat (map pprTopBind binds)
+pprTopBind :: OutputableBndr a => Bind a -> SDoc
pprTopBind (NonRec binder expr)
- = ppr_binding (binder,expr) $$ text ""
+ = ppr_binding (binder,expr) $$ blankLine
-pprTopBind (Rec binds)
+pprTopBind (Rec [])
+ = ptext (sLit "Rec { }")
+pprTopBind (Rec (b:bs))
= vcat [ptext (sLit "Rec {"),
- vcat (map ppr_binding binds),
+ ppr_binding b,
+ vcat [blankLine $$ ppr_binding b | b <- bs],
ptext (sLit "end Rec }"),
- text ""]
+ blankLine]
\end{code}
\begin{code}
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 _ (Var name) = ppr name
+ppr_expr _ (Lit lit) = ppr lit
ppr_expr add_par (Cast expr co)
= add_par $
sep [pprParendExpr expr,
- ptext (sLit "`cast`") <+> parens (pprCo co)]
+ ptext (sLit "`cast`") <+> pprCo co]
where
- pprCo co = sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
+ pprCo co | opt_SuppressCoercions = ptext (sLit "...")
+ | otherwise = parens
+ $ sep [ppr co, dcolon <+> ppr (coercionKindPredTy co)]
ppr_expr add_par expr@(Lam _ _)
hang (ptext (sLit "\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)
2 (pprCoreExpr body)
-ppr_expr add_par expr@(App fun arg)
+ppr_expr add_par expr@(App {})
= case collectArgs expr of { (fun, args) ->
let
pp_args = sep (map pprArg args)
tc = dataConTyCon dc
saturated = val_args `lengthIs` idArity f
- other -> add_par (hang (ppr f) 2 pp_args)
+ _ -> add_par (hang (ppr f) 2 pp_args)
- other -> add_par (hang (pprParendExpr fun) 2 pp_args)
+ _ -> add_par (hang (pprParendExpr fun) 2 pp_args)
}
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)],
pprParendExpr expr]
+pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
pprCoreAlt (con, args, rhs)
= hang (ppr_case_pat con args) 2 (pprCoreExpr rhs)
-ppr_case_pat con@(DataAlt dc) args
+ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc
+ppr_case_pat (DataAlt dc) args
| isTupleTyCon tc
= tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
where
where
ppr_bndr = pprBndr CaseBind
+pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty
pprArg expr = pprParendExpr expr
\end{code}
pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder
- | isTyVar binder = pprTypedBinder binder
+ | isTyVar binder = pprKindedTyVarBndr binder
| otherwise
- = vcat [sig, pprIdDetails binder, pragmas]
+ = vcat [sig, pprIdExtras binder, pragmas]
where
sig = pprTypedBinder binder
pragmas = ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@"
-pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr)
+pprCoreBinder LambdaBind bndr
+ | isDeadBinder bndr
+ = getPprStyle $ \ sty ->
+ if debugStyle sty then
+ parens (pprTypedBinder bndr)
+ else
+ char '_'
+ | otherwise
+ = parens (pprTypedBinder bndr)
-- Case bound things don't get a signature or a herald, unless we have debug on
pprCoreBinder CaseBind bndr
if debugStyle sty then
parens (pprTypedBinder bndr)
else
- pprUntypedBinder bndr
+ if isDeadBinder bndr then char '_'
+ else pprUntypedBinder bndr
+pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder
| isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
| otherwise = pprIdBndr binder
+pprTypedBinder :: Var -> SDoc
+-- Print binder with a type or kind signature (not paren'd)
pprTypedBinder binder
- | isTyVar binder = ptext (sLit "@") <+> pprTyVarBndr binder
+ | isTyVar binder = pprKindedTyVarBndr 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
+pprKindedTyVarBndr :: TyVar -> SDoc
+-- Print a type variable binder with its kind (but not if *)
+pprKindedTyVarBndr tyvar
+ = ptext (sLit "@") <+> ppr tyvar <> opt_kind
where
+ opt_kind -- Print the kind if not *
+ | isLiftedTypeKind kind = empty
+ | otherwise = dcolon <> pprKind kind
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 -> SDoc
pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info
= megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
where
dmd_info = newDemandInfo info
lbv_info = lbvarInfo info
- no_info = isAlwaysActive prag_info && isNoOcc occ_info &&
+ no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info &&
(case dmd_info of { Nothing -> True; Just d -> isTop d }) &&
hasNoLBVarInfo lbv_info
\begin{code}
-pprIdDetails :: Id -> SDoc
-pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
- | isExportedId id = ptext (sLit "[Exported]")
- | otherwise = empty
+pprIdExtras :: Id -> SDoc
+pprIdExtras id = pp_scope <> ppr (idDetails id)
+ where
+ pp_scope | isGlobalId id = ptext (sLit "GblId")
+ | isExportedId id = ptext (sLit "LclIdX")
+ | otherwise = ptext (sLit "LclId")
ppIdInfo :: Id -> IdInfo -> SDoc
-ppIdInfo b info
+ppIdInfo _ info
= brackets $
vcat [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
projects / ghc-hetmet.git / blobdiff