[commit: ghc] type-holes-branch: This seems to fix the zonking of the tyvars in the hole's error message. (fe99d51)

[Simon Peyton Jones]

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 <thijsalkemade at gmail.com>
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}