Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc

7 files changed, 85 insertions, 58 deletions

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index 69d46c2096..f6207f1a13 100644
--- a/compiler/deSugar/MatchLit.lhs
+++ b/compiler/deSugar/MatchLit.lhs
@@ -107,7 +107,7 @@ dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
                            , ol_witness = witness, ol_type = ty })
   | not rebindable
   , Just expr <- shortCutLit dflags val ty = dsExpr expr	-- Note [Literal short cut]
-  | otherwise			    = dsExpr witness
+  | otherwise	                           = dsExpr witness
 \end{code}
 
 Note [Literal short cut]
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index ef0263d05d..0638422a91 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -619,6 +619,7 @@ hsExprNeedsParens (PArrSeq {})        = False
 hsExprNeedsParens (HsLit {})          = False
 hsExprNeedsParens (HsOverLit {})      = False
 hsExprNeedsParens (HsVar {})          = False
+hsExprNeedsParens (HsHole {})         = False
 hsExprNeedsParens (HsIPVar {})        = False
 hsExprNeedsParens (ExplicitTuple {})  = False
 hsExprNeedsParens (ExplicitList {})   = False
@@ -637,6 +638,7 @@ isAtomicHsExpr (HsVar {})     = True
 isAtomicHsExpr (HsLit {})     = True
 isAtomicHsExpr (HsOverLit {}) = True
 isAtomicHsExpr (HsIPVar {})   = True
+isAtomicHsExpr (HsHole {})    = True
 isAtomicHsExpr (HsWrap _ e)   = isAtomicHsExpr e
 isAtomicHsExpr (HsPar e)      = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr _              = False
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 0fb0194d25..4f0bfad561 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -93,6 +93,11 @@ in TcErrors. TcErrors.reportTidyWanteds does not print the errors
 and does not fail if -fwarn-type-errors is on, so that we can continue
 compilation. The errors are turned into warnings in `reportUnsolved`.
 
+Note [Suppressing error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If there are any insolubles, like (Int~Bool), then we suppress all less-drastic
+errors (like (Eq a)).  Often the latter are a knock-on effect of the former.
+
 \begin{code}
 reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
 reportUnsolved wanted
@@ -122,15 +127,13 @@ report_unsolved mb_binds_var defer wanted
                  
             -- If we are deferring we are going to need /all/ evidence around,
             -- including the evidence produced by unflattening (zonkWC)
---       ; errs_so_far <- ifErrsM (return True) (return False)
        ; let tidy_env = tidyFreeTyVars env0 free_tvs
              free_tvs = tyVarsOfWC wanted
              err_ctxt = CEC { cec_encl  = []
                             , cec_tidy  = tidy_env
                             , cec_defer    = defer
                             , cec_suppress = insolubleWC wanted
-                                  -- Suppress all but insolubles if there are
-                                  -- any insoulubles, or earlier errors
+                                  -- See Note [Suppressing error messages]
                             , cec_binds    = mb_binds_var }
 
        ; traceTc "reportUnsolved (after unflattening):" $ 
@@ -189,14 +192,13 @@ reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
 reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics })
   = do { reportFlats (ctxt { cec_suppress = False }) (mapBag (tidyCt env) insols)
        ; reportFlats ctxt                            (mapBag (tidyCt env) flats)
+            -- All the Derived ones have been filtered out of flats 
+            -- by the constraint solver. This is ok; we don't want
+            -- to report unsolved Derived goals as errors
+            -- See Note [Do not report derived but soluble errors]
        ; mapBagM_ (reportImplic ctxt) implics }
   where
     env = cec_tidy ctxt
---    tidy_cts = mapBag (tidyCt env) (insols `unionBags` flats)
-                  -- All the Derived ones have been filtered out alrady
-                  -- by the constraint solver. This is ok; we don't want
-                  -- to report unsolved Derived goals as error
-                  -- See Note [Do not report derived but soluble errors]
 
 reportFlats :: ReportErrCtxt -> Cts -> TcM ()
 reportFlats ctxt flats    -- Here 'flats' includes insolble goals
@@ -212,7 +214,6 @@ reportFlats ctxt flats    -- Here 'flats' includes insolble goals
         -- skolem-equalities, and they cause confusing knock-on 
         -- effects in other errors; see test T4093b.
       , ("Skolem equalities",    skolem_eq,   mkUniReporter mkEqErr1) ]
---      , ("Unambiguous",          unambiguous, reportFlatErrs) ]
       reportFlatErrs
       ctxt (bagToList flats)
   where
@@ -225,17 +226,6 @@ reportFlats ctxt flats    -- Here 'flats' includes insolble goals
     skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 
     skolem_eq _ _ = False
 
