Commit 5826a77a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Pretty printing and debug improvements

parent 9e3171c6
......@@ -7,7 +7,7 @@ module TcEnv(
TyThing(..), TcTyThing(..), TcId,
-- Instance environment, and InstInfo type
InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
InstInfo(..), iDFunId, pprInstInfoDetails,
simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
......@@ -669,17 +669,10 @@ data InstBindings a
-- See Note [Newtype deriving and unused constructors]
-- in TcDeriv
pprInstInfo :: InstInfo a -> SDoc
pprInstInfo info = hang (ptext (sLit "instance"))
2 (sep [ ifPprDebug (pprForAll tvs)
, pprThetaArrowTy theta, ppr tau
, ptext (sLit "where")])
where
(tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
pprInstInfoDetails info
= hang (pprInstanceHdr (iSpec info) <+> ptext (sLit "where"))
2 (details (iBinds info))
where
details (VanillaInst b _ _) = pprLHsBinds b
details (NewTypeDerived {}) = text "Derived from the representation type"
......
......@@ -85,7 +85,8 @@ reportUnsolved runtimeCoercionErrors wanted
, cec_tidy = tidy_env
, cec_defer = defer }
; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted)
; traceTc "reportUnsolved:" (vcat [ pprTvBndrs (varSetElems free_tvs)
, ppr wanted ])
; reportWanteds err_ctxt wanted
......
......@@ -1463,6 +1463,7 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc dict_id)
; let fd_eqns = improveFromInstEnv instEnvs
(mkClassPred cls xis, pprArisingAt loc)
; traceTcS "improve" (vcat [ppr cls <+> ppr xis, vcat (map pprEquation fd_eqns), ppr (snd instEnvs)])
; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc
; case any_fundeps of
-- No Functional Dependencies
......
......@@ -154,7 +154,8 @@ data TcSigInfo
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
= ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau
= ppr id <+> dcolon <+> vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
, ppr (map fst tyvars) ]
\end{code}
Note [Kind vars in sig_tvs]
......
......@@ -1494,7 +1494,8 @@ matchClass clas tys
([], unifs, _) -- Nothing matches
-> do { traceTcS "matchClass not matching"
(vcat [ text "dict" <+> ppr pred,
text "unifs" <+> ppr unifs ])
text "unifs" <+> ppr unifs,
ppr instEnvs ])
; return MatchInstNo
} ;
([(ispec, inst_tys)], [], _) -- A single match
......
......@@ -152,7 +152,7 @@ module TcType (
tyVarsOfType, tyVarsOfTypes,
tcTyVarsOfType, tcTyVarsOfTypes,
pprKind, pprParendKind,
pprKind, pprParendKind, pprSigmaType,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
pprTheta, pprThetaArrowTy, pprClassPred
......
......@@ -153,12 +153,8 @@ pprInstance ispec
-- * pprInstanceHdr is used in VStudio to populate the ClassView tree
pprInstanceHdr :: ClsInst -> SDoc
-- Prints the ClsInst as an instance declaration
pprInstanceHdr ispec@(ClsInst { is_flag = flag })
= ptext (sLit "instance") <+> ppr flag
<+> sep [pprThetaArrowTy theta, ppr res_ty]
where
dfun = is_dfun ispec
(_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })
= ptext (sLit "instance") <+> ppr flag <+> pprSigmaType (idType dfun)
-- Print without the for-all, which the programmer doesn't write
pprInstances :: [ClsInst] -> SDoc
......
......@@ -135,7 +135,7 @@ module Type (
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing,
pprTvBndr, pprTvBndrs, pprForAll,
pprTvBndr, pprTvBndrs, pprForAll, pprSigmaType,
pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprSourceTyCon,
) where
......
......@@ -38,7 +38,7 @@ module TypeRep (
-- Pretty-printing
pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
pprTyThing, pprTyThingCategory,
pprTyThing, pprTyThingCategory, pprSigmaType,
pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit,
Prec(..), maybeParen, pprTcApp, pprTypeNameApp,
......@@ -564,11 +564,11 @@ ppr_type :: Prec -> Type -> SDoc
ppr_type _ (TyVarTy tv) = ppr_tvar tv
ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys
ppr_type p (LitTy l) = ppr_tylit p l
ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty
ppr_type p fun_ty@(FunTy ty1 ty2)
| isPredTy ty1
= ppr_forall_type p fun_ty
......@@ -580,19 +580,10 @@ ppr_type p fun_ty@(FunTy ty1 ty2)
| not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2
ppr_fun_tail other_ty = [ppr_type TopPrec other_ty]
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
= maybeParen p FunPrec $
sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
split1 tvs ty = (reverse tvs, ty)
split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2
split2 ps ty = (reverse ps, ty)
= maybeParen p FunPrec $ (ppr_sigma_type True ty)
ppr_tvar :: TyVar -> SDoc
ppr_tvar tv -- Note [Infix type variables]
......@@ -605,6 +596,26 @@ ppr_tylit _ tl =
StrTyLit s -> text (show s)
-------------------
ppr_sigma_type :: Bool -> Type -> SDoc
-- Bool <=> Show the foralls
ppr_sigma_type show_foralls ty
= sep [ if show_foralls then pprForAll tvs else empty
, pprThetaArrowTy ctxt
, pprType tau ]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
split1 tvs ty = (reverse tvs, ty)
split2 ps (ty1 `FunTy` ty2) | isPredTy ty1 = split2 (ty1:ps) ty2
split2 ps ty = (reverse ps, ty)
pprSigmaType :: Type -> SDoc
pprSigmaType ty = ppr_sigma_type opt_PprStyle_Debug ty
pprForAll :: [TyVar] -> SDoc
pprForAll [] = empty
pprForAll tvs = ptext (sLit "forall") <+> pprTvBndrs tvs <> dot
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment