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 Id ( idType, getIdInfo, getIdStrictness, isTupleCon,
+ nullIdEnv, SYN_IE(DataCon), GenId{-instances-}
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
-import Name ( isOpLexeme )
+import Name ( isSymLexeme )
import Outputable -- quite a few things
import PprEnv
-import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
+import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
import PprStyle ( PprStyle(..) )
import Pretty
import PrimOp ( PrimOp{-instances-} )
(Just (ppr sty)) -- tyvars
(Just (ppr sty)) -- usage vars
(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
- (Just (ppr sty)) -- types
+ (Just (pprParendGenType sty)) -- types
(Just (ppr sty)) -- usages
--------------
])
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 [ppr_alt_con con (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 [ppPStr SLIT("case"), ppNest 4 (ppr_parend_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 {"],
ppNest 2 (ppr_alts pe alts),
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 [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
+ pTy pe ty, ppr_parend_expr pe expr ]
+ where
+ pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = ppBeside (ppStr "{-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
+
+ppr_alt_con con pp_con
+ = if isSymLexeme con then ppParens pp_con else pp_con
\end{code}
\begin{code}
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (con, params, expr)
- = ppHang (ppCat [ppr_con con (pCon pe con),
- ppInterleave ppSP (map (pMinBndr pe) params),
- ppStr "->"])
+ = ppHang (if isTupleCon con then
+ ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
+ ppStr "->"]
+ else
+ ppCat [ppr_alt_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 ]
pragmas =
ifnotPprForUser sty
- (ppIdInfo sty binder True{-specs, please-} id nullIdEnv
+ (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
(getIdInfo binder))
pprBabyCoreBinder sty binder