Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : type-holes-branch
http://hackage.haskell.org/trac/ghc/changeset/11f4ef0496700c133bf32f4165c2892a979df2df >--------------------------------------------------------------- commit 11f4ef0496700c133bf32f4165c2892a979df2df Author: Thijs Alkemade <[email protected]> Date: Wed Jul 18 13:50:53 2012 +0200 Improve the printing of the local environment. >--------------------------------------------------------------- compiler/typecheck/TcErrors.lhs | 65 ++++++++++++++++++++++++++++----------- 1 files changed, 47 insertions(+), 18 deletions(-) diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index ba8c824..abf9d8d 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,5 +1,5 @@ \begin{code} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, Holes #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -45,6 +45,7 @@ import Outputable import DynFlags import Data.List ( partition, mapAccumL ) import UniqFM +import BasicTypes \end{code} %************************************************************************ @@ -158,7 +159,7 @@ reportTidyWanteds ctxt insols flats implics } else do { - ; traceTc "reportTidyWanteds" (ppr $ flats `unionBags` insols) + ; traceTc "reportTidyWanteds" (ppr $ cec_tidy ctxt) ; mapBagM_ (deferToRuntime ev_binds_var ctxt mkHoleDeferredError) holes ; reportInsolsAndFlats ctxt (filterBag (not.isHole) insols) (filterBag (not.isHole) flats) @@ -168,7 +169,6 @@ reportTidyWanteds ctxt insols flats implics where isHole ct = case ct of CHoleCan {} -> True _ -> False - holeTyVars = concatBag $ mapBag (listToBag . varSetElems . tyVarsOfCt) $ holes holes = filterBag isHole (flats `unionBags` insols) @@ -404,35 +404,64 @@ mkIrredErr ctxt cts \begin{code} mkHoleDeferredError :: ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleDeferredError ctxt ct@(CHoleCan { cc_ev = fl, cc_hole_ty = ty }) +mkHoleDeferredError ctxt ct@(CHoleCan {}) = do { let env0 = cec_tidy ctxt ; let vars = tyVarsOfCt ct + ; zonked_vars <- zonkTyVarsAndFV vars - ; (env2, zonked_ty) <- zonkTidyTcType env0 ty - ; let (env3, tyvars) = tidyOpenTyVars env2 $ varSetElems zonked_vars - ; tyvars_msg <- mapM locMsg tyvars - ; let msg = addArising orig $ (text "Found hole" <+> quotes (text "_") <+> text "with type") <+> pprType zonked_ty - $$ (if not $ null tyvars then text "Where:" <+> sep tyvars_msg else empty) - $$ (if not $ isNullUFM lenv then text "In scope:" <+> ppr lenv else empty) + + ; (env1, zonked_ty) <- zonkTidyTcType env0 (cc_hole_ty ct) + + ; let (env2, tyvars) = tidyOpenTyVars env1 (varSetElems zonked_vars) + + ; tyvars_msg <- mapM loc_msg tyvars + + ; (env3, lenv_msg) <- ppr_localenv lenv env2 + + ; traceTc "mkHoleDeferredError" (ppr env3) + + ; let msg = (text "Found hole" <+> quotes (text "_") <+> text "with type") <+> pprType zonked_ty + $$ (if null tyvars_msg then empty else text "Where:" <+> vcat tyvars_msg) + $$ (if null lenv_msg then empty else text "In scope:" <+> vcat lenv_msg) + ; mkErrorReport ctxt msg } where - orig@(HoleOrigin lenv) = ctLocOrigin (ctWantedLoc ct) - locMsg tv = case tcTyVarDetails tv of - SkolemTv {} -> return $ (quotes $ ppr tv) <+> ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) + (HoleOrigin lenv) = ctLocOrigin (ctWantedLoc ct) + loc_msg tv = case tcTyVarDetails tv of + SkolemTv {} -> return $ (quotes $ ppr tv) <+> skol_msg MetaTv {} -> do { tyvar <- readMetaTyVar tv - ; case tyvar of - (Indirect ty) -> return $ (quotes $ pprType ty) <+> ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) - Flexi -> return $ (quotes $ ppr tv) <+> text "is a free type variable" + ; return $ case tyvar of + (Indirect ty) -> (quotes $ pprType ty) <+> skol_msg + Flexi -> (quotes $ ppr tv) <+> text "is a free type variable" } det -> return $ ppr det - ppr_skol given_loc tv_loc - = case skol_info of + where skol_msg = ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) + + ppr_skol given_loc tv_loc = case skol_info of UnkSkol -> ptext (sLit "is an unknown type variable") _ -> sep [ ptext (sLit "is a rigid type variable bound by"), sep [ppr skol_info, ptext (sLit "at") <+> ppr tv_loc]] where skol_info = ctLocOrigin given_loc + + ppr_localenv :: TcTypeEnv -> TidyEnv -> TcM (TidyEnv, [SDoc]) + ppr_localenv lenv tidyenv = do { let bound = catMaybes $ map (get_thing.snd) $ ufmToList lenv + ; (finalenv, zonked_bound) <- foldlM tidy_bind (tidyenv, []) bound + ; return (finalenv, map ppr_local_bind zonked_bound) + } + where tidy_bind (tidyenv, docs) (nm, ty) = do { (newtidyenv, zonked_ty) <- zonkTidyTcType tidyenv ty + ; return (newtidyenv, (nm, zonked_ty):docs) + } + + get_thing :: TcTyThing -> Maybe (Var, TcType) + get_thing (ATcId thing_id NotTopLevel _) = Just (thing_id, varType thing_id) + get_thing _ = Nothing + + ppr_local_bind :: (Var, Type) -> SDoc + ppr_local_bind (nm, ty) = ppr nm <+> dcolon <+> pprType ty + +mkHoleDeferredError _ ct = pprPanic "mkHoleDeferredError" (ppr ct) \end{code} %************************************************************************ _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
