Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : type-holes-branch
http://hackage.haskell.org/trac/ghc/changeset/fe99d5113997df0778ab22dbc61b37d894f5f420 >--------------------------------------------------------------- commit fe99d5113997df0778ab22dbc61b37d894f5f420 Author: Thijs Alkemade <[email protected]> Date: Tue Jul 17 13:31:13 2012 +0200 This seems to fix the zonking of the tyvars in the hole's error message. >--------------------------------------------------------------- compiler/typecheck/TcCanonical.lhs | 4 ++-- compiler/typecheck/TcErrors.lhs | 31 ++++++++++++++++++++++++++++--- compiler/typecheck/TcExpr.lhs | 9 +++++---- 3 files changed, 35 insertions(+), 9 deletions(-) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 69e0186..33ba4ed 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -208,11 +208,11 @@ canonicalize (CIrredEvCan { cc_flavor = fl , cc_depth = d , cc_ty = xi }) = canIrred d fl xi -canonicalize (CHoleCan { cc_depth = d +canonicalize c@(CHoleCan { cc_depth = d , cc_flavor = fl , cc_hole_nm = nm , cc_hole_ty = xi }) - = canHole d fl nm xi + = continueWith c -- canHole d fl nm xi canEvVar :: SubGoalDepth -> CtFlavor diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index a45621f..5e2bc64 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -405,15 +405,39 @@ mkIrredErr ctxt cts \begin{code} mkHoleDeferredError :: Bag Ct -> ReportErrCtxt -> Ct -> TcM ErrMsg -mkHoleDeferredError allcts ctxt ct@(CHoleCan { cc_hole_nm = nm, cc_flavor = fl }) = mkErrorReport ctxt msg +mkHoleDeferredError allcts ctxt ct@(CHoleCan { cc_hole_nm = nm, cc_flavor = fl, cc_hole_ty = ty }) + = do { traceTc "mkHoleDeferredError" (ppr $ tyVarsOfCt ct) + ; let env0 = cec_tidy ctxt + ; let vars = tyVarsOfCt ct + ; zonked_vars <- zonkTyVarsAndFV vars + --; let env1 = tidyFreeTyVars env0 zonked_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") <+> ppr nm <+> text "with type" <+> pprType zonked_ty + $$ (text "In scope:" <+> ppr lenv) + $$ (text "Where:" <+> sep tyvars_msg) + ; mkErrorReport ctxt msg + } where - ty = ctFlavPred fl orig@(HoleOrigin _ lenv) = ctLocOrigin (ctWantedLoc ct) relevant = mapBag ctPred $ filterBag isRelevant allcts isRelevant ct' = case classifyPredType (ctPred ct') of ClassPred {} -> any (`elem` (varSetElems $ tyVarsOfCt ct)) (varSetElems $ tyVarsOfCt ct') _ -> False - msg = addArising orig $ (text "Found hole") <+> ppr nm <+> text "with type" <+> ppr ty $$ (text "In scope:" <+> ppr lenv) + locMsg tv = case tcTyVarDetails tv of + SkolemTv {} -> return $ (quotes $ ppr tv) <+> ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) + MetaTv {} -> do { (Indirect ty) <- readMetaTyVar tv + ; return $ (quotes $ pprType ty) <+> ppr_skol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv) + } + det -> return $ ppr det + 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 \end{code} %************************************************************************ @@ -1026,6 +1050,7 @@ findGlobals ctxt tvs = do { lcl_ty_env <- case cec_encl ctxt of [] -> getLclTypeEnv (i:_) -> return (ic_env i) + ; traceTc "findGlobals" (ppr lcl_ty_env) ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) } where go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 5cee4f8..db4b070 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -219,14 +219,15 @@ tcExpr (HsType ty) _ -- Can't eliminate it altogether from the parser, because the -- same parser parses *patterns*. tcExpr (HsHole name) res_ty - = do { traceTc "tcExpr.HsHole" (ppr res_ty) - ; let ev = mkLocalId name res_ty + = do { ty <- newFlexiTyVarTy liftedTypeKind + ; traceTc "tcExpr.HsHole" (ppr ty) + ; let ev = mkLocalId name ty ; lenv <- getLclTypeEnv ; let loc = HoleOrigin name lenv - ; let can = (CHoleCan (Wanted (CtLoc loc (nameSrcSpan name) []) ev) name res_ty 0) + ; let can = (CHoleCan (Wanted (CtLoc loc (nameSrcSpan name) []) ev) name ty 0) ; traceTc "tcExpr.HsHole emitting" (ppr can) ; emitInsoluble can - ; return (HsHole ev) } + ; tcWrapResult (HsHole ev) ty res_ty } \end{code} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
