Major pass through type checker:(1) prioritizing equalities, (2) improved Derived...
[ghc.git] / compiler / typecheck / TcErrors.lhs
index b3dfb9c..572f82c 100644 (file)
@@ -1,6 +1,6 @@
 \begin{code}
 module TcErrors( 
-       reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
+       reportUnsolved, reportUnsolvedDeriv,
        reportUnsolvedWantedEvVars, warnDefaulting, 
        unifyCtxt, typeExtraInfoMsg, 
        kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
@@ -28,13 +28,12 @@ import SrcLoc
 import Bag
 import ListSetOps( equivClasses )
 import Util
-import Unique
 import FastString
 import Outputable
 import DynFlags
 import StaticFlags( opt_PprStyle_Debug )
 import Data.List( partition )
-import Control.Monad( unless )
+import Control.Monad( when, unless )
 \end{code}
 
 %************************************************************************
@@ -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
@@ -134,17 +117,27 @@ reportTidyImplic ctxt implic
   
 reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 reportTidyWanteds ctxt unsolved
-  = do { let (flats, implics) = splitWanteds unsolved
-             (ambigs, others) = partition is_ambiguous (bagToList flats)
-       ; groupErrs (reportFlat ctxt) others
-       ; mapBagM_ (reportTidyImplic ctxt) implics
-       ; ifErrsM (return ()) $
-                  -- Only report ambiguity if no other errors happened
-          -- See Note [Avoiding spurious errors]
-         reportAmbigErrs ctxt skols ambigs }
+  = do { let (flats,  implics)    = splitWanteds unsolved
+             (ambigs, non_ambigs) = partition is_ambiguous (bagToList flats)
+                    (tv_eqs, others)     = partition is_tv_eq non_ambigs
+
+       ; groupErrs (reportEqErrs ctxt) tv_eqs
+       ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others
+       ; when (null tv_eqs) $ mapBagM_ (reportTidyImplic ctxt) implics
+
+                  -- Only report ambiguity if no other errors (at all) happened
+          -- See Note [Avoiding spurious errors] in TcSimplify
+       ; ifErrsM (return ()) $ reportAmbigErrs ctxt skols ambigs }
   where
     skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
  
+       -- Report equalities of form (a~ty) first.  They are usually
+       -- skolem-equalities, and they cause confusing knock-on 
+       -- effects in other errors; see test T4093b.
+    is_tv_eq c | EqPred ty1 ty2 <- wantedEvVarPred c
+               = tcIsTyVarTy ty1 || tcIsTyVarTy ty2
+               | otherwise = False
+
        -- Treat it as "ambiguous" if 
        --   (a) it is a class constraint
         --   (b) it constrains only type variables
@@ -158,7 +151,7 @@ reportTidyWanteds ctxt unsolved
 reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
 reportFlat ctxt flats origin
   = do { unless (null dicts) $ reportDictErrs ctxt dicts origin
-       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   
+       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   origin
        ; unless (null ips)   $ reportIPErrs   ctxt ips   origin
        ; ASSERT( null others ) return () }
   where
@@ -277,12 +270,18 @@ reportIPErrs ctxt ips orig
 %************************************************************************
 
 \begin{code}
-reportEqErrs :: ReportErrCtxt -> [PredType] -> TcM ()
-reportEqErrs ctxt eqs 
+reportEqErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM ()
+reportEqErrs ctxt eqs orig
   = mapM_ report_one eqs 
   where
-    report_one (EqPred ty1 ty2) = reportEqErr ctxt ty1 ty2
-    report_one pred             = pprPanic "reportEqErrs" (ppr pred)    
+    env0 = cec_tidy ctxt
+    report_one (EqPred 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)    
 
 reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM ()
 reportEqErr ctxt ty1 ty2
@@ -554,7 +553,7 @@ monomorphism_fix :: DynFlags -> SDoc
 monomorphism_fix dflags
   = ptext (sLit "Probable fix:") <+> vcat
        [ptext (sLit "give these definition(s) an explicit type signature"),
-        if dopt Opt_MonomorphismRestriction dflags
+        if xopt Opt_MonomorphismRestriction dflags
            then ptext (sLit "or use -XNoMonomorphismRestriction")
            else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
                        -- if it is not already set!
@@ -640,36 +639,30 @@ warnDefaulting wanteds default_ty
 %************************************************************************
 %*                                                                     *
                  Error from the canonicaliser
+        These ones are called *during* constraint simplification
 %*                                                                     *
 %************************************************************************
 
 \begin{code}
-kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS ()
+kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 -- If there's a kind error, we don't want to blindly say "kind error"
 -- We might, say, be unifying a skolem 'a' with a type 'Int', 
 -- 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
-  = wrapErrTcS        $ 
-    setCtFlavorLoc fl $ 
-    do { env0 <- tcInitTidyEnv
-       ; let (env1, ty1') = tidyOpenType env0 ty1
-             (env2, ty2') = tidyOpenType env1 ty2
-             ctxt = CEC { cec_encl = []
-                        , cec_extra = empty
-                        , cec_tidy = env2 }
-       ; reportEqErr ctxt ty1' ty2' }
+  = wrapEqErrTcS fl ty1 ty2 $ \ env0 ty1 ty2 extra -> 
+    do { let ctxt = CEC { cec_encl = []
+                        , cec_extra = extra
+                        , cec_tidy = env0 }
+       ; reportEqErr ctxt ty1 ty2 
+       ; failM
+       }
 
 misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
 misMatchErrorTcS fl ty1 ty2
-  = wrapErrTcS            $ 
-    setCtFlavorLocNoEq fl $  -- Don't add the "When matching t1 with t2"
-                            -- part, because it duplciates what we say now
-    do { env0 <- tcInitTidyEnv
-       ; let (env1, ty1') = tidyOpenType env0 ty1
-             (env2, ty2') = tidyOpenType env1 ty2
-             (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
-       ; failWithTcM (env3, inaccessible_msg $$ msg) }
+  = 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 
@@ -685,13 +678,9 @@ misMatchErrorTcS fl ty1 ty2
 
 occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
 occursCheckErrorTcS fl tv ty
-  = wrapErrTcS           $ 
-    setCtFlavorLoc fl $ 
-    do { env0          <- tcInitTidyEnv
-       ; let (env1, tv') = tidyOpenTyVar env0 tv
-             (env2, ty') = tidyOpenType env1 ty
-             extra = sep [ppr tv', char '=', ppr ty']
-       ; failWithTcM (env2, hang msg 2 extra) }
+  = 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:"
 
@@ -731,30 +720,69 @@ flattenForAllErrorTcS fl ty _bad_eqs
 %************************************************************************
 
 \begin{code}
-setCtFlavorLocNoEq :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLocNoEq (Wanted  loc) thing = setCtLoc loc thing
-setCtFlavorLocNoEq (Derived loc) thing = setCtLoc loc thing
-setCtFlavorLocNoEq (Given   loc) thing = setCtLoc loc thing
-
 setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
-setCtFlavorLoc (Wanted  loc) thing = setWantedLoc loc thing
-setCtFlavorLoc (Derived loc) thing = setWantedLoc loc thing
-setCtFlavorLoc (Given   loc) thing = setGivenLoc  loc thing
-
-setWantedLoc :: WantedLoc -> TcM a -> TcM a
-setWantedLoc loc thing_inside 
-  = setCtLoc loc $
-    add_origin (ctLocOrigin loc) $ 
-    thing_inside
+setCtFlavorLoc (Wanted  loc)   thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing
+setCtFlavorLoc (Given   loc)   thing = setCtLoc loc thing
+
+wrapEqErrTcS :: CtFlavor -> TcType -> TcType
+             -> (TidyEnv -> TcType -> TcType -> SDoc -> TcM a)
+             -> TcS a
+wrapEqErrTcS fl ty1 ty2 thing_inside
+  = do { ty_binds_var <- getTcSTyBinds
+       ; wrapErrTcS $ setCtFlavorLoc fl $ 
+    do {   -- Apply the current substitition
+           -- and zonk to get rid of flatten-skolems
+       ; ty_binds_map <- readTcRef ty_binds_var
+       ; let subst = mkOpenTvSubst (mapVarEnv snd ty_binds_map)
+       ; 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   -> 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
-    add_origin (TypeEqOrigin item) = addErrCtxtM (unifyCtxt item)
-    add_origin orig = addErrCtxt (ptext (sLit "At") <+> ppr orig)
 
-setGivenLoc :: GivenLoc -> TcM a -> TcM a
-setGivenLoc loc thing_inside 
-  = setCtLoc loc $
-    add_origin (ctLocOrigin loc) $ 
-    thing_inside
-  where
-    add_origin skol = addErrCtxt (ptext (sLit "In") <+> pprSkolInfo skol)
+getWantedEqExtra :: TvSubst -> TidyEnv -> CtOrigin -> TcType -> TcType
+                 -> 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
+  --
+  -- The complication is that the types in the TypeEqOrigin must
+  --   (a) be zonked
+  --   (b) have any TcS-monad pending equalities applied to them 
+  --                   (hence the passed-in substitution)
+  = 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  
+            return (env0, empty)
+         else 
+            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}