#include "HsVersions.h"
module PprCore (
- pprCoreExpr,
- pprCoreBinding,
+ pprCoreExpr, pprIfaceUnfolding,
+ pprCoreBinding, pprCoreBindings,
pprBigCoreBinder,
- pprTypedCoreBinder,
- pprPlainCoreBinding
+ 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,
- nullIdEnv, DataCon(..), GenId{-instances-}
- )
-import IdInfo ( ppIdInfo, StrictnessInfo(..) )
+import Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
+ nullIdEnv, SYN_IE(DataCon), GenId{-instances-},
+ SYN_IE(Id)
+ )
+import IdInfo ( ppIdInfo, ppStrictnessInfo )
import Literal ( Literal{-instances-} )
+import Name ( OccName )
import Outputable -- quite a few things
-import PprType ( pprType_Internal,
- GenType{-instances-}, GenTyVar{-instance-}
- )
-import PprStyle ( PprStyle(..) )
+import PprEnv
+import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
import Pretty
import PrimOp ( PrimOp{-instances-} )
import TyVar ( GenTyVar{-instances-} )
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
+@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.
\begin{code}
-pprPlainCoreBinding :: PprStyle -> CoreBinding -> Pretty
+pprCoreBinding :: PprStyle -> CoreBinding -> Doc
+pprCoreBindings :: PprStyle -> [CoreBinding] -> Doc
-pprCoreBinding
- :: (Eq tyvar, Outputable tyvar,
+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
+ -> (bndr -> Doc) -- to print "major" val_bdrs
+ -> (bndr -> Doc) -- to print "minor" val_bdrs
+ -> (occ -> Doc) -- to print bindees
-> GenCoreBinding bndr occ tyvar uvar
- -> Pretty
+ -> Doc
+
+pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
+ = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
+
+init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
+ = initPprEnv sty
+ (Just (ppr sty)) -- literals
+ (Just ppr_con) -- data cons
+ (Just ppr_prim) -- primops
+ (Just (\ cc -> text (showCostCentre sty True cc)))
+ (Just tvbndr) -- tyvar binders
+ (Just (ppr sty)) -- tyvar occs
+ (Just (ppr sty)) -- usage vars
+ (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
+ (Just (pprParendGenType sty)) -- types
+ (Just (ppr sty)) -- usages
+ where
+
+ ppr_con con = ppr sty con
+
+{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.]
+ [We can't treat them as ordinary applications because the Con doesn't have
+ dictionaries in it, whereas the constructor Id does.]
+
+ OLD VERSION:
+ -- 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 <> char '!'
+-}
-pprCoreBinding sty pbdr1 pbdr2 pocc bind
- = ppr_bind (initial_pe sty (Left (pbdr1, pbdr2, pocc))) bind
+ -- 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 <> char '!'
-pprPlainCoreBinding sty (NonRec binder expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+--------------
+pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds)
+
+pprCoreBinding sty (NonRec binder expr)
+ = hang (hsep [pprBigCoreBinder sty binder, equals])
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 -}")]
+pprCoreBinding sty (Rec binds)
+ = vcat [ptext SLIT("Rec {"),
+ vcat (map ppr_bind binds),
+ ptext SLIT("end Rec }")]
where
ppr_bind (binder, expr)
- = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals])
+ = hang (hsep [pprBigCoreBinder sty binder, equals])
4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr)
\end{code}
\begin{code}
-pprCoreExpr, pprParendCoreExpr
- :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+pprCoreExpr
+ :: PprStyle
+ -> (Id -> Doc) -- to print "major" val_bdrs
+ -> (Id -> Doc) -- to print "minor" val_bdrs
+ -> (Id -> Doc) -- to print bindees
+ -> CoreExpr
+ -> Doc
+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
+ -> (bndr -> Doc) -- to print "major" val_bdrs
+ -> (bndr -> Doc) -- to print "minor" val_bdrs
+ -> (occ -> Doc) -- to print bindees
-> GenCoreExpr bndr occ tyvar uvar
- -> Pretty
+ -> Doc
-pprCoreExpr sty pbdr1 pbdr2 pocc expr
- = ppr_expr (initial_pe sty (Left (pbdr1, pbdr2, pocc))) expr
+pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
+ = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
= let
= case expr of
Var _ -> id -- leave unchanged
Lit _ -> id
- _ -> ppParens -- wraps in parens
+ _ -> parens -- wraps in parens
in
- parenify (pprCoreExpr sty pbdr1 pbdr2 pocc expr)
+ parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
+
+-- Printer for unfoldings in interfaces
+pprIfaceUnfolding :: CoreExpr -> Doc
+pprIfaceUnfolding = ppr_expr env
+ where
+ env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
+ (pprTypedCoreBinder PprInterface)
+ (ppr PprInterface)
+ (ppr PprInterface)
ppr_core_arg sty pocc arg
- = ppr_arg (initial_pe sty (Left (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 (initial_pe sty (Left (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 (initial_pe sty (Left (pbdr1, pbdr2, pocc))) deflt
+ = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
\end{code}
%************************************************************************
Eq uvar, Outputable uvar)
=>
Outputable (GenCoreBinding bndr occ tyvar uvar) where
- ppr sty bind = pprCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind
+ ppr sty bind = pprQuote sty $ \sty ->
+ 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 = pprCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr
+ ppr sty expr = pprQuote sty $ \sty ->
+ 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
+ ppr sty arg = pprQuote sty $ \sty ->
+ 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
+ ppr sty alts = pprQuote sty $ \sty ->
+ 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)}
-%* *
-%************************************************************************
-
-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}
-
-\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)
-
-\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
+ ppr sty deflt = pprQuote sty $ \sty ->
+ ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt
\end{code}
%************************************************************************
\begin{code}
ppr_bind pe (NonRec val_bdr expr)
- = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
+ = hang (hsep [pMajBndr pe val_bdr, equals])
4 (ppr_expr pe expr)
ppr_bind pe (Rec binds)
- = ppAboves [ ppStr "{- Rec -}",
- ppAboves (map ppr_pair binds),
- ppStr "{- end Rec -}" ]
+ = vcat (map ppr_pair binds)
where
ppr_pair (val_bdr, expr)
- = ppHang (ppCat [pmaj_bdr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr)
+ = hang (hsep [pMajBndr pe val_bdr, equals])
+ 4 (ppr_expr pe expr <> semi)
\end{code}
\begin{code}
= case expr of
Var _ -> id -- leave unchanged
Lit _ -> id
- _ -> ppParens -- wraps in parens
+ _ -> parens -- wraps in parens
in
parenify (ppr_expr pe expr)
\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 (Var name) = pOcc pe name
+ppr_expr pe (Lit lit) = pLit pe lit
ppr_expr pe (Con con args)
- = ppHang (ppBesides [pcon pe con, ppChar '!'])
- 4 (ppSep (map (ppr_arg pe) args))
+ = hang (pCon pe con)
+ 4 (braces $ sep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
- = ppHang (ppBesides [pprim pe prim, ppChar '!'])
- 4 (ppSep (map (ppr_arg pe) args))
+ = hang (pPrim pe prim)
+ 4 (sep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
= let
- (uvars, tyvars, vars, body) = digForLambdas expr
+ (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("\\") (pmin_bdr pe) vars])
+ hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars,
+ pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
+ pp_vars SLIT("\\") (pMajndr pe) vars])
4 (ppr_expr pe body)
where
- pp_vars lam pp [] = ppNil
+ pp_vars lam pp [] = empty
pp_vars lam pp vs
- = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
+ = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")]
-ppr_expr pe expr@(App _ _)
+ppr_expr pe expr@(App fun arg)
= let
- (fun, args) = 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 (map (ppr_arg pe) args))
+ hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_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 "}"]
+ | 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 _)) = (<>) (pMinBndr pe n) ppr_arrow
+ ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow
+ ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow
+ ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
+ = hsep [pCon pe con,
+ hsep (map (pMinBndr pe) params),
+ ppr_arrow]
+
+ 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
+
+
+ ppr_arrow = ptext SLIT(" ->")
+ in
+ sep
+ [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts],
+ (<>) (ppr_rhs alts) (text ";}")]
+
+ | otherwise -- default "case" printing
+ = sep
+ [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")],
+ nest 2 (ppr_alts pe alts),
+ text "}"]
+ where
+ pp_keyword = case alts of
+ AlgAlts _ _ -> ptext SLIT("case")
+ PrimAlts _ _ -> ptext SLIT("case#")
-- 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",
+ = vcat [
+ hsep [ptext SLIT("let {"), pMajBndr pe 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 [pmaj_bdr pe val_bdr, ppEquals])
+ = ($$)
+ (hang (ptext SLIT("let {"))
+ 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals])
4 (ppr_expr pe rhs),
- ppStr "} in"]))
+ 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)]
+ = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
+ hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
+ where
+ keyword = case bind of
+ Rec _ -> SLIT("_letrec_ {")
+ NonRec _ _ -> SLIT("let {")
ppr_expr pe (SCC cc expr)
- = ppSep [ppCat [ppPStr SLIT("_scc_"), pscc pe cc],
+ = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
ppr_parend_expr pe expr ]
+
+ppr_expr pe (Coerce c ty expr)
+ = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
+ where
+ pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_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}
ppr_alts pe (AlgAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
where
+ ppr_arrow = ptext SLIT("->")
+
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
+ = hang (if isTupleCon con then
+ hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))),
+ ppr_arrow]
+ else
+ hsep [pCon pe con,
+ hsep (map (pMinBndr pe) params),
+ ppr_arrow]
+ )
+ 4 (ppr_expr pe expr <> semi)
ppr_alts pe (PrimAlts alts deflt)
- = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
+ = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (lit, expr)
- = ppHang (ppCat [plit pe lit, ppStr "->"])
- 4 (ppr_expr pe expr)
+ = hang (hsep [pLit pe lit, ptext SLIT("->")])
+ 4 (ppr_expr pe expr <> semi)
\end{code}
\begin{code}
-ppr_default pe NoDefault = ppNil
+ppr_default pe NoDefault = empty
ppr_default pe (BindDefault val_bdr expr)
- = ppHang (ppCat [pmin_bdr pe val_bdr, ppStr "->"])
- 4 (ppr_expr pe expr)
+ = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")])
+ 4 (ppr_expr pe expr <> semi)
\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 (UsageArg use) = puse pe use
+ppr_arg pe (LitArg lit) = pLit pe lit
+ppr_arg pe (VarArg v) = pOcc pe v
+ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty
+ppr_arg pe (UsageArg use) = pUse pe use
\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))
+pprBigCoreBinder sty binder = pprTypedCoreBinder sty binder
pprBabyCoreBinder sty binder
- = ppCat [ppr sty binder, pp_strictness]
+ = hsep [ppr sty binder, pp_strictness]
where
- pp_strictness
- = case (getIdStrictness binder) of
- NoStrictnessInfo -> ppNil
- BottomGuaranteed -> ppStr "{- _!_ -}"
- StrictnessInfo xx _ ->
- panic "PprCore:pp_strictness:StrictnessInfo:ToDo"
- -- ppStr ("{- " ++ (showList xx "") ++ " -}")
+ pp_strictness = ppStrictnessInfo sty (getIdStrictness binder)
pprTypedCoreBinder sty binder
- = ppBesides [ppLparen, ppCat [ppr sty binder,
- ppStr "::", ppr sty (idType binder)],
- ppRparen]
+ = hsep [ppr sty binder, ptext SLIT("::"), pprParendGenType sty (idType binder)]
+ -- 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