summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2012-04-27 16:50:09 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2012-04-27 16:50:09 +0100
commit5826a77a0b5b9886a4a59aeb4f71de24be3eda80 (patch)
tree6dd166bc5554eec7730288b3580ffe5fe952430e /compiler
parent9e3171c632d200ae1b259dd3501fa6f6d9ac3278 (diff)
downloadhaskell-5826a77a0b5b9886a4a59aeb4f71de24be3eda80.tar.gz
Pretty printing and debug improvements
Diffstat (limited to 'compiler')
-rw-r--r--compiler/typecheck/TcEnv.lhs15
-rw-r--r--compiler/typecheck/TcErrors.lhs3
-rw-r--r--compiler/typecheck/TcInteract.lhs1
-rw-r--r--compiler/typecheck/TcPat.lhs3
-rw-r--r--compiler/typecheck/TcSMonad.lhs3
-rw-r--r--compiler/typecheck/TcType.lhs2
-rw-r--r--compiler/types/InstEnv.lhs8
-rw-r--r--compiler/types/Type.lhs2
-rw-r--r--compiler/types/TypeRep.lhs37
9 files changed, 39 insertions, 35 deletions
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 1967976856..2e870da966 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -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"
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 0fcd0d4ea2..63a5beeb24 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -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
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index dde7021b5d..c62c778736 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -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
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 7b759d100e..38ef6bc380 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -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]
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 4a5bd4949f..ca7cf88fd1 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -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
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 74b4e1a066..b45824fbc4 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -152,7 +152,7 @@ module TcType (
tyVarsOfType, tyVarsOfTypes,
tcTyVarsOfType, tcTyVarsOfTypes,
- pprKind, pprParendKind,
+ pprKind, pprParendKind, pprSigmaType,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
pprTheta, pprThetaArrowTy, pprClassPred
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index d2080bf396..e28a3fb53e 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -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
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 1470160dd3..e0de629da6 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -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
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 69637b39ed..605c97fcc4 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -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
View Lorry Controller Status