Further improvements in error messages

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index db21659..9531a50 100644 (file)
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1,6 +1,6 @@
 \begin{code}
 module TcErrors( 
-       reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
+       reportUnsolved, reportUnsolvedDeriv,
        reportUnsolvedWantedEvVars, warnDefaulting, 
        unifyCtxt, typeExtraInfoMsg, 
        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
@@ -28,7 +28,6 @@ import SrcLoc
 import Bag
 import ListSetOps( equivClasses )
 import Util
-import Unique
 import FastString
 import Outputable
 import DynFlags
@@ -53,7 +52,9 @@ reportUnsolved (unsolved_flats, unsolved_implics)
   | isEmptyBag unsolved
   = return ()
   | otherwise
-  = do { env0 <- tcInitTidyEnv
+  = do { unsolved <- mapBagM zonkWanted unsolved
+                    -- Zonk to un-flatten any flatten-skols
+       ; env0 <- tcInitTidyEnv
        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
              tidy_unsolved = tidyWanteds tidy_env unsolved
              err_ctxt = CEC { cec_encl = [] 
@@ -64,12 +65,14 @@ reportUnsolved (unsolved_flats, unsolved_implics)
   where
     unsolved = mkWantedConstraints unsolved_flats unsolved_implics
 
+
 reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
 reportUnsolvedWantedEvVars wanteds
   | isEmptyBag wanteds 
   = return ()
   | otherwise
-  = do { env0 <- tcInitTidyEnv
+  = do { wanteds <- mapBagM zonkWantedEvVar wanteds
+       ; env0 <- tcInitTidyEnv
        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
              tidy_unsolved = tidyWantedEvVars tidy_env wanteds
              err_ctxt = CEC { cec_encl  = [] 
@@ -83,7 +86,8 @@ reportUnsolvedDeriv unsolved loc
   = return ()
   | otherwise
   = setCtLoc loc $
-    do { env0 <- tcInitTidyEnv
+    do { unsolved <- zonkTcThetaType unsolved
+       ; env0 <- tcInitTidyEnv
        ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
              tidy_unsolved = map (tidyPred tidy_env) unsolved
              err_ctxt = CEC { cec_encl  = [] 
@@ -94,30 +98,9 @@ reportUnsolvedDeriv unsolved loc
     alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
                     nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
 
-reportUnsolvedImplication :: Implication -> TcM ()
-reportUnsolvedImplication implic
-  = do { env0 <- tcInitTidyEnv
-       ; let tidy_env    = tidyFreeTyVars env0 (tyVarsOfImplication implic)
-             tidy_implic = tidyImplication tidy_env implic
-             new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
-             err_ctxt = CEC { cec_encl = [tidy_implic]
-                            , cec_extra = empty
-                            , cec_tidy = new_tidy_env } 
-       ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
-  where
-    -- Extend the tidy env with a mapping from tyvars to the
-    -- names the user originally used.  At the moment we do this
-    -- from the type env, but it might be better to record the
-    -- scoped type variable in the Implication.  Urgh.
-    add (ATyVar name ty) (occ_env, var_env)
-       | Just tv <- tcGetTyVar_maybe ty
-       , not (getUnique name `elemVarEnvByKey` var_env)
-       = case tidyOccName occ_env (nameOccName name) of
-           (occ_env', occ') ->  (occ_env', extendVarEnv var_env tv tv')
-               where
-                 tv'   = setTyVarName tv name'
-                 name' = tidyNameOcc name occ'
-    add _ tidy_env = tidy_env      
+--------------------------------------------
+--      Internal functions
+--------------------------------------------
 
 data ReportErrCtxt 
     = CEC { cec_encl :: [Implication]  -- Enclosing implications
@@ -283,10 +266,10 @@ reportEqErrs ctxt eqs orig
   where
     env0 = cec_tidy ctxt
     report_one (EqPred ty1 ty2) 
-      = getWantedEqExtra emptyTvSubst env0 orig ty1 ty2 $ \ env1 extra ->
-        let ctxt' = ctxt { cec_tidy = env1
-                         , cec_extra = cec_extra ctxt $$ extra }
-        in reportEqErr ctxt' ty1 ty2 
+      = do { (env1, extra) <- getWantedEqExtra emptyTvSubst env0 orig ty1 ty2
+           ; let ctxt' = ctxt { cec_tidy = env1
+                               , cec_extra = cec_extra ctxt $$ extra }
+           ; reportEqErr ctxt' ty1 ty2 }
     report_one pred 
       = pprPanic "reportEqErrs" (ppr pred)    
 
@@ -646,6 +629,7 @@ warnDefaulting wanteds default_ty
 %************************************************************************
 %*                                                                     *
                  Error from the canonicaliser
+        These ones are called *during* constraint simplification
 %*                                                                     *
 %************************************************************************
 
@@ -656,21 +640,17 @@ kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
 -- in which case that's the error to report.  So we set things
 -- up to call reportEqErr, which does the business properly
 kindErrorTcS fl ty1 ty2
-  = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra -> 
-    do { let (env1, ty1') = tidyOpenType env0 ty1
-             (env2, ty2') = tidyOpenType env1 ty2
-             ctxt = CEC { cec_encl = []
+  = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> 
+    do { let ctxt = CEC { cec_encl = []
                         , cec_extra = extra
-                        , cec_tidy = env2 }
-       ; reportEqErr ctxt ty1' ty2' }
+                        , cec_tidy = env0 }
+       ; reportEqErr ctxt ty1 ty2 }
 
 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 misMatchErrorTcS fl ty1 ty2
-  = wrapEqErrTcS fl ty1 ty2 $ \ env0 extra -> 
-    do { let (env1, ty1') = tidyOpenType env0 ty1
-             (env2, ty2') = tidyOpenType env1 ty2
-             (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
-       ; failWithTcM (env3, inaccessible_msg $$ msg $$ extra) }
+  = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> 
+    do { let (env1, msg)  = misMatchMsgWithExtras env0 ty1 ty2
+       ; failWithTcM (env1, inaccessible_msg $$ msg $$ extra) }
   where
     inaccessible_msg 
       = case fl of 
@@ -686,11 +666,9 @@ misMatchErrorTcS fl ty1 ty2
 
 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 occursCheckErrorTcS fl tv ty
-  = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 extra2 -> 
-    do { let (env1, tv') = tidyOpenTyVar env0 tv
-             (env2, ty') = tidyOpenType env1 ty
-             extra1 = sep [ppr tv', char '=', ppr ty']
-       ; failWithTcM (env2, hang msg 2 (extra1 $$ extra2)) }
+  = wrapEqErrTcS fl (mkTyVarTy tv) ty $ \ env0 ty1 ty2 extra2 -> 
+    do { let extra1 = sep [ppr ty1, char '=', ppr ty2]
+       ; failWithTcM (env0, hang msg 2 (extra1 $$ extra2)) }
   where
     msg = text $ "Occurs check: cannot construct the infinite type:"
 
@@ -736,25 +714,33 @@ setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
 setCtFlavorLoc (Given   loc) thing = setCtLoc loc thing
 
 wrapEqErrTcS :: CtFlavor -> TcType -> TcType
-             -> (TidyEnv -> SDoc -> TcM a)
+             -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
              -> TcS a
 wrapEqErrTcS fl ty1 ty2 thing_inside
   = do { ty_binds_var <- getTcSTyBinds
        ; wrapErrTcS $ setCtFlavorLoc fl $ 
-    do { env0 <- tcInitTidyEnv 
+    do {   -- Apply the current substitition
+           -- and zonk to get rid of flatten-skolems
        ; ty_binds_bag <- readTcRef ty_binds_var
        ; let subst = mkOpenTvSubst (mkVarEnv (bagToList ty_binds_bag))
+       ; env0 <- tcInitTidyEnv 
+       ; (env1, ty1) <- zonkSubstTidy env0 subst ty1
+       ; (env2, ty2) <- zonkSubstTidy env1 subst ty2
+       ; let do_wanted loc = do { (env3, extra) <- getWantedEqExtra subst env2 
+                                                     (ctLocOrigin loc) ty1 ty2
+                                ; thing_inside env3 ty1 ty2 extra } 
        ; case fl of
-           Wanted  loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
-           Derived loc -> getWantedEqExtra subst env0 (ctLocOrigin loc) ty1 ty2 thing_inside
-           Given {}    -> thing_inside env0 empty  -- We could print more info, but it
-                                                   -- seems to be coming out already
+           Wanted  loc -> do_wanted loc
+           Derived loc -> do_wanted loc
+           Given {}    -> thing_inside env2 ty1 ty2 empty 
+                                -- We could print more info, but it
+                                 -- seems to be coming out already
        } }  
+  where
 
 getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
-                 -> (TidyEnv -> SDoc -> TcM a)
-                 -> TcM a
-getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2 thing_inside
+                 -> TcM (TidyEnv, SDoc)
+getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2
   -- If the types in the error message are the same 
   -- as the types we are unifying (remember to zonk the latter)
   -- don't add the extra expected/actual message
@@ -763,19 +749,28 @@ getWantedEqExtra subst env0 (TypeEqOrigin item) ty1 ty2 thing_inside
   --   (a) be zonked
   --   (b) have any TcS-monad pending equalities applied to them 
   --                   (hence the passed-in substitution)
-  = do { act0 <- zonkTcType (uo_actual item)
-       ; exp0 <- zonkTcType (uo_expected item)
-       ; let act1 = substTy subst act0
-             exp1 = substTy subst exp0
-             (env1, exp2) = tidyOpenType env0 exp1
-             (env2, act2) = tidyOpenType env1 act1
-       ; if (act1 `tcEqType` ty1 && exp1 `tcEqType` ty2)
-         || (exp1 `tcEqType` ty1 && act1 `tcEqType` ty2)
+  = do { (env1, act) <- zonkSubstTidy env0 subst (uo_actual item)
+       ; (env2, exp) <- zonkSubstTidy env1 subst (uo_expected item)
+       ; if (act `tcEqType` ty1 && exp `tcEqType` ty2)
+         || (exp `tcEqType` ty1 && act `tcEqType` ty2)
          then  
-            thing_inside env0 empty
+            return (env0, empty)
          else 
-            thing_inside env2 (mkExpectedActualMsg act2 exp2) }
-
-getWantedEqExtra _ env0 orig _ _ thing_inside
-  = thing_inside env0 (pprArising orig)
+            return (env2, mkExpectedActualMsg act exp) }
+
+getWantedEqExtra _ env0 orig _ _ 
+  = return (env0, pprArising orig)
+
+zonkSubstTidy :: TidyEnv -> TvSubst -> TcType -> TcM (TidyEnv, TcType)
+-- In general, becore printing a type, we want to
+--   a) Zonk it.  Even during constraint simplification this is
+--      is important, to un-flatten the flatten skolems in a type
+--   b) Substitute any solved unification variables.  This is
+--      only important *during* solving, becuase after solving
+--      the substitution is expressed in the mutable type variables
+--      But during solving there may be constraint (F xi ~ ty)
+--      where the substitution has not been applied to the RHS
+zonkSubstTidy env subst ty
+  = do { ty' <- zonkTcTypeAndSubst subst ty
+       ; return (tidyOpenType env ty') }
 \end{code}

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index a3484a9..a81270e 100644 (file)
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -57,6 +57,7 @@ module TcMType (
   zonkTcType, zonkTcTypes, zonkTcThetaType,
   zonkTcKindToKind, zonkTcKind, 
   zonkImplication, zonkWanted, zonkEvVar, zonkWantedEvVar,
+  zonkTcTypeAndSubst,
   tcGetGlobalTyVars, 
 
   readKindVar, writeKindVar
@@ -485,25 +486,23 @@ zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar tyvars
 -----------------  Types
 
 zonkTcTypeCarefully :: TcType -> TcM TcType
+-- Do not zonk type variables free in the environment
 zonkTcTypeCarefully ty
   = do { env_tvs <- tcGetGlobalTyVars
-       ; zonkType (zonkTcTyVarCarefully env_tvs) ty }
-
-
-zonkTcTyVarCarefully :: TcTyVarSet -> TcTyVar -> TcM TcType
--- Do not zonk type variables free in the environment
-zonkTcTyVarCarefully env_tvs tv 
-  | tv `elemVarSet` env_tvs 
-  = return (TyVarTy tv)
-  | otherwise
-  = ASSERT( isTcTyVar tv )
-    case tcTyVarDetails tv of
-      SkolemTv {}  -> return (TyVarTy tv)
-      FlatSkol ty  -> zonkType (zonkTcTyVarCarefully env_tvs) ty
-      MetaTv _ ref -> do { cts <- readMutVar ref
-                        ; case cts of    
-                            Flexi       -> return (TyVarTy tv)
-                            Indirect ty -> zonkType (zonkTcTyVarCarefully env_tvs) ty }
+       ; zonkType (zonk_tv env_tvs) ty }
+  where
+    zonk_tv env_tvs tv
+      | tv `elemVarSet` env_tvs 
+      = return (TyVarTy tv)
+      | otherwise
+      = ASSERT( isTcTyVar tv )
+       case tcTyVarDetails tv of
+         SkolemTv {}  -> return (TyVarTy tv)
+         FlatSkol ty  -> zonkType (zonk_tv env_tvs) ty
+         MetaTv _ ref -> do { cts <- readMutVar ref
+                            ; case cts of    
+                                Flexi       -> return (TyVarTy tv)
+                                Indirect ty -> zonkType (zonk_tv env_tvs) ty }
 
 zonkTcType :: TcType -> TcM TcType
 -- Simply look through all Flexis
@@ -521,6 +520,23 @@ zonkTcTyVar tv
                             Flexi       -> return (TyVarTy tv)
                             Indirect ty -> zonkTcType ty }
 
+zonkTcTypeAndSubst :: TvSubst -> TcType -> TcM TcType
+-- Zonk, and simultaneously apply a non-necessarily-idempotent substitution
+zonkTcTypeAndSubst subst ty = zonkType zonk_tv ty
+  where
+    zonk_tv tv 
+      = case tcTyVarDetails tv of
+         SkolemTv {}  -> return (TyVarTy tv)
+         FlatSkol ty  -> zonkType zonk_tv ty
+         MetaTv _ ref -> do { cts <- readMutVar ref
+                            ; case cts of    
+                                Flexi       -> zonk_flexi tv
+                                Indirect ty -> zonkType zonk_tv ty }
+    zonk_flexi tv
+      = case lookupTyVar subst tv of
+          Just ty -> zonkType zonk_tv ty
+          Nothing -> return (TyVarTy tv)
+
 zonkTcTypes :: [TcType] -> TcM [TcType]
 zonkTcTypes tys = mapM zonkTcType tys
 

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 57e9125..0e7acdd 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -236,7 +236,7 @@ simplifyAsMuchAsPossible ctxt wanteds
               simplifyApproxLoop 0 wanteds
 
              -- Report any errors
-       ; mapBagM_ reportUnsolvedImplication unsolved_implics
+       ; reportUnsolved (emptyBag, unsolved_implics)
 
        ; let final_wanted_evvars = mapBag deCanonicaliseWanted unsolved_flats
        ; return (final_wanted_evvars, ev_binds) }