%
-% (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
-
- -- these are here to make the instances go in 0.26:
-#if __GLASGOW_HASKELL__ <= 26
- , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
- , GenCoreCaseDefault, GenCoreArg
-#endif
+ pprCoreExpr, pprIfaceUnfolding,
+ pprCoreBinding, pprCoreBindings, pprIdBndr
) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
import CoreSyn
-import CostCentre ( showCostCentre )
-import Id ( idType, getIdInfo, getIdStrictness,
- nullIdEnv, DataCon(..), GenId{-instances-}
- )
-import IdInfo ( ppIdInfo, StrictnessInfo(..) )
-import Literal ( Literal{-instances-} )
-import Name ( isOpLexeme )
-import Outputable -- quite a few things
+import Id ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
+import Var ( isTyVar )
+import IdInfo ( ppIdInfo )
+import Const ( Con(..), DataCon )
+import DataCon ( isTupleCon, isUnboxedTupleCon )
+import PprType ( pprParendType, pprTyVarBndr )
import PprEnv
-import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
-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-} )
+import Outputable
\end{code}
%************************************************************************
usually be called through some intermediary.
The binder/occ printers take the default ``homogenized'' (see
-@PprEnv@...) @Pretty@ and the binder/occ. They can either use the
+@PprEnv@...) @Doc@ 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.
+Un-annotated core dumps
+~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
-
-pprGenCoreBinding
- :: (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
-
-pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
- = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
-
-init_ppr_env sty pbdr1 pbdr2 pocc
- = initPprEnv sty
- (Just (ppr sty)) -- literals
- (Just (ppr sty)) -- data cons
- (Just (ppr sty)) -- primops
- (Just (\ cc -> ppStr (showCostCentre sty True cc)))
- (Just (ppr sty)) -- tyvars
- (Just (ppr sty)) -- usage vars
- (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
- (Just (ppr sty)) -- types
- (Just (ppr sty)) -- usages
-
---------------
-pprCoreBinding sty (NonRec binder expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
- 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
-
-pprCoreBinding 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)
+pprCoreBindings :: [CoreBind] -> SDoc
+pprCoreBinding :: CoreBind -> SDoc
+pprCoreExpr :: CoreExpr -> SDoc
+
+pprCoreBindings = pprTopBinds pprCoreEnv
+pprCoreBinding = pprTopBind pprCoreEnv
+pprCoreExpr = ppr_expr pprCoreEnv
+
+pprCoreEnv = initCoreEnv pprCoreBinder
\end{code}
+Printer for unfoldings in interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-pprCoreExpr
- :: PprStyle
- -> (Id -> Pretty) -- to print "major" val_bdrs
- -> (Id -> Pretty) -- to print "minor" val_bdrs
- -> (Id -> Pretty) -- to print bindees
- -> CoreExpr
- -> Pretty
-pprCoreExpr = pprGenCoreExpr
-
-pprGenCoreExpr, 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
-
-pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
- = ppr_expr (init_ppr_env sty 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 (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
+pprIfaceUnfolding :: CoreExpr -> SDoc
+pprIfaceUnfolding = ppr_expr pprIfaceEnv
-ppr_core_arg sty pocc arg
- = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
+pprIfaceEnv = initCoreEnv pprIfaceBinder
+\end{code}
+
+\begin{code}
+instance Outputable b => Outputable (Bind b) where
+ ppr bind = ppr_bind pprGenericEnv bind
-ppr_core_alts sty pbdr1 pbdr2 pocc alts
- = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
+instance Outputable b => Outputable (Expr b) where
+ ppr expr = ppr_expr pprGenericEnv expr
-ppr_core_default sty pbdr1 pbdr2 pocc deflt
- = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
+pprGenericEnv :: Outputable b => PprEnv b
+pprGenericEnv = initCoreEnv (\site -> ppr)
\end{code}
%************************************************************************
%* *
%************************************************************************
+
\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 = pprGenCoreBinding 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 = pprGenCoreExpr 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
+initCoreEnv pbdr
+ = initPprEnv
+ (Just ppr) -- Constants
+ (Just ppr) -- Cost centres
+
+ (Just ppr) -- tyvar occs
+ (Just pprParendType) -- types
+
+ (Just pbdr) (Just pprIdBndr) -- value vars
+ -- The pprIdBndr part here is a temporary debugging aid
+ -- Revert to ppr if it gets tiresome
\end{code}
%************************************************************************
%* *
-\subsection{Workhorse routines (...????...)}
+\subsection{The guts}
%* *
%************************************************************************
\begin{code}
-ppr_bind pe (NonRec val_bdr expr)
- = ppHang (ppCat [pMajBndr 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 [pMajBndr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr)
+pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
+
+pprTopBind pe (NonRec binder expr)
+ = sep [ppr_binding_pe pe (binder,expr)] $$ text ""
+
+pprTopBind pe (Rec binds)
+ = vcat [ptext SLIT("Rec {"),
+ vcat (map (ppr_binding_pe pe) binds),
+ ptext SLIT("end Rec }"),
+ text ""]
+\end{code}
+
+\begin{code}
+ppr_bind :: PprEnv b -> Bind b -> SDoc
+
+ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
+ppr_bind pe (Rec binds) = vcat (map pp binds)
+ where
+ pp bind = ppr_binding_pe pe bind <> semi
+
+ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
+ppr_binding_pe pe (val_bdr, expr)
+ = sep [pBndr pe LetBind val_bdr,
+ nest 2 (equals <+> ppr_expr pe 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)
+ | no_parens = ppr_expr pe expr
+ | otherwise = parens (ppr_expr pe expr)
+ where
+ no_parens = case expr of
+ Var _ -> True
+ Con con [] -> True
+ Con (DataCon dc) _ -> isTupleCon dc
+ _ -> False
\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 :: PprEnv b -> Expr b -> SDoc
-ppr_expr pe (Con con args)
- = ppHang (ppBesides [pCon pe con, ppChar '!'])
- 4 (ppSep (map (ppr_arg pe) args))
+ppr_expr pe (Type ty) = ptext SLIT("TYPE") <+> ppr ty -- Wierd
+
+ppr_expr pe (Var name) = pOcc pe name
+
+ppr_expr pe (Con con [])
+ = ppr con -- Nullary constructors too
+
+ppr_expr pe (Con (DataCon dc) args)
+ -- Drop the type arguments and print in (a,b,c) notation
+ | isTupleCon dc
+ = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
+ | isUnboxedTupleCon dc
+ = text "(# " <>
+ hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
+ text " #)"
-ppr_expr pe (Prim prim args)
- = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
- 4 (ppSep (map (ppr_arg pe) args))
+ppr_expr pe (Con con args)
+ = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
ppr_expr pe 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("\\") (pMinBndr pe) vars])
+ hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
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 _ _)
+ppr_expr pe expr@(App fun arg)
= let
- (fun, uargs, targs, vargs) = collectArgs expr
+ (final_fun, final_args) = go fun [arg]
+ go (App fun arg) args_so_far = go fun (arg:args_so_far)
+ go fun args_so_far = (fun, args_so_far)
in
- ppHang (ppr_parend_expr pe fun)
- 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
- , ppInterleave ppNil (map (pTy pe) targs)
- , ppInterleave ppNil (map (ppr_arg pe) vargs)
- ])
-
-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 "}"]
+ hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
+
+ppr_expr pe (Case expr var [(con,args,rhs)])
+ = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
+ hsep [ptext SLIT("of"),
+ ppr_bndr var,
+ char '{',
+ ppr_case_pat pe con args
+ ]],
+ ppr_expr pe rhs,
+ char '}'
+ ]
+ where
+ ppr_bndr = pBndr pe CaseBind
+
+ppr_expr pe (Case expr var alts)
+ = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
+ ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
+ nest 4 (sep (punctuate semi (map ppr_alt alts))),
+ char '}'
+ ]
+ where
+ ppr_bndr = pBndr pe CaseBind
+
+ ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
+ 4 (ppr_expr pe rhs)
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
- = ppAboves [
- ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals],
- ppNest 2 (ppr_expr pe rhs),
- ppStr "} in",
+ = vcat [
+ hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
+ nest 2 (ppr_expr pe rhs),
+ ptext SLIT("} in"),
ppr_expr pe body ]
ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
- = ppAbove
- (ppHang (ppStr "let {")
- 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
+ = hang (ptext SLIT("let {"))
+ 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
4 (ppr_expr pe rhs),
- ppStr "} in"]))
- (ppr_expr pe expr)
+ ptext SLIT("} in")])
+ $$
+ ppr_expr pe 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 pe (SCC cc expr)
- = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
- ppr_parend_expr pe expr ]
-\end{code}
-
-\begin{code}
-ppr_alts pe (AlgAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
+ hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
where
- ppr_alt (con, params, expr)
- = ppHang (ppCat [ppr_con con (pCon pe con),
- ppInterleave ppSP (map (pMinBndr 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 ]
+ keyword = case bind of
+ Rec _ -> SLIT("__letrec {")
+ NonRec _ _ -> SLIT("let {")
+
+ppr_expr pe (Note (SCC cc) expr)
+ = sep [hsep [ptext SLIT("__scc"), pSCC pe cc],
+ ppr_parend_expr pe expr ]
+
+#ifdef DEBUG
+ppr_expr pe (Note (Coerce to_ty from_ty) expr)
+ = \ sty ->
+ if debugStyle sty && not (ifaceStyle sty) then
+ sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty, pTy pe from_ty],
+ ppr_parend_expr pe expr] sty
+ else
+ sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
+ ppr_parend_expr pe expr] sty
+#else
+ppr_expr pe (Note (Coerce to_ty from_ty) expr)
+ = sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
+ ppr_parend_expr pe expr]
+#endif
+
+ppr_expr pe (Note InlineCall expr)
+ = ptext SLIT("__inline") <+> ppr_parend_expr pe expr
+
+ppr_case_pat pe con@(DataCon dc) args
+ | isTupleCon dc
+ = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
+ | isUnboxedTupleCon dc
+ = hsep [text "(# " <>
+ hsep (punctuate comma (map ppr_bndr args)) <>
+ text " #)",
+ arrow]
where
- ppr_alt (lit, expr)
- = ppHang (ppCat [pLit pe lit, ppStr "->"])
- 4 (ppr_expr pe expr)
-\end{code}
+ ppr_bndr = pBndr pe CaseBind
-\begin{code}
-ppr_default pe NoDefault = ppNil
+ppr_case_pat pe con args
+ = pCon pe con <+> hsep (map ppr_bndr args) <+> arrow
+ where
+ ppr_bndr = pBndr pe CaseBind
-ppr_default pe (BindDefault val_bdr expr)
- = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
- 4 (ppr_expr pe expr)
-\end{code}
+ppr_arg pe (Type ty) = ptext SLIT("__a") <+> pTy pe ty
+ppr_arg pe expr = ppr_parend_expr pe expr
-\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
+arrow = ptext SLIT("->")
\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]
- where
- sig = ifnotPprShowAll sty (
- ppHang (ppCat [ppr sty binder, ppStr "::"])
- 4 (ppr sty (idType binder)))
-
- pragmas =
- ifnotPprForUser sty
- (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
- (getIdInfo binder))
-
-pprBabyCoreBinder sty binder
- = ppCat [ppr sty binder, pp_strictness]
+-- Used for printing dump info
+pprCoreBinder LetBind binder
+ = vcat [sig, pragmas, ppr binder]
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]
+ sig = pprTypedBinder binder
+ pragmas = ppIdInfo (idInfo binder)
+
+-- Lambda bound type variables are preceded by "__a"
+pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
+
+-- Case bound things don't get a signature or a herald
+pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
+
+-- Used for printing interface-file unfoldings
+pprIfaceBinder CaseBind binder = pprUntypedBinder binder
+pprIfaceBinder other binder = pprTypedBinder binder
+
+pprUntypedBinder binder
+ | isTyVar binder = pprTyVarBndr binder
+ | otherwise = pprIdBndr binder
+
+pprTypedBinder binder
+ | isTyVar binder = ptext SLIT("__a") <+> pprTyVarBndr binder
+ | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
+ -- The space before the :: is important; it helps the lexer
+ -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
+ --
+ -- It's important that the type is parenthesised too, at least when
+ -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
+
+-- When printing any Id binder in debug mode, we print its inline pragma
+pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id))
\end{code}
projects / ghc-hetmet.git / blobdiff