#include "HsVersions.h"
module PprCore (
- pprCoreExpr,
+ pprCoreExpr, pprIfaceUnfolding,
pprCoreBinding,
pprBigCoreBinder,
pprTypedCoreBinder
-- these are here to make the instances go in 0.26:
-#if __GLASGOW_HASKELL__ <= 26
+#if __GLASGOW_HASKELL__ <= 30
, GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
, GenCoreCaseDefault, GenCoreArg
#endif
) where
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
import CoreSyn
import CostCentre ( showCostCentre )
import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
- nullIdEnv, DataCon(..), GenId{-instances-}
+ nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
-import Name ( isSymLexeme )
+import Name ( OccName, parenInCode )
import Outputable -- quite a few things
import PprEnv
-import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
-import PprStyle ( PprStyle(..) )
+import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
+import PprStyle ( PprStyle(..), ifaceStyle )
import Pretty
import PrimOp ( PrimOp{-instances-} )
import TyVar ( GenTyVar{-instances-} )
pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
pprGenCoreBinding
- :: (Eq tyvar, Outputable tyvar,
+ :: (Eq tyvar, Outputable tyvar,
Eq uvar, Outputable uvar,
Outputable bndr,
Outputable occ)
-> Pretty
pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
- = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
+ = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
-init_ppr_env sty pbdr1 pbdr2 pocc
+init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
= initPprEnv sty
(Just (ppr sty)) -- literals
- (Just (ppr sty)) -- data cons
- (Just (ppr sty)) -- primops
+ (Just ppr_con) -- data cons
+ (Just ppr_prim) -- primops
(Just (\ cc -> ppStr (showCostCentre sty True cc)))
- (Just (ppr sty)) -- tyvars
- (Just (ppr sty)) -- usage vars
+ (Just tvbndr) -- tyvar binders
+ (Just (ppr sty)) -- tyvar occs
+ (Just (ppr sty)) -- usage vars
(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
- (Just (ppr sty)) -- types
- (Just (ppr sty)) -- usages
+ (Just (pprParendGenType sty)) -- types
+ (Just (ppr sty)) -- usages
+ where
+ -- ppr_con is used when printing Con expressions; we add a "!"
+ -- to distinguish them from ordinary applications. But not when
+ -- printing for interfaces, where they are treated as ordinary applications
+ ppr_con con | ifaceStyle sty = ppr sty con
+ | otherwise = ppr sty con `ppBeside` ppChar '!'
+
+ -- We add a "!" to distinguish Primitive applications from ordinary applications.
+ -- But not when printing for interfaces, where they are treated
+ -- as ordinary applications
+ ppr_prim prim | ifaceStyle sty = ppr sty prim
+ | otherwise = ppr sty prim `ppBeside` ppChar '!'
--------------
pprCoreBinding sty (NonRec binder expr)
pprCoreExpr = pprGenCoreExpr
pprGenCoreExpr, pprParendCoreExpr
- :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+ :: (Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar,
Outputable bndr,
Outputable occ)
=> PprStyle
-> Pretty
pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
- = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
+ = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
= let
in
parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
+-- Printer for unfoldings in interfaces
+pprIfaceUnfolding :: CoreExpr -> Pretty
+pprIfaceUnfolding = ppr_expr env
+ where
+ env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
+ (pprTypedCoreBinder PprInterface)
+ (pprTypedCoreBinder PprInterface)
+ (ppr PprInterface)
+
ppr_core_arg sty pocc arg
- = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
+ = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
ppr_core_alts sty pbdr1 pbdr2 pocc alts
- = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
+ = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
ppr_core_default sty pbdr1 pbdr2 pocc deflt
- = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
+ = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
\end{code}
%************************************************************************
4 (ppr_expr pe expr)
ppr_bind pe (Rec binds)
- = ppAboves [ ppStr "{- Rec -}",
- ppAboves (map ppr_pair binds),
- ppStr "{- end Rec -}" ]
+ = ppAboves (map ppr_pair binds)
where
ppr_pair (val_bdr, expr)
= ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
\end{code}
\begin{code}
ppr_expr pe (Con con []) = pCon pe con
ppr_expr pe (Con con args)
- = ppHang (ppBesides [pCon pe con, ppChar '!'])
+ = ppHang (pCon pe con)
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
- = ppHang (ppBesides [pPrim pe prim, ppChar '!'])
+ = ppHang (pPrim pe prim)
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
= let
(uvars, tyvars, vars, 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])
+ ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars,
+ pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
+ pp_vars SLIT("\\") (pMinBndr 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 _ _)
+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)
- ])
+ ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args))
ppr_expr pe (Case expr alts)
+ | only_one_alt alts
+ -- johan thinks that single case patterns should be on same line as case,
+ -- and no indent; all sane persons agree with him.
+ = let
+ ppr_alt (AlgAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+ ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
+ ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
+ ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
+ = ppCat [pCon pe con,
+ ppInterleave ppSP (map (pMinBndr pe) params),
+ ppStr "->"]
+
+ ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr
+ ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr
+ ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr
+ ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
+ in
+ ppSep
+ [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
+ ppBeside (ppr_rhs alts) (ppStr ";}")]
+
+ | otherwise -- default "case" printing
= ppSep
- [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
+ [ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts),
ppStr "}"]
+ where
+ pp_keyword = case alts of
+ AlgAlts _ _ -> ppPStr SLIT("case")
+ PrimAlts _ _ -> ppPStr SLIT("case#")
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
-- general case (recursive case, too)
ppr_expr pe (Let bind expr)
- = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
+ = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind),
ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
+ where
+ keyword = case bind of
+ Rec _ -> "letrec {"
+ NonRec _ _ -> "let {"
ppr_expr pe (SCC cc expr)
= ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
ppr_parend_expr pe expr ]
+
+ppr_expr pe (Coerce c ty expr)
+ = ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
+ where
+ pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v)
+
+only_one_alt (AlgAlts [] (BindDefault _ _)) = True
+only_one_alt (AlgAlts (_:[]) NoDefault) = True
+only_one_alt (PrimAlts [] (BindDefault _ _)) = True
+only_one_alt (PrimAlts (_:[]) NoDefault) = True
+only_one_alt _ = False
\end{code}
\begin{code}
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]
else
- ppCat [ppr_con con (pCon pe con),
+ ppCat [pCon pe con,
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
- 4 (ppr_expr pe expr)
- where
- ppr_con con pp_con
- = if isSymLexeme con then ppParens pp_con else pp_con
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
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)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
\end{code}
\begin{code}
ppr_default pe (BindDefault val_bdr expr)
= ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
- 4 (ppr_expr pe expr)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
\end{code}
\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 (TyArg ty) = ppStr "_@_ " `ppBeside` pTy pe ty
ppr_arg pe (UsageArg use) = pUse pe use
\end{code}
= ppAboves [sig, pragmas, ppr sty binder]
where
sig = ifnotPprShowAll sty (
- ppHang (ppCat [ppr sty binder, ppStr "::"])
+ ppHang (ppCat [ppr sty binder, ppDcolon])
4 (ppr sty (idType binder)))
-
pragmas =
ifnotPprForUser sty
- (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
- (getIdInfo binder))
+ (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
pprBabyCoreBinder sty binder
= ppCat [ppr sty binder, pp_strictness]
-- ppStr ("{- " ++ (showList xx "") ++ " -}")
pprTypedCoreBinder sty binder
- = ppBesides [ppLparen, ppCat [ppr sty binder,
- ppStr "::", ppr sty (idType binder)],
- ppRparen]
+ = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
+
+ppDcolon = ppStr " :: "
+ -- The space before the :: is important; it helps the lexer
+ -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
\end{code}
projects / ghc-hetmet.git / blobdiff