diff options
Diffstat (limited to 'compiler/types/TyCoRep.hs')
| -rw-r--r-- | compiler/types/TyCoRep.hs | 61 |
1 files changed, 60 insertions, 1 deletions
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 0fbcc2c0ba..80681e7678 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -66,6 +66,8 @@ module TyCoRep ( pprCo, pprParendCo, + debugPprType, + -- * Free variables tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, tyCoFVsBndr, tyCoFVsOfType, tyCoVarsOfTypeList, @@ -2505,7 +2507,6 @@ instance Outputable TyLit where ppr = pprTyLit ------------------ - pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType @@ -2546,6 +2547,64 @@ instance Outputable TyBinder where instance Outputable Coercion where -- defined here to avoid orphans ppr = pprCo +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty TopPrec ty + +debug_ppr_ty :: TyPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ifPprDebug (parens (ppr tv <+> dcolon + <+> (debugPprType (tyVarKind tv)))) + (ppr tv) + +debug_ppr_ty prec (FunTy arg res) + = maybeParen prec FunPrec $ + sep [debug_ppr_ty FunPrec arg, arrow <+> debug_ppr_ty prec res] + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec TyConPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty TyConPrec) tys)) + +debug_ppr_ty prec (AppTy t1 t2) + = hang (debug_ppr_ty prec t1) + 2 (debug_ppr_ty TyConPrec t2) + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec TopPrec $ + hang (debug_ppr_ty TopPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec FunPrec $ + hang (text "forall" <+> fsep (map pp_bndr tvs) <> dot) + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + + pp_bndr, pp_with_kind :: TyVarBinder -> SDoc + pp_bndr tv = ifPprDebug (ppr tv) (pp_with_kind tv) + + pp_with_kind tv + = parens (ppr tv <+> dcolon + <+> ppr (tyVarKind (binderVar tv))) + {- Note [When to print foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |