-pprStgExpr sty (StgLet bind expr)
- = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
- ppHang (ppStr "} in ") 2 (ppr sty expr)]
-
-pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
- = ppSep [ppHang (ppStr "let-no-escape {")
- 2 (pprStgBinding sty bind),
- ppHang (ppBeside (ppStr "} in ")
- (ifPprDebug sty (
- ppNest 4 (
- ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
- ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
- ppStr "]"]))))
- 2 (ppr sty expr)]
-\end{code}
-
-\begin{code}
-pprStgExpr sty (StgSCC ty cc expr)
- = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
- pprStgExpr sty expr ]
-\end{code}
-
-\begin{code}
-pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
- = ppSep [ppSep [ppStr "case",
- ppNest 4 (ppCat [pprStgExpr sty expr,
- ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
- ppStr "of {"],
- ifPprDebug sty (
- ppNest 4 (
- ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
- ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
- ppStr "]; uniq: ", pprUnique uniq])),
- ppNest 2 (ppr_alts sty alts),
- ppStr "}"]
- where
- ppr_default sty StgNoDefault = ppNil
- ppr_default sty (StgBindDefault bndr used expr)
- = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
- where
- pp_binder = if used then ppr sty bndr else ppChar '_'
-
- pp_ty (StgAlgAlts ty _ _) = ppr sty ty
- pp_ty (StgPrimAlts ty _ _) = ppr sty ty
-
- ppr_alts sty (StgAlgAlts ty alts deflt)
- = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
- ppr_default sty deflt ]
- where
- ppr_bxd_alt sty (con, params, use_mask, expr)
- = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"])
- 4 (ppBeside (ppr sty expr) ppSemi)
-
- ppr_alts sty (StgPrimAlts ty alts deflt)
- = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
- ppr_default sty deflt ]
- where
- ppr_ubxd_alt sty (lit, expr)
- = ppHang (ppCat [ppr sty lit, ppStr "->"])
- 4 (ppBeside (ppr sty expr) ppSemi)
+pprStgExpr (StgLet bind expr)
+ = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
+ hang (ptext SLIT("} in ")) 2 (ppr expr)]
+
+pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
+ = sep [hang (ptext SLIT("let-no-escape {"))
+ 2 (pprGenStgBinding bind),
+ hang ((<>) (ptext SLIT("} in "))
+ (ifPprDebug (
+ nest 4 (
+ hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+ ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+ char ']']))))
+ 2 (ppr expr)]
+
+pprStgExpr (StgSCC cc expr)
+ = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
+ pprStgExpr expr ]
+
+pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
+ = sep [sep [ptext SLIT("case"),
+ nest 4 (hsep [pprStgExpr expr,
+ ifPprDebug (dcolon <+> ppr alt_type)]),
+ ptext SLIT("of"), ppr bndr, char '{'],
+ ifPprDebug (
+ nest 4 (
+ hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+ ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+ ptext SLIT("]; "),
+ pprMaybeSRT srt])),
+ nest 2 (vcat (map pprStgAlt alts)),
+ char '}']
+
+pprStgAlt (con, params, use_mask, expr)
+ = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
+ 4 (ppr expr <> semi)
+
+pprStgOp (StgPrimOp op) = ppr op
+pprStgOp (StgFCallOp op _) = ppr op
+
+instance Outputable AltType where
+ ppr PolyAlt = ptext SLIT("Polymorphic")
+ ppr (UbxTupAlt tc) = ptext SLIT("UbxTup") <+> ppr tc
+ ppr (AlgAlt tc) = ptext SLIT("Alg") <+> ppr tc
+ ppr (PrimAlt tc) = ptext SLIT("Prim") <+> ppr tc