-{-
-    unambiguous :: Ct -> PredTree -> Bool
-    unambiguous ct pred 
-      | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct)))
-      = True
-      | otherwise 
-      = case pred of
-          EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2)
-          _              -> False
--}
-
 ---------------
 isRigid, isRigidOrSkol :: Type -> Bool
 isRigid ty 
@@ -324,11 +314,12 @@ mkGroupReporter mk_err ctxt (ct1 : rest)
 
 maybeReportError :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
 -- Report the error and/or make a deferred binding for it
-maybeReportError ctxt err ct
+maybeReportError ctxt err _ct
+  | cec_defer ctxt  -- We have -fdefer-type-errors
+                    -- so warn about all, even if cec_suppress is on
+  = reportWarning (makeIntoWarning err)
   | cec_suppress ctxt
   = return ()
-  | isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
-  = reportWarning (makeIntoWarning err)
   | otherwise
   = reportError err
 
@@ -338,7 +329,7 @@ maybeAddDeferredBinding ctxt err ct
   | CtWanted { ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
     -- Only add deferred bindings for Wanted constraints
   , isHoleCt ct || cec_defer ctxt  -- And it's a hole or we have -fdefer-type-errors
-  , Just ev_binds_var <- cec_binds ctxt  -- We hvae somewhere to put the bindings
+  , Just ev_binds_var <- cec_binds ctxt  -- We have somewhere to put the bindings
   = do { dflags <- getDynFlags
        ; let err_msg = pprLocErrMsg err
              err_fs  = mkFastString $ showSDoc dflags $
@@ -494,7 +485,7 @@ mkHoleError ctxt ct@(CHoleCan {})
     loc_msg tv 
        = case tcTyVarDetails tv of
           SkolemTv {} -> quotes (ppr tv) <+> skol_msg
-          MetaTv {}   -> quotes (ppr tv) <+> text "is a free type variable"
+          MetaTv {}   -> quotes (ppr tv) <+> text "is an ambiguous type variable"
           det -> pprTcTyVarDetails det
        where 
           skol_msg = pprSkol (getSkolemInfo (cec_encl ctxt) tv) (getSrcLoc tv)
@@ -527,6 +518,24 @@ mkIPErr ctxt cts
 %*									*
 %************************************************************************
 
+Note [Inaccessible code]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a where
+     T1 :: T a
+     T2 :: T Bool
+
+   f :: (a ~ Int) => T a -> Int
+   f T1 = 3
+   f T2 = 4   -- Unreachable code
+
+Here the second equation is unreachable. The original constraint
+(a~Int) from the signature gets rewritten by the pattern-match to
+(Bool~Int), so the danger is that we report the error as coming from
+the *signature* (Trac #7293).  So, for Given errors we replace the
+env (and hence src-loc) on its CtLoc with that from the immediately
+enclosing implication.
+
 \begin{code}
 mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 -- Don't have multiple equality errors from the same location
@@ -537,20 +546,30 @@ mkEqErr _ [] = panic "mkEqErr"
 mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
 -- Wanted constraints only!
 mkEqErr1 ctxt ct
+  | isGiven ev
   = do { (ctxt, binds_msg) <- relevantBindings ctxt ct
-       ; (ctxt, orig) <- zonkTidyOrigin ctxt orig
-       ; let (is_oriented, wanted_msg) = mk_wanted_extra orig
-       ; if isGiven ev then 
-           mkEqErr_help ctxt (inaccessible_msg orig $$ binds_msg) ct Nothing ty1 ty2
-         else
-           mkEqErr_help ctxt (wanted_msg $$ binds_msg) ct is_oriented ty1 ty2 }
+       ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
+       ; mkEqErr_help ctxt (given_msg $$ binds_msg) 
+                      (ct { cc_loc = given_loc}) -- Note [Inaccessible code]
+                      Nothing ty1 ty2 }
+
+  | otherwise   -- Wanted or derived
+  = do { (ctxt, binds_msg) <- relevantBindings ctxt ct
+       ; (ctxt, tidy_orig) <- zonkTidyOrigin ctxt (ctLocOrigin (cc_loc ct))
+       ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
+       ; mkEqErr_help ctxt (wanted_msg $$ binds_msg) 
+                      ct is_oriented ty1 ty2 }
   where
     ev         = cc_ev ct
-    orig       = ctLocOrigin (cc_loc ct)
-    (ty1, ty2) = getEqPredTys (ctPred ct)
-
-    inaccessible_msg orig = hang (ptext (sLit "Inaccessible code in"))
-                               2 (ppr orig)
+    (ty1, ty2) = getEqPredTys (ctEvPred ev)
+
+    mk_given :: [Implication] -> (CtLoc, SDoc)
+    -- For given constraints we overwrite the env (and hence src-loc)
+    -- with one from the implication.  See Note [Inaccessible code]
+    mk_given []           = (cc_loc ct, empty)
+    mk_given (implic : _) = (setCtLocEnv (cc_loc ct) (ic_env implic)
+                            , hang (ptext (sLit "Inaccessible code in"))
+                                 2 (ppr (ic_info implic)))
 
        -- If the types in the error message are the same as the types
        -- we are unifying, don't add the extra expected/actual message
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 68301f7972..c03c51bef3 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -627,8 +627,7 @@ discardWarnings thing_inside
 \begin{code}
 mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
 mkLongErrAt loc msg extra
-  = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ;
-         rdr_env <- getGlobalRdrEnv ;
+  = do { rdr_env <- getGlobalRdrEnv ;
          dflags <- getDynFlags ;
          return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
 
@@ -640,13 +639,15 @@ reportErrors = mapM_ reportError
 
 reportError :: ErrMsg -> TcRn ()
 reportError err
-  = do { errs_var <- getErrsVar ;
+  = do { traceTc "Adding error:" (pprLocErrMsg err) ;
+         errs_var <- getErrsVar ;
          (warns, errs) <- readTcRef errs_var ;
          writeTcRef errs_var (warns, errs `snocBag` err) }
 
 reportWarning :: ErrMsg -> TcRn ()
 reportWarning warn
-  = do { errs_var <- getErrsVar ;
+  = do { traceTc "Adding warning:" (pprLocErrMsg warn) ;
+         errs_var <- getErrsVar ;
          (warns, errs) <- readTcRef errs_var ;
          writeTcRef errs_var (warns `snocBag` warn, errs) }
 
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index aa5dec9bd2..42e9d556ff 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -64,7 +64,7 @@ module TcRnTypes(
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin, 
         ctLocDepth, bumpCtLocDepth,
-        setCtLocOrigin,
+        setCtLocOrigin, setCtLocEnv,
 	CtOrigin(..), 
         pushErrCtxt, pushErrCtxtSameOrigin,
 
@@ -1360,6 +1360,9 @@ bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 }
 setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
 setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
 
+setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc
+setCtLocEnv ctl env = ctl { ctl_env = env }
+
 pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc
 pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) 
   = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } }
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 63c475d24a..ba1a2cb397 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1600,28 +1600,28 @@ Main purpose: create new evidence for new_pred;
 -- NB: this allows us to sneak away with ``error'' thunks for 
 -- coercions that come from derived ids (which don't exist!) 
 
-rewriteCtFlavor (CtDerived {}) pty_new _co
-  = newDerived pty_new
-        
-rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) pty_new co
-  = do { new_ev <- newGivenEvVar pty_new new_tm  -- See Note [Bind new Givens immediately]
-       ; return (Just new_ev) }
-  where
-    new_tm = mkEvCast old_tm (mkTcSymCo co)  -- mkEvCast optimises ReflCo
-  
-rewriteCtFlavor ctev@(CtWanted { ctev_evar = evar, ctev_pred = old_pred }) 
-                      new_pred co
+
+rewriteCtFlavor old_ev new_pred co
   | isTcReflCo co -- If just reflexivity then you may re-use the same variable
-  = return (Just (if old_pred `eqType` new_pred
-                  then ctev 
-                  else ctev { ctev_pred = new_pred }))
+  = return (Just (if ctEvPred old_ev `eqType` new_pred
+                  then old_ev
+                  else old_ev { ctev_pred = new_pred }))
        -- Even if the coercion is Refl, it might reflect the result of unification alpha := ty
        -- so old_pred and new_pred might not *look* the same, and it's vital to proceed from
        -- now on using new_pred.
        -- However, if they *do* look the same, we'd prefer to stick with old_pred
        -- then retain the old type, so that error messages come out mentioning synonyms
 
-  | otherwise
+rewriteCtFlavor (CtDerived {}) new_pred _co
+  = newDerived new_pred
+        
+rewriteCtFlavor (CtGiven { ctev_evtm = old_tm }) new_pred co
+  = do { new_ev <- newGivenEvVar new_pred new_tm  -- See Note [Bind new Givens immediately]
+       ; return (Just new_ev) }
+  where
+    new_tm = mkEvCast old_tm (mkTcSymCo co)  -- mkEvCast optimises ReflCo
+  
+rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_pred = old_pred }) new_pred co
   = do { new_evar <- newWantedEvVar new_pred
        ; setEvBind evar (mkEvCast (getEvTerm new_evar) co)
        ; case new_evar of
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index c0ff59d793..09a5b11c22 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -79,7 +79,9 @@ simplifyTop wanteds
            ; simpl_top_loop wc_first_go }
     
     simpl_top_loop wc
-      | isEmptyWC wc 
+      | isEmptyWC wc || insolubleWC wc
+             -- Don't do type-class defaulting if there are insolubles
+             -- Doing so is not going to solve the insolubles
       = return wc
       | otherwise
       = do { wc_residual <- nestTcS (solve_wanteds_and_drop wc)