Major patch to add -fwarn-redundant-constraints
authorSimon Peyton Jones <simonpj@microsoft.com>
Mon, 5 Jan 2015 13:20:48 +0000 (13:20 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 6 Jan 2015 14:21:13 +0000 (14:21 +0000)
The idea was promted by Trac #9939, but it was Christmas, so I did
some recreational programming that went much further.

The idea is to warn when a constraint in a user-supplied context is
redundant.  Everything is described in detail in
  Note [Tracking redundant constraints]
in TcSimplify.

Main changes:

 * The new ic_status field in an implication, of type ImplicStatus.
   It replaces ic_insol, and includes information about redundant
   constraints.

 * New function TcSimplify.setImplicationStatus sets the ic_status.

 * TcSigInfo has sig_report_redundant field to say whenther a
   redundant constraint should be reported; and similarly
   the FunSigCtxt constructor of UserTypeCtxt

 * EvBinds has a field eb_is_given, to record whether it is a given
   or wanted binding. Some consequential chagnes to creating an evidence
   binding (so that we record whether it is given or wanted).

 * AbsBinds field abs_ev_binds is now a *list* of TcEvBiinds;
   see Note [Typechecking plan for instance declarations] in
   TcInstDcls

 * Some significant changes to the type checking of instance
   declarations; Note [Typechecking plan for instance declarations]
   in TcInstDcls.

 * I found that TcErrors.relevantBindings was failing to zonk the
   origin of the constraint it was looking at, and hence failing to
   find some relevant bindings.  Easy to fix, and orthogonal to
   everything else, but hard to disentangle.

Some minor refactorig:

 * TcMType.newSimpleWanteds moves to Inst, renamed as newWanteds

 * TcClassDcl and TcInstDcls now have their own code for typechecking
   a method body, rather than sharing a single function. The shared
   function (ws TcClassDcl.tcInstanceMethodBody) didn't have much code
   and the differences were growing confusing.

 * Add new function TcRnMonad.pushLevelAndCaptureConstraints, and
   use it

 * Add new function Bag.catBagMaybes, and use it in TcSimplify

207 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsExpr.hs
compiler/hsSyn/HsBinds.hs
compiler/iface/BuildTyCl.hs
compiler/iface/IfaceSyn.hs
compiler/main/DynFlags.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcClassDcl.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcFlatten.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcRules.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcSimplify.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/utils/Bag.hs
compiler/utils/Util.hs
docs/users_guide/using.xml
testsuite/tests/arrows/should_compile/arrowpat.hs
testsuite/tests/codeGen/should_compile/T3286.hs
testsuite/tests/deriving/should_compile/T2856.hs
testsuite/tests/deriving/should_compile/T4966.hs
testsuite/tests/deriving/should_compile/T4966.stderr
testsuite/tests/deriving/should_compile/deriving-1935.hs
testsuite/tests/deriving/should_compile/deriving-1935.stderr
testsuite/tests/deriving/should_compile/drv001.hs
testsuite/tests/deriving/should_compile/drv002.hs
testsuite/tests/deriving/should_compile/drv003.hs
testsuite/tests/deriving/should_compile/drv003.stderr
testsuite/tests/deriving/should_run/T9576.stderr
testsuite/tests/gadt/Gadt17_help.hs
testsuite/tests/ghci/scripts/T5045.hs
testsuite/tests/ghci/scripts/T8357.hs
testsuite/tests/ghci/scripts/T8931.script
testsuite/tests/ghci/scripts/ghci044.script
testsuite/tests/ghci/scripts/ghci044.stderr
testsuite/tests/ghci/scripts/ghci047.script
testsuite/tests/ghci/scripts/ghci047.stderr
testsuite/tests/haddock/haddock_examples/Test.hs
testsuite/tests/haddock/haddock_examples/haddock.Test.stderr
testsuite/tests/haddock/should_compile_flag_haddock/haddockA023.hs
testsuite/tests/haddock/should_compile_flag_haddock/haddockA026.hs
testsuite/tests/haddock/should_compile_flag_haddock/haddockA027.hs
testsuite/tests/haddock/should_compile_noflag_haddock/haddockC026.hs
testsuite/tests/haddock/should_compile_noflag_haddock/haddockC027.hs
testsuite/tests/indexed-types/should_compile/Class2.hs
testsuite/tests/indexed-types/should_compile/Gentle.hs
testsuite/tests/indexed-types/should_compile/InstContextNorm.hs
testsuite/tests/indexed-types/should_compile/InstEqContext.hs
testsuite/tests/indexed-types/should_compile/InstEqContext2.hs
testsuite/tests/indexed-types/should_compile/InstEqContext3.hs
testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs
testsuite/tests/indexed-types/should_compile/Rules1.hs
testsuite/tests/indexed-types/should_compile/Simple24.hs
testsuite/tests/indexed-types/should_compile/T2448.hs
testsuite/tests/indexed-types/should_compile/T3023.hs
testsuite/tests/indexed-types/should_compile/T3023.stderr
testsuite/tests/indexed-types/should_compile/T3484.hs
testsuite/tests/indexed-types/should_compile/T4200.hs
testsuite/tests/indexed-types/should_compile/T4497.hs
testsuite/tests/indexed-types/should_compile/T4981-V1.hs
testsuite/tests/indexed-types/should_compile/T4981-V2.hs
testsuite/tests/indexed-types/should_compile/T4981-V3.hs
testsuite/tests/indexed-types/should_compile/T5002.hs
testsuite/tests/indexed-types/should_compile/T9090.hs
testsuite/tests/indexed-types/should_compile/T9316.hs
testsuite/tests/indexed-types/should_compile/T9747.hs
testsuite/tests/indexed-types/should_fail/T2239.hs
testsuite/tests/indexed-types/should_fail/T3330c.stderr
testsuite/tests/indexed-types/should_fail/T7862.hs
testsuite/tests/indexed-types/should_fail/T7862.stderr
testsuite/tests/module/mod129.hs
testsuite/tests/module/mod71.stderr
testsuite/tests/parser/should_compile/mc15.hs
testsuite/tests/parser/should_compile/read002.hs
testsuite/tests/partial-sigs/should_compile/all.T
testsuite/tests/patsyn/should_compile/T8584-2.hs
testsuite/tests/patsyn/should_compile/T8968-1.hs
testsuite/tests/patsyn/should_compile/all.T
testsuite/tests/patsyn/should_compile/ex-view.hs
testsuite/tests/perf/compiler/T3064.hs
testsuite/tests/perf/compiler/T5030.hs
testsuite/tests/polykinds/PolyKinds08.hs
testsuite/tests/polykinds/T6015a.hs
testsuite/tests/polykinds/T6020a.hs
testsuite/tests/polykinds/T6068.hs
testsuite/tests/polykinds/T7090.hs
testsuite/tests/polykinds/T7332.hs
testsuite/tests/polykinds/T8359.hs
testsuite/tests/polykinds/T9569.hs
testsuite/tests/polykinds/T9750.hs
testsuite/tests/rebindable/T5821.hs
testsuite/tests/rebindable/rebindable9.hs
testsuite/tests/rename/should_fail/rnfail020.hs
testsuite/tests/simplCore/should_compile/T3831.hs
testsuite/tests/simplCore/should_compile/T4398.hs
testsuite/tests/simplCore/should_compile/T4398.stderr
testsuite/tests/simplCore/should_compile/T5329.hs
testsuite/tests/simplCore/should_compile/T5342.hs
testsuite/tests/simplCore/should_compile/T5359b.hs
testsuite/tests/simplCore/should_compile/T5359b.stderr
testsuite/tests/simplCore/should_compile/T8848.hs
testsuite/tests/simplCore/should_compile/T8848.stderr
testsuite/tests/simplCore/should_compile/T8848a.hs
testsuite/tests/simplCore/should_compile/simpl002.hs
testsuite/tests/simplCore/should_compile/simpl007.hs
testsuite/tests/simplCore/should_compile/simpl014.hs
testsuite/tests/simplCore/should_compile/simpl016.hs
testsuite/tests/simplCore/should_compile/simpl016.stderr
testsuite/tests/simplCore/should_compile/spec003.hs
testsuite/tests/th/T3100.hs
testsuite/tests/th/T7021a.hs
testsuite/tests/th/T8807.hs
testsuite/tests/th/TH_tf3.hs
testsuite/tests/typecheck/should_compile/GivenOverlapping.hs
testsuite/tests/typecheck/should_compile/LoopOfTheDay1.hs
testsuite/tests/typecheck/should_compile/LoopOfTheDay2.hs
testsuite/tests/typecheck/should_compile/LoopOfTheDay3.hs
testsuite/tests/typecheck/should_compile/T1470.hs
testsuite/tests/typecheck/should_compile/T2683.hs
testsuite/tests/typecheck/should_compile/T3018.hs
testsuite/tests/typecheck/should_compile/T3108.hs
testsuite/tests/typecheck/should_compile/T3692.hs
testsuite/tests/typecheck/should_compile/T3743.hs
testsuite/tests/typecheck/should_compile/T4361.hs
testsuite/tests/typecheck/should_compile/T4401.hs
testsuite/tests/typecheck/should_compile/T4524.hs
testsuite/tests/typecheck/should_compile/T4952.hs
testsuite/tests/typecheck/should_compile/T4969.hs
testsuite/tests/typecheck/should_compile/T5514.hs
testsuite/tests/typecheck/should_compile/T5581.hs
testsuite/tests/typecheck/should_compile/T5676.hs
testsuite/tests/typecheck/should_compile/T6055.hs
testsuite/tests/typecheck/should_compile/T6134.hs
testsuite/tests/typecheck/should_compile/T7171a.hs
testsuite/tests/typecheck/should_compile/T7196.hs
testsuite/tests/typecheck/should_compile/T7220.hs
testsuite/tests/typecheck/should_compile/T7541.hs
testsuite/tests/typecheck/should_compile/T7875.hs
testsuite/tests/typecheck/should_compile/T7903.hs
testsuite/tests/typecheck/should_compile/T7903.stderr-ghc
testsuite/tests/typecheck/should_compile/Tc170_Aux.hs
testsuite/tests/typecheck/should_compile/Tc173a.hs
testsuite/tests/typecheck/should_compile/tc045.hs
testsuite/tests/typecheck/should_compile/tc051.hs
testsuite/tests/typecheck/should_compile/tc056.stderr
testsuite/tests/typecheck/should_compile/tc058.hs
testsuite/tests/typecheck/should_compile/tc065.hs
testsuite/tests/typecheck/should_compile/tc078.hs
testsuite/tests/typecheck/should_compile/tc078.stderr-ghc
testsuite/tests/typecheck/should_compile/tc079.hs
testsuite/tests/typecheck/should_compile/tc088.hs
testsuite/tests/typecheck/should_compile/tc091.hs
testsuite/tests/typecheck/should_compile/tc092.hs
testsuite/tests/typecheck/should_compile/tc109.hs
testsuite/tests/typecheck/should_compile/tc113.hs
testsuite/tests/typecheck/should_compile/tc115.hs
testsuite/tests/typecheck/should_compile/tc115.stderr-ghc
testsuite/tests/typecheck/should_compile/tc116.hs
testsuite/tests/typecheck/should_compile/tc116.stderr-ghc
testsuite/tests/typecheck/should_compile/tc125.hs
testsuite/tests/typecheck/should_compile/tc125.stderr-ghc
testsuite/tests/typecheck/should_compile/tc126.hs
testsuite/tests/typecheck/should_compile/tc126.stderr-ghc
testsuite/tests/typecheck/should_compile/tc145.hs
testsuite/tests/typecheck/should_compile/tc152.hs
testsuite/tests/typecheck/should_compile/tc176.hs
testsuite/tests/typecheck/should_compile/tc178.hs
testsuite/tests/typecheck/should_compile/tc180.hs
testsuite/tests/typecheck/should_compile/tc181.hs
testsuite/tests/typecheck/should_compile/tc183.hs
testsuite/tests/typecheck/should_compile/tc187.hs
testsuite/tests/typecheck/should_compile/tc192.hs
testsuite/tests/typecheck/should_compile/tc203.hs
testsuite/tests/typecheck/should_compile/tc204.hs
testsuite/tests/typecheck/should_compile/tc206.hs
testsuite/tests/typecheck/should_compile/tc208.hs
testsuite/tests/typecheck/should_compile/tc229.hs
testsuite/tests/typecheck/should_compile/tc230.hs
testsuite/tests/typecheck/should_compile/tc235.hs
testsuite/tests/typecheck/should_compile/tc237.hs
testsuite/tests/typecheck/should_compile/tc239.hs
testsuite/tests/typecheck/should_compile/twins.hs
testsuite/tests/typecheck/should_fail/T6161.stderr
testsuite/tests/typecheck/should_fail/tcfail017.stderr
testsuite/tests/typecheck/should_fail/tcfail020.stderr
testsuite/tests/typecheck/should_fail/tcfail071.hs
testsuite/tests/typecheck/should_fail/tcfail138.hs
testsuite/tests/typecheck/should_fail/tcfail143.stderr

index 99e6de6..f4b7e80 100644 (file)
@@ -125,10 +125,12 @@ type RepArity = Int
 -}
 
 -- | Type of the tags associated with each constructor possibility
+--   or superclass selector
 type ConTag = Int
 
 fIRST_TAG :: ConTag
 -- ^ Tags are allocated from here for real constructors
+--   or for superclass selectors
 fIRST_TAG =  1
 
 {-
index 1a73210..8f5b30e 100644 (file)
@@ -1156,8 +1156,8 @@ collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
 
 add_ev_bndr :: EvBind -> [Id] -> [Id]
-add_ev_bndr (EvBind b _) bs | isId b    = b:bs
-                            | otherwise = bs
+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs
+                                       | otherwise = bs
   -- A worry: what about coercion variable binders??
 
 collectLStmtsBinders :: [LStmt Id body] -> [Id]
index e79c88c..3e91806 100644 (file)
@@ -13,7 +13,7 @@ lower levels it is preserved with @let@/@letrec@s).
 {-# LANGUAGE CPP #-}
 
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                 dsHsWrapper, dsTcEvBinds, dsEvBinds
+                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
   ) where
 
 #include "HsVersions.h"
@@ -137,9 +137,9 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
   | ABE { abe_wrap = wrap, abe_poly = global
         , abe_mono = local, abe_prags = prags } <- export
   = do  { dflags <- getDynFlags
-        ; bind_prs    <- ds_lhs_binds binds
-        ; let   core_bind = Rec (fromOL bind_prs)
-        ; ds_binds <- dsTcEvBinds ev_binds
+        ; bind_prs <- ds_lhs_binds binds
+        ; let core_bind = Rec (fromOL bind_prs)
+        ; ds_binds <- dsTcEvBinds_s ev_binds
         ; rhs <- dsHsWrapper wrap $  -- Usually the identity
                             mkLams tyvars $ mkLams dicts $
                             mkCoreLets ds_binds $
@@ -167,7 +167,7 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
               locals       = map abe_mono exports
               tup_expr     = mkBigCoreVarTup locals
               tup_ty       = exprType tup_expr
-        ; ds_binds <- dsTcEvBinds ev_binds
+        ; ds_binds <- dsTcEvBinds_s ev_binds
         ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
                              mkCoreLets ds_binds $
                              Let core_bind $
@@ -832,6 +832,11 @@ dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e
 dsHsWrapper (WpEvApp    tm)   e = liftM (App e) (dsEvTerm tm)
 
 --------------------------------------
+dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
+dsTcEvBinds_s []       = return []
+dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null
+                         dsTcEvBinds b
+
 dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
 dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
 dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
@@ -839,10 +844,11 @@ dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
 dsEvBinds :: Bag EvBind -> DsM [CoreBind]
 dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
   where
-    ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
-    ds_scc (CyclicSCC bs)            = liftM Rec (mapM ds_pair bs)
+    ds_scc (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = r }))
+                          = liftM (NonRec v) (dsEvTerm r)
+    ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
 
-    ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
+    ds_pair (EvBind { eb_lhs = v, eb_rhs = r }) = liftM ((,) v) (dsEvTerm r)
 
 sccEvBinds :: Bag EvBind -> [SCC EvBind]
 sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
@@ -851,7 +857,8 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
     edges = foldrBag ((:) . mk_node) [] bs
 
     mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
-    mk_node b@(EvBind var term) = (b, var, varSetElems (evVarsOfTerm term))
+    mk_node b@(EvBind { eb_lhs = var, eb_rhs = term })
+       = (b, var, varSetElems (evVarsOfTerm term))
 
 
 ---------------------------------------
@@ -974,7 +981,7 @@ ds_tc_coercion subst tc_co
     ds_co_binds eb@(TcEvBinds {}) = pprPanic "ds_co_binds" (ppr eb)
 
     ds_scc :: CvSubst -> SCC EvBind -> CvSubst
-    ds_scc subst (AcyclicSCC (EvBind v ev_term))
+    ds_scc subst (AcyclicSCC (EvBind { eb_lhs = v, eb_rhs = ev_term }))
       = extendCvSubstAndInScope subst v (ds_co_term subst ev_term)
     ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
 
index d252d91..dbc9a76 100644 (file)
@@ -142,7 +142,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
        ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
                             body1 lbinds
-       ; ds_binds <- dsTcEvBinds ev_binds
+       ; ds_binds <- dsTcEvBinds_s ev_binds
        ; return (mkCoreLets ds_binds body2) }
 
 dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
index ef14fab..82d014b 100644 (file)
@@ -191,8 +191,13 @@ data HsBindLR idL idR
        -- to have the right type
         abs_exports :: [ABExport idL],
 
-        abs_ev_binds :: TcEvBinds,     -- ^ Evidence bindings
-        abs_binds    :: LHsBinds idL   -- ^ Typechecked user bindings
+        -- | Evidence bindings
+        -- Why a list? See TcInstDcls
+        -- Note [Typechecking plan for instance declarations]
+        abs_ev_binds :: [TcEvBinds],
+
+        -- | Typechecked user bindings
+        abs_binds    :: LHsBinds idL
     }
 
   | PatSynBind (PatSynBind idL idR)
index 33be51f..6e14700 100644 (file)
@@ -239,7 +239,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
 
               -- Make selectors for the superclasses
         ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
-                                [1..length sc_theta]
+                                (takeList sc_theta [fIRST_TAG..])
         ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
                            | sc_name <- sc_sel_names]
               -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
index 7cd875f..0b17d61 100644 (file)
@@ -114,7 +114,7 @@ data IfaceDecl
                                                    -- the tycon)
                    ifFamFlav :: IfaceFamTyConFlav }
 
-  | IfaceClass { ifCtxt    :: IfaceContext,             -- Context...
+  | IfaceClass { ifCtxt    :: IfaceContext,             -- Superclasses
                  ifName    :: IfaceTopBndr,             -- Name of the class TyCon
                  ifTyVars  :: [IfaceTvBndr],            -- Type variables
                  ifRoles   :: [Role],                   -- Roles
index 8857925..b8c2bb1 100644 (file)
@@ -467,6 +467,7 @@ data WarningFlag =
 -- See Note [Updating flag description in the User's Guide]
      Opt_WarnDuplicateExports
    | Opt_WarnDuplicateConstraints
+   | Opt_WarnRedundantConstraints
    | Opt_WarnHiShadows
    | Opt_WarnImplicitPrelude
    | Opt_WarnIncompletePatterns
@@ -2825,7 +2826,9 @@ fWarningFlags = [
   flagSpec "warn-dodgy-imports"               Opt_WarnDodgyImports,
   flagSpec "warn-empty-enumerations"          Opt_WarnEmptyEnumerations,
   flagSpec "warn-context-quantification"      Opt_WarnContextQuantification,
-  flagSpec "warn-duplicate-constraints"       Opt_WarnDuplicateConstraints,
+  flagSpec' "warn-duplicate-constraints"      Opt_WarnDuplicateConstraints
+    (\_ -> deprecate "it is subsumed by -fwarn-redundant-constraints"),
+  flagSpec "warn-redundant-constraints"       Opt_WarnRedundantConstraints,
   flagSpec "warn-duplicate-exports"           Opt_WarnDuplicateExports,
   flagSpec "warn-hi-shadowing"                Opt_WarnHiShadows,
   flagSpec "warn-implicit-prelude"            Opt_WarnImplicitPrelude,
@@ -3317,7 +3320,7 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnPartialTypeSignatures,
         Opt_WarnUnrecognisedPragmas,
         Opt_WarnPointlessPragmas,
-        Opt_WarnDuplicateConstraints,
+        Opt_WarnRedundantConstraints,
         Opt_WarnDuplicateExports,
         Opt_WarnOverflowedLiterals,
         Opt_WarnEmptyEnumerations,
index d38f281..6b08822 100644 (file)
@@ -11,6 +11,7 @@ The @Inst@ type: dictionaries or method instances
 module Inst (
        deeplySkolemise, deeplyInstantiate, 
        instCall, instDFunType, instStupidTheta,
+       newWanted, newWanteds,
        emitWanted, emitWanteds,
 
        newOverloadedLit, mkOverLit,
@@ -62,11 +63,22 @@ import Data.Maybe( isJust )
 {-
 ************************************************************************
 *                                                                      *
-                Emitting constraints
+                Creating and emittind constraints
 *                                                                      *
 ************************************************************************
 -}
 
+newWanted :: CtOrigin -> PredType -> TcM CtEvidence
+newWanted orig pty
+  = do loc <- getCtLoc orig
+       v <- newEvVar pty
+       return $ CtWanted { ctev_evar = v
+                         , ctev_pred = pty
+                         , ctev_loc = loc }
+
+newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
+newWanteds orig = mapM (newWanted orig)
+
 emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
 emitWanteds origin theta = mapM (emitWanted origin) theta
 
@@ -75,7 +87,7 @@ emitWanted origin pred
   = do { loc <- getCtLoc origin
        ; ev  <- newEvVar pred
        ; emitSimple $ mkNonCanonical $
-             CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
+         CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
        ; return ev }
 
 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
@@ -634,3 +646,5 @@ tyVarsOfImplic (Implic { ic_skols = skols
 
 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
+
+
index b4bb65d..7d66d16 100644 (file)
@@ -200,7 +200,7 @@ tcHsBootSigs (ValBindsOut binds sigs)
   where
     tc_boot_sig (TypeSig lnames ty _) = mapM f lnames
       where
-        f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+        f (L _ name) = do  { sigma_ty <- tcHsSigType (FunSigCtxt name True) ty
                            ; return (mkVanillaGlobal name sigma_ty) }
         -- Notice that we make GlobalIds, not LocalIds
     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
@@ -552,7 +552,8 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
 ------------------
 tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
                              -- dependencies based on type signatures
-            -> PragFun -> TcSigInfo
+            -> PragFun
+            -> TcSigInfo
             -> LHsBind Name
             -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
 -- There is just one binding,
@@ -561,11 +562,13 @@ tcPolyCheck :: RecFlag       -- Whether it's recursive after breaking
 tcPolyCheck rec_tc prag_fn
             sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
                            , sig_nwcs = sig_nwcs, sig_theta = theta
-                           , sig_tau = tau, sig_loc = loc })
+                           , sig_tau = tau, sig_loc = loc
+                           , sig_warn_redundant = warn_redundant })
             bind
   = ASSERT( null sig_nwcs ) -- We should be in tcPolyInfer if there are wildcards
     do { ev_vars <- newEvVars theta
-       ; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
+       ; let ctxt      = FunSigCtxt (idName poly_id) warn_redundant
+             skol_info = SigSkol ctxt (mkPhiTy theta tau)
              prag_sigs = prag_fn (idName poly_id)
              tvs = map snd tvs_w_scoped
        ; (ev_binds, (binds', [mono_info]))
@@ -583,7 +586,7 @@ tcPolyCheck rec_tc prag_fn
                           , abe_prags = SpecPrags spec_prags }
              abs_bind = L loc $ AbsBinds
                         { abs_tvs = tvs
-                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
+                        , abs_ev_vars = ev_vars, abs_ev_binds = [ev_binds]
                         , abs_exports = [export], abs_binds = binds' }
              closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
                     | otherwise                                     = NotTopLevel
@@ -602,9 +605,8 @@ tcPolyInfer
   -> [LHsBind Name]
   -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
 tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
-  = do { (((binds', mono_infos), tclvl), wanted)
-             <- captureConstraints  $
-                captureTcLevel      $
+  = do { ((binds', mono_infos), tclvl, wanted)
+             <- pushLevelAndCaptureConstraints  $
                 tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
 
        ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
@@ -622,7 +624,7 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
                           | otherwise              = NotTopLevel
              abs_bind = L loc $
                         AbsBinds { abs_tvs = qtvs
-                                 , abs_ev_vars = givens, abs_ev_binds = ev_binds
+                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
                                  , abs_exports = exports, abs_binds = binds' }
 
        ; traceTc "Binding:" (ppr final_closed $$
@@ -922,7 +924,7 @@ tcSpec poly_id prag@(SpecSig fun_name hs_tys inl)
   where
     name      = idName poly_id
     poly_ty   = idType poly_id
-    sig_ctxt  = FunSigCtxt name
+    sig_ctxt  = FunSigCtxt name True
     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
 
 tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
@@ -1395,9 +1397,13 @@ tcTySig (L _ (IdSig id))
        ; return ([sig], []) }
 tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
   = setSrcSpan loc $
-    pushTcLevelM   $
-    do { nwc_tvs <- mapM newWildcardVarMetaKind wcs      -- Generate fresh meta vars for the wildcards
-       ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1) hs_ty
+    pushTcLevelM_  $  -- When instantiating the signature, do so "one level in"
+                      -- so that they can be unified under the forall
+    do {  -- Generate fresh meta vars for the wildcards
+       ; nwc_tvs <- mapM newWildcardVarMetaKind wcs
+
+       ; sigma_ty <- tcExtendTyVarEnv nwc_tvs $ tcHsSigType (FunSigCtxt name1 False) hs_ty
+
        ; sigs <- mapM (instTcTySig hs_ty sigma_ty (extra_cts hs_ty) (zip wcs nwc_tvs))
                       (map unLoc names)
        ; return (sigs, nwc_tvs) }
@@ -1408,7 +1414,7 @@ tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
 tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
   = setSrcSpan loc $
     do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
-       ; let ctxt = FunSigCtxt name
+       ; let ctxt = FunSigCtxt name False
        ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
        { ty' <- tcHsSigType ctxt ty
        ; req' <- tcHsContext req
@@ -1440,12 +1446,18 @@ instTcTySigFromId id
                            , sig_nwcs = []
                            , sig_theta = theta, sig_tau = tau
                            , sig_extra_cts = Nothing
-                           , sig_partial = False }) }
+                           , sig_partial = False
+                           , sig_warn_redundant = False
+                               -- Do not report redundant constraints for
+                               -- instance methods and record selectors
+                 }) }
 
 instTcTySig :: LHsType Name -> TcType    -- HsType and corresponding TcType
             -> Maybe SrcSpan             -- Just loc <=> an extra-constraints
-                                         -- wildcard is present at location loc.
-            -> [(Name, TcTyVar)] -> Name -> TcM TcSigInfo
+                                         --   wildcard is present at location loc.
+            -> [(Name, TcTyVar)]         -- Named wildcards
+            -> Name                      -- Name of the function
+            -> TcM TcSigInfo
 instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
   = do { (inst_tvs, theta, tau) <- tcInstType tcInstSigTyVars sigma_ty
        ; return (TcSigInfo { sig_id  = mkLocalId name sigma_ty
@@ -1454,7 +1466,9 @@ instTcTySig hs_ty@(L loc _) sigma_ty extra_cts nwcs name
                            , sig_nwcs = nwcs
                            , sig_theta = theta, sig_tau = tau
                            , sig_extra_cts = extra_cts
-                           , sig_partial = isJust extra_cts || not (null nwcs) }) }
+                           , sig_partial = isJust extra_cts || not (null nwcs)
+                           , sig_warn_redundant = True
+               }) }
 
 -------------------------------
 data GeneralisationPlan
@@ -1649,6 +1663,6 @@ typeSigCtxt _    (TcPatSynInfo _)
 typeSigCtxt name (TcSigInfo { sig_id = _id, sig_tvs = tvs
                             , sig_theta = theta, sig_tau = tau
                             , sig_extra_cts = extra_cts })
-  = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name) <> colon
+  = sep [ text "In" <+> pprUserTypeCtxt (FunSigCtxt name False) <> colon
         , nest 2 (pprSigmaTypeExtraCts (isJust extra_cts)
                   (mkSigmaTy (map snd tvs) theta tau)) ]
index a5b0d99..65ebfd9 100644 (file)
@@ -27,7 +27,6 @@ import DataCon ( dataConName )
 import Name( isSystemName, nameOccName )
 import OccName( OccName )
 import Outputable
-import Control.Monad
 import DynFlags( DynFlags )
 import VarSet
 import RdrName
@@ -189,7 +188,7 @@ canTuple :: CtEvidence -> [PredType] -> TcS (StopOrContinue Ct)
 canTuple ev preds
   | CtWanted { ctev_evar = evar, ctev_loc = loc } <- ev
   = do { new_evars <- mapM (newWantedEvVar loc) preds
-       ; setEvBind evar (EvTupleMk (map (ctEvTerm . fst) new_evars))
+       ; setWantedEvBind evar (EvTupleMk (map (ctEvTerm . fst) new_evars))
        ; emitWorkNC (freshGoals new_evars)
          -- Note the "NC": these are fresh goals, not necessarily canonical
        ; stopWith ev "Decomposed tuple constraint" }
@@ -485,9 +484,8 @@ can_eq_nc' _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) _
 -- Literals
 can_eq_nc' _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
  | l1 == l2
-  = do { when (isWanted ev) $
-         setEvBind (ctev_evar ev) (EvCoercion $
-                                   mkTcReflCo (eqRelRole eq_rel) ty1)
+  = do { setEvBindIfWanted ev (EvCoercion $
+                               mkTcReflCo (eqRelRole eq_rel) ty1)
        ; stopWith ev "Equal LitTy" }
 
 -- Decomposable type constructor applications
@@ -523,7 +521,7 @@ can_eq_nc' _rdr_env _envs ev eq_rel s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
           do { traceTcS "Creating implication for polytype equality" $ ppr ev
              ; ev_term <- deferTcSForAllEq (eqRelRole eq_rel)
                                            loc (tvs1,body1) (tvs2,body2)
-             ; setEvBind orig_ev ev_term
+             ; setWantedEvBind orig_ev ev_term
              ; stopWith ev "Deferred polytype equality" } }
  | otherwise
  = do { traceTcS "Ommitting decomposition of given polytype equality" $
@@ -704,7 +702,7 @@ try_decompose_nom_app ev ty1 ty2
        = do { ev_s <- newWantedEvVarNC loc (mkTcEqPred s1 s2)
             ; co_t <- unifyWanted loc Nominal t1 t2
             ; let co = mkTcAppCo (ctEvCoercion ev_s) co_t
-            ; setEvBind evar (EvCoercion co)
+            ; setWantedEvBind evar (EvCoercion co)
             ; canEqNC ev_s NomEq s1 s2 }
        | CtGiven { ctev_evtm = ev_tm, ctev_loc = loc } <- ev
        = do { let co   = evTermCoercion ev_tm
@@ -767,7 +765,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
 
      CtWanted { ctev_evar = evar, ctev_loc = loc }
         -> do { cos <- zipWith3M (unifyWanted loc) tc_roles tys1 tys2
-              ; setEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) }
+              ; setWantedEvBind evar (EvCoercion (mkTcTyConAppCo role tc cos)) }
 
      CtGiven { ctev_evtm = ev_tm, ctev_loc = loc }
         -> do { let ev_co = evTermCoercion ev_tm
@@ -1063,9 +1061,8 @@ canEqTyVarTyVar :: CtEvidence           -- tv1 ~ orhs (or orhs ~ tv1, if swapped
 -- See Note [Canonical orientation for tyvar/tyvar equality constraints]
 canEqTyVarTyVar ev eq_rel swapped tv1 tv2 co2
   | tv1 == tv2
-  = do { when (isWanted ev) $
-         ASSERT( tcCoercionRole co2 == eqRelRole eq_rel )
-         setEvBind (ctev_evar ev) (EvCoercion (maybeSym swapped co2))
+  = do { ASSERT( tcCoercionRole co2 == eqRelRole eq_rel )
+         setEvBindIfWanted ev (EvCoercion (maybeSym swapped co2))
        ; stopWith ev "Equal tyvars" }
 
   | incompat_kind   = incompat
@@ -1151,9 +1148,8 @@ canEqReflexive :: CtEvidence    -- ty ~ ty
                -> TcType        -- ty
                -> TcS (StopOrContinue Ct)   -- always Stop
 canEqReflexive ev eq_rel ty
-  = do { when (isWanted ev) $
-         setEvBind (ctev_evar ev) (EvCoercion $
-                                   mkTcReflCo (eqRelRole eq_rel) ty)
+  = do { setEvBindIfWanted ev (EvCoercion $
+                               mkTcReflCo (eqRelRole eq_rel) ty)
        ; stopWith ev "Solved by reflexivity" }
 
 incompatibleKind :: CtEvidence         -- t1~t2
@@ -1485,8 +1481,8 @@ rewriteEvidence ev@(CtGiven { ctev_evtm = old_tm , ctev_loc = loc }) new_pred co
 rewriteEvidence ev@(CtWanted { ctev_evar = evar, ctev_loc = loc }) new_pred co
   = do { (new_ev, freshness) <- newWantedEvVar loc new_pred
        ; MASSERT( tcCoercionRole co == ctEvRole ev )
-       ; setEvBind evar (mkEvCast (ctEvTerm new_ev)
-                           (tcDowngradeRole Representational (ctEvRole ev) co))
+       ; setWantedEvBind evar (mkEvCast (ctEvTerm new_ev)
+                                 (tcDowngradeRole Representational (ctEvRole ev) co))
        ; case freshness of
             Fresh  -> continueWith new_ev
             Cached -> stopWith ev "Cached wanted" }
@@ -1542,7 +1538,7 @@ rewriteEqEvidence old_ev eq_rel swapped nlhs nrhs lhs_co rhs_co
                   mkTcSymCo lhs_co
                   `mkTcTransCo` ctEvCoercion new_evar
                   `mkTcTransCo` rhs_co
-       ; setEvBind evar (EvCoercion co)
+       ; setWantedEvBind evar (EvCoercion co)
        ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
        ; return (ContinueWith new_evar) }
 
index 719c2f3..e113682 100644 (file)
@@ -9,7 +9,7 @@ Typechecking class declarations
 {-# LANGUAGE CPP #-}
 
 module TcClassDcl ( tcClassSigs, tcClassDecl2,
-                    findMethodBind, instantiateMethod, tcInstanceMethodBody,
+                    findMethodBind, instantiateMethod, 
                     tcClassMinimalDef,
                     HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
                     tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
@@ -20,7 +20,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 import HsSyn
 import TcEnv
 import TcPat( addInlinePrags )
-import TcEvidence( HsWrapper, idHsWrapper )
+import TcEvidence( idHsWrapper )
 import TcBinds
 import TcUnify
 import TcHsType
@@ -156,28 +156,35 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
         --      dm1 = \d -> case ds d of (a,b,c) -> a
         -- And since ds is big, it doesn't get inlined, so we don't get good
         -- default methods.  Better to make separate AbsBinds for each
-        ; let
-              (tyvars, _, _, op_items) = classBigSig clas
+        ; let (tyvars, _, _, op_items) = classBigSig clas
               prag_fn     = mkPragFun sigs default_binds
               sig_fn      = mkHsSigFun sigs
               clas_tyvars = snd (tcSuperSkolTyVars tyvars)
               pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
         ; this_dict <- newEvVar pred
 
-        ; traceTc "TIM2" (ppr sigs)
-        ; let tc_dm = tcDefMeth clas clas_tyvars
-                                this_dict default_binds
-                                sig_fn prag_fn
+        ; let tc_item (sel_id, dm_info)
+                = case dm_info of
+                    DefMeth dm_name    -> tc_dm sel_id dm_name False
+                    GenDefMeth dm_name -> tc_dm sel_id dm_name True
+                       -- For GenDefMeth, warn if the user specifies a signature
+                       -- with redundant constraints; but not for DefMeth, where
+                       -- the default method may well be 'error' or something
+                    NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id))
+                                                     (prag_fn (idName sel_id))
+                                             ; return emptyBag }
+              tc_dm = tcDefMeth clas clas_tyvars this_dict
+                                default_binds sig_fn prag_fn
 
         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
-                      mapM tc_dm op_items
+                      mapM tc_item op_items
 
         ; return (unionManyBags dm_binds) }
 
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
 
 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-          -> HsSigFun -> PragFun -> ClassOpItem
+          -> HsSigFun -> PragFun -> Id -> Name -> Bool
           -> TcM (LHsBinds TcId)
 -- Generate code for polymorphic default methods only (hence DefMeth)
 -- (Generic default methods have turned into instance decls by now.)
@@ -185,78 +192,62 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
 -- default method for every class op, regardless of whether or not
 -- the programmer supplied an explicit default decl for the class.
 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
-  = case dm_info of
-      NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
-                               ; return emptyBag }
-      DefMeth dm_name    -> tc_dm dm_name
-      GenDefMeth dm_name -> tc_dm dm_name
-  where
-    sel_name           = idName sel_id
-    prags              = prag_fn sel_name
-    (dm_bind,bndr_loc) = findMethodBind sel_name binds_in
-                         `orElse` pprPanic "tcDefMeth" (ppr sel_id)
-
-    -- Eg.   class C a where
-    --          op :: forall b. Eq b => a -> [b] -> a
-    --          gen_op :: a -> a
-    --          generic gen_op :: D a => a -> a
-    -- The "local_dm_ty" is precisely the type in the above
-    -- type signatures, ie with no "forall a. C a =>" prefix
-
-    tc_dm dm_name
-      = do { dm_id <- tcLookupId dm_name
-           ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
-             -- Base the local_dm_name on the selector name, because
-             -- type errors from tcInstanceMethodBody come from here
-
-           ; dm_id_w_inline <- addInlinePrags dm_id prags
-           ; spec_prags     <- tcSpecPrags dm_id prags
-
-           ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
-                 hs_ty       = lookupHsSig hs_sig_fn sel_name
-                               `orElse` pprPanic "tc_dm" (ppr sel_name)
-
-           ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
-           ; warnTc (not (null spec_prags))
-                    (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
-                     <+> quotes (ppr sel_name))
-
-           ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
-                                             dm_id_w_inline local_dm_sig idHsWrapper
-                                             IsDefaultMethod dm_bind
-
-           ; return (unitBag tc_bind) }
-
----------------
-tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-                     -> Id -> TcSigInfo
-                     -> HsWrapper  -- See Note [Instance method signatures] in TcInstDcls
-                     -> TcSpecPrags -> LHsBind Name
-                     -> TcM (LHsBind Id)
-tcInstanceMethodBody skol_info tyvars dfun_ev_vars
-                     meth_id local_meth_sig wrapper
-                     specs (L loc bind)
-  = do  { let local_meth_id = case local_meth_sig of
-                  TcSigInfo{ sig_id = meth_id } -> meth_id
-                  _ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
-              lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
+tcDefMeth clas tyvars this_dict binds_in
+          hs_sig_fn prag_fn sel_id dm_name warn_redundant
+  | Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
+    -- First look up the default method -- it should be there!
+  = do { global_dm_id  <- tcLookupId dm_name
+       ; global_dm_id  <- addInlinePrags global_dm_id prags
+       ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
+            -- Base the local_dm_name on the selector name, because
+            -- type errors from tcInstanceMethodBody come from here
+
+       ; spec_prags <- tcSpecPrags global_dm_id prags
+       ; warnTc (not (null spec_prags))
+                (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
+                 <+> quotes (ppr sel_name))
+
+       ; let hs_ty       = lookupHsSig hs_sig_fn sel_name
+                           `orElse` pprPanic "tc_dm" (ppr sel_name)
+             -- We need the HsType so that we can bring the right
+             -- type variables into scope
+             --
+             -- Eg.   class C a where
+             --          op :: forall b. Eq b => a -> [b] -> a
+             --          gen_op :: a -> a
+             --          generic gen_op :: D a => a -> a
+             -- The "local_dm_ty" is precisely the type in the above
+             -- type signatures, ie with no "forall a. C a =>" prefix
+
+             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
+
+             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }
                              -- Substitute the local_meth_name for the binder
                              -- NB: the binding is always a FunBind
-        ; (ev_binds, (tc_bind, _, _))
-               <- checkConstraints skol_info tyvars dfun_ev_vars $
-                  tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
 
-        ; let export = ABE { abe_wrap = wrapper, abe_poly = meth_id
-                           , abe_mono = local_meth_id, abe_prags = specs }
+       ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
+       ; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant }
+        ; (ev_binds, (tc_bind, _, _))
+               <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
+                  tcPolyCheck NonRecursive no_prag_fn local_dm_sig'
+                              (L bind_loc lm_bind)
+
+        ; let export = ABE { abe_poly  = global_dm_id
+                           , abe_mono  = sig_id local_dm_sig'
+                           , abe_wrap  = idHsWrapper
+                           , abe_prags = IsDefaultMethod }
               full_bind = AbsBinds { abs_tvs      = tyvars
-                                   , abs_ev_vars  = dfun_ev_vars
+                                   , abs_ev_vars  = [this_dict]
                                    , abs_exports  = [export]
-                                   , abs_ev_binds = ev_binds
+                                   , abs_ev_binds = [ev_binds]
                                    , abs_binds    = tc_bind }
 
-        ; return (L loc full_bind) }
+        ; return (unitBag (L bind_loc full_bind)) }
+
+  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
   where
+    sel_name = idName sel_id
+    prags    = prag_fn sel_name
     no_prag_fn  _ = []          -- No pragmas for local_meth_id;
                                 -- they are all for meth_id
 
index 960b03f..10191ae 100644 (file)
@@ -1857,7 +1857,7 @@ simplifyDeriv pred tvs theta
              skol_set   = mkVarSet tvs_skols
              doc = ptext (sLit "deriving") <+> parens (ppr pred)
 
-       ; wanted <- mapM (\(PredOrigin t o) -> newSimpleWanted o (substTy skol_subst t)) theta
+       ; wanted <- mapM (\(PredOrigin t o) -> newWanted o (substTy skol_subst t)) theta
 
        ; traceTc "simplifyDeriv" $
          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
index 23cc048..d9b6fc7 100644 (file)
@@ -42,6 +42,7 @@ import DynFlags
 import StaticFlags      ( opt_PprStyle_Debug )
 import ListSetOps       ( equivClasses )
 
+import Control.Monad    ( when )
 import Data.Maybe
 import Data.List        ( partition, mapAccumL, nub, sortBy )
 
@@ -133,6 +134,7 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
   = return ()
   | otherwise
   = do { traceTc "reportUnsolved (before unflattening)" (ppr wanted)
+       ; warn_redundant <- woptM Opt_WarnRedundantConstraints
 
        ; env0 <- tcInitTidyEnv
 
@@ -146,6 +148,7 @@ report_unsolved mb_binds_var defer_errors expr_holes type_holes wanted
                             , cec_expr_holes = expr_holes
                             , cec_type_holes = type_holes
                             , cec_suppress = False -- See Note [Suppressing error messages]
+                            , cec_warn_redundant = warn_redundant
                             , cec_binds    = mb_binds_var }
 
        ; traceTc "reportUnsolved (after unflattening):" $
@@ -181,6 +184,8 @@ data ReportErrCtxt
           , cec_expr_holes :: HoleChoice  -- Holes in expressions
           , cec_type_holes :: HoleChoice  -- Holes in types
 
+          , cec_warn_redundant :: Bool    -- True <=> -fwarn-redundant-constraints
+
           , cec_suppress :: Bool    -- True <=> More important errors have occurred,
                                     --          so create bindings if need be, but
                                     --          don't issue any more errors/warnings
@@ -204,15 +209,20 @@ Specifically (see reportWanteds)
 reportImplic :: ReportErrCtxt -> Implication -> TcM ()
 reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                                  , ic_wanted = wanted, ic_binds = evb
-                                 , ic_insol = ic_insoluble, ic_info = info })
+                                 , ic_status = status, ic_info = info
+                                 , ic_env = tcl_env })
   | BracketSkol <- info
-  , not ic_insoluble -- For Template Haskell brackets report only
-  = return ()        -- definite errors. The whole thing will be re-checked
+  , not (isInsolubleStatus status)
+  = return ()        -- For Template Haskell brackets report only
+                     -- definite errors. The whole thing will be re-checked
                      -- later when we plug it in, and meanwhile there may
                      -- certainly be un-satisfied constraints
 
   | otherwise
-  = reportWanteds ctxt' wanted
+  = do { reportWanteds ctxt' wanted
+       ; traceTc "reportImplic" (ppr implic)
+       ; when (cec_warn_redundant ctxt) $
+         warnRedundantConstraints ctxt' tcl_env info' dead_givens }
   where
     (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs
     (env2, info') = tidySkolemInfo env1 info
@@ -224,40 +234,65 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given
                  , cec_binds = case cec_binds ctxt of
                                  Nothing -> Nothing
                                  Just {} -> Just evb }
+    dead_givens = case status of
+                    IC_Solved { ics_dead = dead } -> dead
+                    _                             -> []
+
+warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
+warnRedundantConstraints ctxt env info ev_vars
+ | null ev_vars
+ = return ()
+
+ | SigSkol {} <- info
+ = setLclEnv env $  -- We want to add "In the type signature for f"
+                    -- to the error context, which is a bit tiresome
+   addErrCtxt (ptext (sLit "In") <+> ppr info) $
+   do { env <- getLclEnv
+      ; msg <- mkErrorMsg ctxt env doc
+      ; reportWarning msg }
+
+ | otherwise  -- But for InstSkol there already *is* a surrounding
+              -- "In the instance declaration for Eq [a]" context
+              -- and we don't want to say it twice. Seems a bit ad-hoc
+ = do { msg <- mkErrorMsg ctxt env doc
+      ; reportWarning msg }
+ where
+   doc = ptext (sLit "Redundant constraint") <> plural ev_vars <> colon
+         <+> pprEvVarTheta ev_vars
 
 reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
-reportWanteds ctxt wanted@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
-  = do { reportSimples ctxt  (mapBag (tidyCt env) insol_given)
-       ; reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted)
-       ; reportSimples ctxt2 (mapBag (tidyCt env) simples)
+reportWanteds ctxt (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
+  = do { ctxt1 <- reportSimples ctxt  (mapBag (tidyCt env) insol_given)
+       ; ctxt2 <- reportSimples ctxt1 (mapBag (tidyCt env) insol_wanted)
+
+         -- For the simple wanteds, suppress them if there are any
+         -- insolubles in the tree, to avoid unnecessary clutter
+       ; let ctxt2' = ctxt { cec_suppress = cec_suppress ctxt2
+                                         || anyBag insolubleImplic implics }
+       ; _ <- reportSimples ctxt2'  (mapBag (tidyCt env) simples)
+
             -- All the Derived ones have been filtered out of simples
             -- 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 ctxt1) implics }
             -- NB ctxt1: don't suppress inner insolubles if there's only a
-            -- wanted insoluble here; but do suppress inner insolubles
-            -- if there's a given insoluble here (= inaccessible code)
+            -- *wanted* insoluble here; but do suppress inner insolubles
+            -- if there's a *given* insoluble here (= inaccessible code)
  where
-    (insol_given, insol_wanted) = partitionBag isGivenCt insols
     env = cec_tidy ctxt
+    (insol_given, insol_wanted) = partitionBag isGivenCt insols
 
-      -- See Note [Suppressing error messages]
-    suppress0 = cec_suppress ctxt
-    suppress1 = suppress0 || not (isEmptyBag insol_given)
-    suppress2 = suppress0 || insolubleWC wanted
-    ctxt1     = ctxt { cec_suppress = suppress1 }
-    ctxt2     = ctxt { cec_suppress = suppress2 }
-
-reportSimples :: ReportErrCtxt -> Cts -> TcM ()
+reportSimples :: ReportErrCtxt -> Cts -> TcM ReportErrCtxt
 reportSimples ctxt simples    -- Here 'simples' includes insolble goals
   =  traceTc "reportSimples" (vcat [ ptext (sLit "Simples =") <+> ppr simples
                                    , ptext (sLit "Suppress =") <+> ppr (cec_suppress ctxt)])
-  >> tryReporters
+  >> tryReporters ctxt
       [ -- First deal with things that are utterly wrong
         -- Like Int ~ Bool (incl nullary TyCons)
         -- or  Int ~ t a   (AppTy on one side)
-        ("Utterly wrong",  utterly_wrong,   True,  mkGroupReporter mkEqErr)
+        ("Utterly wrong (given)",  utterly_wrong_given, True,  mkGroupReporter mkEqErr)
+      , ("Utterly wrong (other)",  utterly_wrong_other, True,  mkGroupReporter mkEqErr)
       , ("Holes",          is_hole,         False, mkHoleReporter)
 
         -- Report equalities of form (a~ty).  They are usually
@@ -272,15 +307,19 @@ reportSimples ctxt simples    -- Here 'simples' includes insolble goals
       , ("Irreds",          is_irred,    False, mkGroupReporter mkIrredErr)
       , ("Dicts",           is_dict,     False, mkGroupReporter mkDictErr)
       ]
-      panicReporter ctxt (bagToList simples)
+      (bagToList simples)
           -- TuplePreds should have been expanded away by the constraint
           -- simplifier, so they shouldn't show up at this point
   where
-    utterly_wrong, skolem_eq, is_hole, is_dict,
+    utterly_wrong_given, utterly_wrong_other, skolem_eq, is_hole, is_dict,
       is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
 
-    utterly_wrong _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2
-    utterly_wrong _ _ = False
+    utterly_wrong_given ct (EqPred _ ty1 ty2)
+      | isGivenCt ct = isRigid ty1 && isRigid ty2
+    utterly_wrong_given _ _ = False
+
+    utterly_wrong_other _ (EqPred _ ty1 ty2) = isRigid ty1 && isRigid ty2
+    utterly_wrong_other _ _ = False
 
     is_hole ct _ = isHoleCt ct
 
@@ -330,11 +369,6 @@ type ReporterSpec
     , Bool                       -- True <=> suppress subsequent reporters
     , Reporter)                  -- The reporter itself
 
-panicReporter :: Reporter
-panicReporter _ cts
-  | null cts  = return ()
-  | otherwise =  pprPanic "reportSimples" (ppr cts)
-
 mkSkolReporter :: Reporter
 -- Suppress duplicates with the same LHS
 mkSkolReporter ctxt cts
@@ -418,7 +452,7 @@ addDeferredBinding ctxt err ct
                        err_msg $$ text "(deferred type error)"
 
          -- Create the binding
-       ; addTcEvBind ev_binds_var ev_id (EvDelayedError pred err_fs) }
+       ; addTcEvBind ev_binds_var (mkWantedEvBind ev_id (EvDelayedError pred err_fs)) }
 
   | otherwise   -- Do not set any evidence for Given/Derived
   = return ()
@@ -441,14 +475,18 @@ maybeAddDeferredBinding ctxt err ct
     | otherwise
     = return ()
 
-tryReporters :: [ReporterSpec] -> Reporter -> Reporter
+tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM ReportErrCtxt
 -- Use the first reporter in the list whose predicate says True
-tryReporters reporters deflt ctxt cts
+tryReporters ctxt reporters cts
   = do { traceTc "tryReporters {" (ppr cts)
-       ; go ctxt reporters cts
-       ; traceTc "tryReporters }" empty }
+       ; ctxt' <- go ctxt reporters cts
+       ; traceTc "tryReporters }" empty
+       ; return ctxt' }
   where
-    go ctxt [] cts = deflt ctxt cts
+    go ctxt [] cts
+      | null cts  = return ctxt
+      | otherwise = pprPanic "tryReporters" (ppr cts)
+
     go ctxt ((str, pred, suppress_after, reporter) : rs) cts
       | null yeses  = do { traceTc "tryReporters: no" (text str)
                          ; go ctxt rs cts }
@@ -487,10 +525,13 @@ pprWithArising (ct:cts)
     ppr_one ct' = hang (parens (pprType (ctPred ct')))
                      2 (pprArisingAt (ctLoc ct'))
 
-mkErrorMsg :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
-mkErrorMsg ctxt ct msg
-  = do { let tcl_env = ctLocEnv (ctLoc ct)
-       ; err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> SDoc -> TcM ErrMsg
+mkErrorMsgFromCt ctxt ct msg
+  = mkErrorMsg ctxt (ctLocEnv (ctLoc ct)) msg
+
+mkErrorMsg :: ReportErrCtxt -> TcLclEnv -> SDoc -> TcM ErrMsg
+mkErrorMsg ctxt tcl_env msg
+  = do { err_info <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
        ; mkLongErrAt (RealSrcSpan (tcl_loc tcl_env)) msg err_info }
 
 type UserGiven = ([EvVar], SkolemInfo, Bool, RealSrcSpan)
@@ -572,16 +613,16 @@ solve it.
 
 
 ************************************************************************
-*                  *
+*                                                                      *
                 Irreducible predicate errors
-*                  *
+*                                                                      *
 ************************************************************************
 -}
 
 mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkIrredErr ctxt cts
-  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct1
-       ; mkErrorMsg ctxt ct1 (msg $$ binds_msg) }
+  = do { (ctxt, binds_msg, _) <- relevantBindings True ctxt ct1
+       ; mkErrorMsgFromCt ctxt ct1 (msg $$ binds_msg) }
   where
     (ct1:_) = cts
     orig    = ctLocOrigin (ctLoc ct1)
@@ -597,9 +638,9 @@ mkHoleError ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort })
                              2 (ptext (sLit "with type:") <+> pprType (ctEvPred (ctEvidence ct)))
                         , ppUnless (null tyvars_msg) (ptext (sLit "Where:") <+> vcat tyvars_msg)
                         , pts_hint ]
-       ; (ctxt, binds_doc) <- relevantBindings False ctxt ct
+       ; (ctxt, binds_doc, _) <- relevantBindings False ctxt ct
                -- The 'False' means "don't filter the bindings"; see Trac #8191
-       ; mkErrorMsg ctxt ct (msg $$ binds_doc) }
+       ; mkErrorMsgFromCt ctxt ct (msg $$ binds_doc) }
   where
     pts_hint
       | TypeHole  <- hole_sort
@@ -621,8 +662,8 @@ mkHoleError _ ct = pprPanic "mkHoleError" (ppr ct)
 ----------------
 mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
 mkIPErr ctxt cts
-  = do { (ctxt, bind_msg) <- relevantBindings True ctxt ct1
-       ; mkErrorMsg ctxt ct1 (msg $$ bind_msg) }
+  = do { (ctxt, bind_msg, _) <- relevantBindings True ctxt ct1
+       ; mkErrorMsgFromCt ctxt ct1 (msg $$ bind_msg) }
   where
     (ct1:_) = cts
     orig    = ctLocOrigin (ctLoc ct1)
@@ -671,7 +712,7 @@ mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
 -- Wanted constraints only!
 mkEqErr1 ctxt ct
   | isGiven ev
-  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
+  = do { (ctxt, binds_msg, _) <- relevantBindings True ctxt ct
        ; let (given_loc, given_msg) = mk_given (cec_encl ctxt)
        ; dflags <- getDynFlags
        ; mkEqErr_help dflags ctxt (given_msg $$ binds_msg)
@@ -679,8 +720,7 @@ mkEqErr1 ctxt ct
                       Nothing ty1 ty2 }
 
   | otherwise   -- Wanted or derived
-  = do { (ctxt, binds_msg) <- relevantBindings True ctxt ct
-       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
+  = do { (ctxt, binds_msg, tidy_orig) <- relevantBindings True ctxt ct
        ; rdr_env <- getGlobalRdrEnv
        ; fam_envs <- tcGetFamInstEnvs
        ; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
@@ -689,8 +729,7 @@ mkEqErr1 ctxt ct
                ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
        ; dflags <- getDynFlags
        ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
-       ; mkEqErr_help dflags (ctxt {cec_tidy = env1})
-                      (wanted_msg $$ coercible_msg $$ binds_msg)
+       ; mkEqErr_help dflags ctxt (wanted_msg $$ coercible_msg $$ binds_msg)
                       ct is_oriented ty1 ty2 }
   where
     ev         = ctEvidence ct
@@ -818,8 +857,8 @@ reportEqErr :: ReportErrCtxt -> SDoc
             -> TcType -> TcType -> TcM ErrMsg
 reportEqErr ctxt extra1 ct oriented ty1 ty2
   = do { let extra2 = mkEqInfoMsg ct ty1 ty2
-       ; mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
-                                   , extra2, extra1]) }
+       ; mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
+                                        , extra2, extra1]) }
 
 mkTyVarEqErr :: DynFlags -> ReportErrCtxt -> SDoc -> Ct
              -> Maybe SwapFlag -> TcTyVar -> TcType -> TcM ErrMsg
@@ -829,29 +868,29 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
                             -- be oriented the other way round;
                             -- see TcCanonical.canEqTyVarTyVar
   || isSigTyVar tv1 && not (isTyVarTy ty2)
-  = mkErrorMsg ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
-                             , extraTyVarInfo ctxt tv1 ty2
-                             , extra ])
+  = mkErrorMsgFromCt ctxt ct (vcat [ misMatchOrCND ctxt ct oriented ty1 ty2
+                                   , extraTyVarInfo ctxt tv1 ty2
+                                   , extra ])
 
   -- So tv is a meta tyvar (or started that way before we
   -- generalised it).  So presumably it is an *untouchable*
   -- meta tyvar or a SigTv, else it'd have been unified
   | not (k2 `tcIsSubKind` k1)            -- Kind error
-  = mkErrorMsg ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
+  = mkErrorMsgFromCt ctxt ct $ (kindErrorMsg (mkTyVarTy tv1) ty2 $$ extra)
 
   | OC_Occurs <- occ_check_expand
   , NomEq <- ctEqRel ct      -- reporting occurs check for Coercible is strange
   = do { let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:")
                               2 (sep [ppr ty1, char '~', ppr ty2])
              extra2 = mkEqInfoMsg ct ty1 ty2
-       ; mkErrorMsg ctxt ct (occCheckMsg $$ extra2 $$ extra) }
+       ; mkErrorMsgFromCt ctxt ct (occCheckMsg $$ extra2 $$ extra) }
 
   | OC_Forall <- occ_check_expand
   = do { let msg = vcat [ ptext (sLit "Cannot instantiate unification variable")
                           <+> quotes (ppr tv1)
                         , hang (ptext (sLit "with a type involving foralls:")) 2 (ppr ty2)
                         , nest 2 (ptext (sLit "Perhaps you want ImpredicativeTypes")) ]
-       ; mkErrorMsg ctxt ct msg }
+       ; mkErrorMsgFromCt ctxt ct msg }
 
   -- If the immediately-enclosing implication has 'tv' a skolem, and
   -- we know by now its an InferSkol kind of skolem, then presumably
@@ -860,9 +899,9 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
   | (implic:_) <- cec_encl ctxt
   , Implic { ic_skols = skols } <- implic
   , tv1 `elem` skols
-  = mkErrorMsg ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2
-                             , extraTyVarInfo ctxt tv1 ty2
-                             , extra ])
+  = mkErrorMsgFromCt ctxt ct (vcat [ misMatchMsg oriented eq_rel ty1 ty2
+                                   , extraTyVarInfo ctxt tv1 ty2
+                                   , extra ])
 
   -- Check for skolem escape
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
@@ -882,7 +921,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
                                <+> ptext (sLit "bound by")
                              , nest 2 $ ppr skol_info
                              , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ] ]
-       ; mkErrorMsg ctxt ct (msg $$ tv_extra $$ extra) }
+       ; mkErrorMsgFromCt ctxt ct (msg $$ tv_extra $$ extra) }
 
   -- Nastiest case: attempt to unify an untouchable variable
   | (implic:_) <- cec_encl ctxt   -- Get the innermost context
@@ -896,7 +935,7 @@ mkTyVarEqErr dflags ctxt extra ct oriented tv1 ty2
                       , nest 2 $ ptext (sLit "at") <+> ppr (tcl_loc env) ]
              tv_extra = extraTyVarInfo ctxt tv1 ty2
              add_sig  = suggestAddSig ctxt ty1 ty2
-       ; mkErrorMsg ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
+       ; mkErrorMsgFromCt ctxt ct (vcat [msg, tclvl_extra, tv_extra, add_sig, extra]) }
 
   | otherwise
   = reportEqErr ctxt extra ct oriented (mkTyVarTy tv1) ty2
@@ -1166,7 +1205,7 @@ mkDictErr ctxt cts
        -- have the same source-location origin, to try avoid a cascade
        -- of error from one location
        ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
-       ; mkErrorMsg ctxt ct1 err }
+       ; mkErrorMsgFromCt ctxt ct1 err }
   where
     no_givens = null (getUserGivens ctxt)
 
@@ -1198,7 +1237,7 @@ mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
 mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
   | null matches  -- No matches but perhaps several unifiers
   = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
-       ; (ctxt, binds_msg) <- relevantBindings True ctxt ct
+       ; (ctxt, binds_msg, _) <- relevantBindings True ctxt ct
        ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
        ; return (ctxt, cannot_resolve_msg is_ambig binds_msg ambig_msg) }
 
@@ -1348,15 +1387,22 @@ usefulContext ctxt pred
     pred_tvs = tyVarsOfType pred
     go [] = []
     go (ic : ics)
-       = case ic_info ic of
-               -- Do not suggest adding constraints to an *inferred* type signature!
-           SigSkol (InfSigCtxt {}) _ -> rest
-           info                      -> info : rest
+       | implausible ic = rest
+       | otherwise      = ic_info ic : rest
        where
           -- Stop when the context binds a variable free in the predicate
           rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
                | otherwise                                 = go ics
 
+    implausible ic
+      | null (ic_skols ic)            = True
+      | implausible_info (ic_info ic) = True
+      | otherwise                     = False
+
+    implausible_info (SigSkol (InfSigCtxt {}) _) = True
+    implausible_info _                           = False
+    -- Do not suggest adding constraints to an *inferred* type signature!
+
 show_fixes :: [SDoc] -> SDoc
 show_fixes []     = empty
 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
@@ -1493,17 +1539,31 @@ getSkolemInfo (implic:implics) tv
 relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
                           -- See Trac #8191
                  -> ReportErrCtxt -> Ct
-                 -> TcM (ReportErrCtxt, SDoc)
+                 -> TcM (ReportErrCtxt, SDoc, CtOrigin)
+-- Also returns the zonked and tidied CtOrigin of the constraint
 relevantBindings want_filtering ctxt ct
   = do { dflags <- getDynFlags
+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
+       ; let ct_tvs    = tyVarsOfCt ct `unionVarSet` extra_tvs
+
+             -- For *kind* errors, report the relevant bindings of the
+             -- enclosing *type* equality, because that's more useful for the programmer
+             extra_tvs = case tidy_orig of
+                             KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
+                             _                    -> emptyVarSet
+       ; traceTc "relevantBindings" $
+           vcat [ ppr ct
+                , pprCtOrigin (ctLocOrigin loc)
+                , ppr ct_tvs
+                , ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env] ]
+
        ; (tidy_env', docs, discards)
-              <- go (cec_tidy ctxt) (maxRelevantBinds dflags)
+              <- go env1 ct_tvs (maxRelevantBinds dflags)
                     emptyVarSet [] False
                     (tcl_bndrs lcl_env)
          -- tcl_bndrs has the innermost bindings first,
          -- which are probably the most relevant ones
 
-       ; traceTc "relevantBindings" (ppr ct $$ ppr [id | TcIdBndr id _ <- tcl_bndrs lcl_env])
        ; let doc = hang (ptext (sLit "Relevant bindings include"))
                       2 (vcat docs $$ max_msg)
              max_msg | discards
@@ -1511,19 +1571,11 @@ relevantBindings want_filtering ctxt ct
                      | otherwise = empty
 
        ; if null docs
-         then return (ctxt, empty)
-         else do { traceTc "rb" doc
-                 ; return (ctxt { cec_tidy = tidy_env' }, doc) } }
+         then return (ctxt,                          empty, tidy_orig)
+         else return (ctxt { cec_tidy = tidy_env' }, doc,   tidy_orig) }
   where
     loc       = ctLoc ct
     lcl_env   = ctLocEnv loc
-    ct_tvs    = tyVarsOfCt ct `unionVarSet` extra_tvs
-
-    -- For *kind* errors, report the relevant bindings of the
-    -- enclosing *type* equality, because that's more useful for the programmer
-    extra_tvs = case ctLocOrigin loc of
-                  KindEqOrigin t1 t2 _ -> tyVarsOfTypes [t1,t2]
-                  _                    -> emptyVarSet
 
     run_out :: Maybe Int -> Bool
     run_out Nothing = False
@@ -1532,14 +1584,14 @@ relevantBindings want_filtering ctxt ct
     dec_max :: Maybe Int -> Maybe Int
     dec_max = fmap (\n -> n - 1)
 
-    go :: TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]
+    go :: TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
        -> Bool                          -- True <=> some filtered out due to lack of fuel
        -> [TcIdBinder]
        -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
                                         -- because of lack of fuel
-    go tidy_env _ _ docs discards []
+    go tidy_env _ _ docs discards []
        = return (tidy_env, reverse docs, discards)
-    go tidy_env n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
+    go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
        = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
             ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
             ; let id_tvs = tyVarsOfType tidy_ty
@@ -1552,30 +1604,30 @@ relevantBindings want_filtering ctxt ct
                                  && id_tvs `disjointVarSet` ct_tvs)
                        -- We want to filter out this binding anyway
                        -- so discard it silently
-              then go tidy_env n_left tvs_seen docs discards tc_bndrs
+              then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
 
               else if isTopLevel top_lvl && not (isNothing n_left)
                        -- It's a top-level binding and we have not specified
                        -- -fno-max-relevant-bindings, so discard it silently
-              then go tidy_env n_left tvs_seen docs discards tc_bndrs
+              then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
 
               else if run_out n_left && id_tvs `subVarSet` tvs_seen
                        -- We've run out of n_left fuel and this binding only
                        -- mentions aleady-seen type variables, so discard it
-              then go tidy_env n_left tvs_seen docs True tc_bndrs
+              then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
 
                        -- Keep this binding, decrement fuel
-              else go tidy_env' (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
+              else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
 
 -----------------------
-warnDefaulting :: Cts -> Type -> TcM ()
+warnDefaulting :: [Ct] -> Type -> TcM ()
 warnDefaulting wanteds default_ty
   = do { warn_default <- woptM Opt_WarnTypeDefaults
        ; env0 <- tcInitTidyEnv
        ; let tidy_env = tidyFreeTyVars env0 $
-                        tyVarsOfCts wanteds
-             tidy_wanteds = mapBag (tidyCt tidy_env) wanteds
-             (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds)
+                        foldr (unionVarSet . tyVarsOfCt) emptyVarSet wanteds
+             tidy_wanteds = map (tidyCt tidy_env) wanteds
+             (loc, ppr_wanteds) = pprWithArising tidy_wanteds
              warn_msg  = hang (ptext (sLit "Defaulting the following constraint(s) to type")
                                 <+> quotes (ppr default_ty))
                             2 ppr_wanteds
index 552a403..ca819c3 100644 (file)
@@ -11,8 +11,9 @@ module TcEvidence (
 
   -- Evidence bindings
   TcEvBinds(..), EvBindsVar(..),
-  EvBindMap(..), emptyEvBindMap, extendEvBinds, lookupEvBind, evBindMapBinds,
-  EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds,
+  EvBindMap(..), emptyEvBindMap, extendEvBinds, 
+                 lookupEvBind, evBindMapBinds, foldEvBindMap,
+  EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind,
   EvTerm(..), mkEvCast, evVarsOfTerm,
   EvLit(..), evTermCoercion,
 
@@ -446,10 +447,10 @@ coVarsOfTcCo tc_co
 
     -- We expect only coercion bindings, so use evTermCoercion
     go_bind :: EvBind -> VarSet
-    go_bind (EvBind _ tm) = go (evTermCoercion tm)
+    go_bind (EvBind { eb_rhs =tm }) = go (evTermCoercion tm)
 
     get_bndrs :: Bag EvBind -> VarSet
-    get_bndrs = foldrBag (\ (EvBind b _) bs -> extendVarSet bs b) emptyVarSet
+    get_bndrs = foldrBag (\ (EvBind { eb_lhs = b }) bs -> extendVarSet bs b) emptyVarSet
 
 -- Pretty printing
 
@@ -665,20 +666,35 @@ newtype EvBindMap
 emptyEvBindMap :: EvBindMap
 emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyVarEnv }
 
-extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
-extendEvBinds bs v t
-  = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs) v (EvBind v t) }
+extendEvBinds :: EvBindMap -> EvBind -> EvBindMap
+extendEvBinds bs ev_bind
+  = EvBindMap { ev_bind_varenv = extendVarEnv (ev_bind_varenv bs)
+                                              (eb_lhs ev_bind)
+                                              ev_bind }
 
 lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
 lookupEvBind bs = lookupVarEnv (ev_bind_varenv bs)
 
 evBindMapBinds :: EvBindMap -> Bag EvBind
-evBindMapBinds bs
-  = foldVarEnv consBag emptyBag (ev_bind_varenv bs)
+evBindMapBinds = foldEvBindMap consBag emptyBag
+
+foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a
+foldEvBindMap k z bs = foldVarEnv k z (ev_bind_varenv bs)
 
 -----------------
 -- All evidence is bound by EvBinds; no side effects
-data EvBind = EvBind EvVar EvTerm
+data EvBind
+  = EvBind { eb_lhs      :: EvVar
+           , eb_rhs      :: EvTerm
+           , eb_is_given :: Bool  -- True <=> given
+                 -- See Note [Tracking redundant constraints] in TcSimplify
+    }
+
+mkWantedEvBind :: EvVar -> EvTerm -> EvBind
+mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm }
+
+mkGivenEvBind :: EvVar -> EvTerm -> EvBind
+mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm }
 
 data EvTerm
   = EvId EvId                    -- Any sort of evidence Id, including coercions
@@ -888,7 +904,11 @@ instance Outputable EvBindsVar where
   ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
 
 instance Outputable EvBind where
-  ppr (EvBind v e)   = sep [ ppr v, nest 2 $ equals <+> ppr e ]
+  ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given })
+     = sep [ pp_gw <+> ppr v
+           , nest 2 $ equals <+> ppr e ]
+     where
+       pp_gw = brackets (if is_given then ptext (sLit "[G]") else ptext (sLit "[W]"))
    -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
 
 instance Outputable EvTerm where
index 3e13a00..2a76023 100644 (file)
@@ -1531,8 +1531,7 @@ unflatten tv_eqs funeqs
       = do { ty1 <- zonkTcTyVar tv
            ; ty2 <- zonkTcType rhs
            ; let is_refl = ty1 `tcEqType` ty2
-           ; if is_refl then do { when (isWanted ev) $
-                                  setEvBind (ctEvId ev)
+           ; if is_refl then do { setEvBindIfWanted ev
                                             (EvCoercion $
                                              mkTcReflCo (eqRelRole eq_rel) rhs)
                                 ; return rest }
@@ -1563,8 +1562,7 @@ tryFill dflags tv rhs ev
     do { rhs' <- zonkTcType rhs
        ; case occurCheckExpand dflags tv rhs' of
            OC_OK rhs''    -- Normal case: fill the tyvar
-             -> do { when (isWanted ev) $
-                     setEvBind (ctEvId ev)
+             -> do { setEvBindIfWanted ev
                                (EvCoercion (mkTcReflCo (ctEvRole ev) rhs''))
                    ; setWantedTyBind tv rhs''
                    ; return True }
index ee97ee8..27ba99b 100644 (file)
@@ -462,7 +462,7 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
   = ASSERT( all isImmutableTyVar tyvars )
     do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
-       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
          do { let env3 = extendIdZonkEnv env2 (collectHsBindsBinders new_val_binds)
             ; new_val_binds <- zonkMonoBinds env3 noSigWarn val_binds
@@ -1254,11 +1254,17 @@ zonkEvTerm env (EvDelayedError ty msg)
   = do { ty' <- zonkTcTypeToType env ty
        ; return (EvDelayedError ty' msg) }
 
+zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
+                            ; return (env, [EvBinds (unionManyBags bs')]) }
+
 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
-zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
-                                       ; return (env', EvBinds bs') }
-zonkTcEvBinds env (EvBinds bs)    = do { (env', bs') <- zonkEvBinds env bs
-                                       ; return (env', EvBinds bs') }
+zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
+                          ; return (env', EvBinds bs') }
+
+zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
+zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
+zonk_tc_ev_binds env (EvBinds bs)    = zonkEvBinds env bs
 
 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
 zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
@@ -1274,22 +1280,21 @@ zonkEvBinds env binds
   where
     collect_ev_bndrs :: Bag EvBind -> [EvVar]
     collect_ev_bndrs = foldrBag add []
-    add (EvBind var _) vars = var : vars
+    add (EvBind { eb_lhs = var }) vars = var : vars
 
 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
-zonkEvBind env (EvBind var term)
+zonkEvBind env (EvBind { eb_lhs = var, eb_rhs = term, eb_is_given = is_given })
   = do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
 
          -- Optimise the common case of Refl coercions
          -- See Note [Optimise coercion zonking]
          -- This has a very big effect on some programs (eg Trac #5030)
-       ; let ty' = idType var'
-
-       ; case getEqPredTys_maybe ty' of
+       ; term' <- case getEqPredTys_maybe (idType var') of
            Just (r, ty1, ty2) | ty1 `eqType` ty2
-                  -> return (EvBind var' (EvCoercion (mkTcReflCo r ty1)))
-           _other -> do { term' <- zonkEvTerm env term
-                        ; return (EvBind var' term') } }
+                  -> return (EvCoercion (mkTcReflCo r ty1))
+           _other -> zonkEvTerm env term
+
+      ; return (EvBind { eb_lhs = var', eb_rhs = term', eb_is_given = is_given }) }
 
 {-
 ************************************************************************
index c8746ff..ced063d 100644 (file)
@@ -17,7 +17,7 @@ import TcBinds
 import TcTyClsDecls
 import TcClassDcl( tcClassDecl2,
                    HsSigFun, lookupHsSig, mkHsSigFun,
-                   findMethodBind, instantiateMethod, tcInstanceMethodBody )
+                   findMethodBind, instantiateMethod )
 import TcPat      ( addInlinePrags )
 import TcRnMonad
 import TcValidity
@@ -60,7 +60,7 @@ import Util
 import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
 
 import Control.Monad
-import Maybes     ( isNothing, isJust, whenIsJust )
+import Maybes     ( isNothing, isJust, whenIsJust, catMaybes )
 import Data.List  ( mapAccumL, partition )
 
 {-
@@ -817,29 +817,53 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
     do {  -- Instantiate the instance decl with skolem constants
        ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
+       ; dfun_ev_vars <- newEvVars dfun_theta
                      -- We instantiate the dfun_id with superSkolems.
                      -- See Note [Subtle interaction of recursion and overlap]
                      -- and Note [Binding when looking up instances]
+
        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
 
-       ; dfun_ev_vars <- newEvVars dfun_theta
-
        ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
-       ; fam_envs <- tcGetFamInstEnvs
-       ; (sc_ids, sc_binds) <- tcSuperClasses fam_envs loc clas inst_tyvars 
-                                              dfun_ev_vars sc_theta' inst_tys
 
-       -- Deal with 'SPECIALISE instance' pragmas
-       -- See Note [SPECIALISE instance pragmas]
+                      -- Deal with 'SPECIALISE instance' pragmas
+                      -- See Note [SPECIALISE instance pragmas]
        ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
 
-        -- Typecheck the methods
-       ; (meth_ids, meth_binds)
-           <- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
-                                inst_tys spec_inst_info
-                                op_items ibinds
+         -- Typecheck superclasses and methods
+         -- See Note [Typechecking plan for instance declarations]
+       ; dfun_ev_binds_var <- newTcEvBinds
+       ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
+       ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl)
+             <- pushTcLevelM $
+                do { fam_envs <- tcGetFamInstEnvs
+                   ; (sc_ids, sc_binds, sc_implics)
+                        <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
+                                          inst_tys dfun_ev_binds fam_envs
+                                          sc_theta'
+
+                      -- Typecheck the methods
+                   ; (meth_ids, meth_binds, meth_implics)
+                        <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
+                                     inst_tys dfun_ev_binds spec_inst_info
+                                     op_items ibinds
+
+                   ; return ( sc_ids     ++          meth_ids
+                            , sc_binds   `unionBags` meth_binds
+                            , sc_implics `unionBags` meth_implics ) }
+
+       ; env <- getLclEnv
+       ; emitImplication $ Implic { ic_tclvl  = tclvl
+                                  , ic_skols  = inst_tyvars
+                                  , ic_no_eqs = False
+                                  , ic_given  = dfun_ev_vars
+                                  , ic_wanted = addImplics emptyWC sc_meth_implics
+                                  , ic_status = IC_Unsolved
+                                  , ic_binds  = dfun_ev_binds_var
+                                  , ic_env    = env
+                                  , ic_info   = InstSkol }
 
        -- Create the result bindings
        ; self_dict <- newDict clas inst_tys
@@ -858,8 +882,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                      --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
              con_app_tys  = wrapId (mkWpTyApps inst_tys)
                                    (dataConWrapId dict_constr)
---              con_app_scs  = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
-             con_app_args = foldl app_to_meth con_app_tys (sc_ids ++ meth_ids)
+             con_app_args = foldl app_to_meth con_app_tys sc_meth_ids
 
              app_to_meth :: HsExpr Id -> Id -> HsExpr Id
              app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
@@ -881,102 +904,78 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
              main_bind = AbsBinds { abs_tvs = inst_tyvars
                                   , abs_ev_vars = dfun_ev_vars
                                   , abs_exports = [export]
-                                  , abs_ev_binds = emptyTcEvBinds
+                                  , abs_ev_binds = []
                                   , abs_binds = unitBag dict_bind }
 
-       ; return (unitBag (L loc main_bind) `unionBags`
-                 listToBag meth_binds      `unionBags`
-                 listToBag sc_binds)
+       ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
        }
  where
    dfun_id = instanceDFunId ispec
    loc     = getSrcSpan dfun_id
 
-----------------------
-mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
-          -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper)
-mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
-  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)
-        ; local_meth_name <- newName sel_occ
-                  -- Base the local_meth_name on the selector name, because
-                  -- type errors from tcInstanceMethodBody come from here
-        ; let poly_meth_id  = mkLocalId poly_meth_name  poly_meth_ty
-              local_meth_id = mkLocalId local_meth_name local_meth_ty
+wrapId :: HsWrapper -> id -> HsExpr id
+wrapId wrapper id = mkHsWrap wrapper (HsVar id)
 
-        ; case lookupHsSig sig_fn sel_name of
-            Just lhs_ty  -- There is a signature in the instance declaration
-                         -- See Note [Instance method signatures]
-               -> setSrcSpan (getLoc lhs_ty) $
-                  do { inst_sigs <- xoptM Opt_InstanceSigs
-                     ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
-                     ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name) lhs_ty
-                     ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty
-                     ; tc_sig  <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name
-                     ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $
-                                  tcSubType (FunSigCtxt sel_name) poly_sig_ty poly_meth_ty
-                     ; return (poly_meth_id, tc_sig, hs_wrap) }
+{- Note [Typechecking plan for instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For intance declarations we generate the following bindings and implication
+constraints.  Example:
 
-            Nothing     -- No type signature
-               -> do { tc_sig <- instTcTySigFromId local_meth_id
-                     ; return (poly_meth_id, tc_sig, idHsWrapper) } }
-              -- Absent a type sig, there are no new scoped type variables here
-              -- Only the ones from the instance decl itself, which are already
-              -- in scope.  Example:
-              --      class C a where { op :: forall b. Eq b => ... }
-              --      instance C [c] where { op = <rhs> }
-              -- In <rhs>, 'c' is scope but 'b' is not!
-  where
-    sel_name      = idName sel_id
-    sel_occ       = nameOccName sel_name
-    local_meth_ty = instantiateMethod clas sel_id inst_tys
-    poly_meth_ty  = mkSigmaTy tyvars theta local_meth_ty
-    theta         = map idType dfun_ev_vars
+   instance Ord a => Ord [a] where compare = <compare-rhs>
 
-methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
-methSigCtxt sel_name sig_ty meth_ty env0
-  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty
-       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
-       ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name))
-                      2 (vcat [ ptext (sLit "is more general than its signature in the class")
-                              , ptext (sLit "Instance sig:") <+> ppr sig_ty
-                              , ptext (sLit "   Class sig:") <+> ppr meth_ty ])
-       ; return (env2, msg) }
+generates this:
 
-misplacedInstSig :: Name -> LHsType Name -> SDoc
-misplacedInstSig name hs_ty
-  = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
-              2 (hang (pprPrefixName name)
-                    2 (dcolon <+> ppr hs_ty))
-         , ptext (sLit "(Use InstanceSigs to allow this)") ]
+   Bindings:
+      -- Method bindings
+      $ccompare :: forall a. Ord a => a -> a -> Ordering
+      $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
 
-{-
-Note [Instance method signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With -XInstanceSigs we allow the user to supply a signature for the
-method in an instance declaration.  Here is an artificial example:
+      -- Superclass bindings
+      $cp1Ord :: forall a. Ord a => Eq [a]
+      $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
+               in dfEqList (dw :: Eq a)
 
-       data Age = MkAge Int
-       instance Ord Age where
-         compare :: a -> a -> Bool
-         compare = error "You can't compare Ages"
+   Constraints:
+      forall a. Ord a =>
+                -- Method constraint
+             (forall. (empty) => <constraints from compare-rhs>)
+                -- Superclass constraint
+          /\ (forall. (empty) => dw :: Eq a)
 
-The instance signature can be *more* polymorphic than the instantiated
-class method (in this case: Age -> Age -> Bool), but it cannot be less
-polymorphic.  Moreover, if a signature is given, the implementation
-code should match the signature, and type variables bound in the
-singature should scope over the method body.
+Notice that
 
-We achieve this by building a TcSigInfo for the method, whether or not
-there is an instance method signature, and using that to typecheck
-the declaration (in tcInstanceMethodBody).  That means, conveniently,
-that the type variables bound in the signature will scope over the body.
+ * Per-meth/sc implication.  There is one inner implication per
+   superclass or method, with no skolem variables or givens.  The only
+   reason for this one is to gather the evidence bindings privately
+   for this superclass or method.  This implication is generated
+   by checkInstConstraints.
 
-What about the check that the instance method signature is more
-polymorphic than the instantiated class method type?  We just do a
-tcSubType call in mkMethIds, and use the HsWrapper thus generated in
-the method AbsBind.  It's very like the tcSubType impedence-matching
-call in mkExport.  We have to pass the HsWrapper into
-tcInstanceMethodBody.
+ * Overall instance implication. There is an overall enclosing
+   implication for the whole instance declaratation, with the expected
+   skolems and givens.  We need this to get the correct "redundant
+   constraint" warnings, gathering all the uses from all the methods
+   and superclasses.  See TcSimplify Note [Tracking redundant
+   constraints]
+
+ * The given constraints in the outer implication may generate
+   evidence, notably by superclass selection.  Since the method and
+   superclass bindings are top-level, we want that evidence copied
+   into *every* method or superclass definition.  (Some of it will
+   be usused in some, but dead-code elimination will drop it.)
+
+   We achieve this by putting the the evidence variable for the overall
+   instance implicaiton into the AbsBinds for each method/superclass.
+   Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
+   (And that in turn is why the abs_ev_binds field of AbBinds is a
+   [TcEvBinds] rather than simply TcEvBinds.
+
+   This is a bit of a hack, but works very nicely in practice.
+
+ * Note that if a method has a locally-polymorhic binding, there will
+   be yet another implication for that, generated by tcPolyCheck
+   in tcMethodBody. E.g.
+          class C a where
+            foo :: forall b. Ord b => blah
 
 
 ************************************************************************
@@ -986,22 +985,24 @@ tcInstanceMethodBody.
 ************************************************************************
 -}
 
-tcSuperClasses :: FamInstEnvs -> SrcSpan
-               -> Class -> [TcTyVar] -> [EvVar]
-               -> TcThetaType -> [TcType]
-               -> TcM ([EvVar], [LHsBind Id])
+tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
+               -> TcEvBinds -> FamInstEnvs
+               -> TcThetaType
+               -> TcM ([EvVar], LHsBinds Id, Bag Implication)
 -- Make a new top-level function binding for each superclass,
 -- something like
---    $Ordp0 :: forall a. Ord a => Eq [a]
---    $Ordp0 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
+--    $Ordp1 :: forall a. Ord a => Eq [a]
+--    $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
 --
 -- See Note [Recursive superclasses] for why this is so hard!
 -- In effect, be build a special-purpose solver for the first step
 -- of solving each superclass constraint
-tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys
+tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds fam_envs sc_theta
   = do { traceTc "tcSuperClasses" (ppr cls $$ ppr inst_tys $$ ppr given_cls_preds)
-       ; mapAndUnzipM tc_super (zip sc_theta [0..]) }
+       ; (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
+       ; return (ids, listToBag binds, listToBag implics) }
   where
+    loc     = getSrcSpan dfun_id
     head_size = sizeTypes inst_tys
 
     ------------
@@ -1043,8 +1044,8 @@ tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys
 
     ------------
     tc_super (sc_pred, n)
-      = do { (ev_binds, sc_ev_id) <- checkScConstraints InstSkol tyvars dfun_evs $
-                                     emit_sc_pred fam_envs sc_pred
+      = do { (sc_implic, sc_ev_id) <- checkInstConstraints $
+                                      emit_sc_pred fam_envs sc_pred
 
            ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
            ; let sc_top_ty = mkForAllTys tyvars (mkPiTypes dfun_evs sc_pred)
@@ -1052,35 +1053,39 @@ tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys
                  export = ABE { abe_wrap = idHsWrapper, abe_poly = sc_top_id
                               , abe_mono = sc_ev_id
                               , abe_prags = SpecPrags [] }
+                 local_ev_binds = TcEvBinds (ic_binds sc_implic)
                  bind = AbsBinds { abs_tvs      = tyvars
                                  , abs_ev_vars  = dfun_evs
                                  , abs_exports  = [export]
-                                 , abs_ev_binds = ev_binds
+                                 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
                                  , abs_binds    = emptyBag }
-           ; return (sc_top_id, L loc bind) }
+           ; return (sc_top_id, L loc bind, sc_implic) }
 
     -------------------
     emit_sc_pred fam_envs sc_pred ev_binds
       | (sc_co, norm_sc_pred) <- normaliseType fam_envs Nominal sc_pred
                                  -- sc_co :: sc_pred ~ norm_sc_pred
       , ClassPred cls tys <- classifyPredType norm_sc_pred
-      = do { (ok, sc_ev_tm) <- emit_sc_cls_pred norm_sc_pred cls tys
+      = do { sc_ev_tm <- emit_sc_cls_pred norm_sc_pred cls tys
            ; sc_ev_id <- newEvVar sc_pred
            ; let tc_co = TcCoercion (mkSubCo (mkSymCo sc_co))
-           ; addTcEvBind ev_binds sc_ev_id (mkEvCast sc_ev_tm tc_co)
-           ; return (ok, sc_ev_id) }
+           ; addTcEvBind ev_binds (mkWantedEvBind sc_ev_id (mkEvCast sc_ev_tm tc_co))
+               -- This is where we set the evidence for the superclass, and do so
+               -- (very unusually) *outside the solver*.  That's why
+               -- checkInstConstraints passes in the evidence bindings
+           ; return sc_ev_id }
 
       | otherwise
       = do { sc_ev_id <- emitWanted ScOrigin sc_pred
            ; traceTc "tcSuperClass 4" (ppr sc_pred $$ ppr sc_ev_id)
-           ; return (True, sc_ev_id) }
+           ; return sc_ev_id }
 
     -------------------
     emit_sc_cls_pred sc_pred cls tys
       | (ev_tm:_) <- [ ev_tm | (ev_tm, ev_ty) <- given_cls_preds
                              , ev_ty `tcEqType` sc_pred ]
       = do { traceTc "tcSuperClass 1" (ppr sc_pred $$ ppr ev_tm)
-           ; return (True, ev_tm) }
+           ; return ev_tm }
 
       | otherwise
       = do { inst_envs <- tcGetInstEnvs
@@ -1091,12 +1096,40 @@ tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys
                        ; arg_evs  <- emitWanteds ScOrigin inst_theta
                        ; let dict_app = EvDFunApp dfun_id inst_tys (map EvId arg_evs)
                        ; traceTc "tcSuperClass 2" (ppr sc_pred $$ ppr dict_app)
-                       ; return (True, dict_app) }
-
-               _ -> do { sc_ev_id <- emitWanted ScOrigin sc_pred
-                       ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev_id)
-                       ; return (False, EvId sc_ev_id) } }
-
+                       ; return dict_app }
+
+               _ -> -- No instance, so we want to report an error
+                    -- Emitting it as an 'insoluble' prevents the solver
+                    -- attempting to solve it (which might, wrongly, succeed)
+                    do { sc_ev <- newWanted ScOrigin sc_pred
+                       ; emitInsoluble (mkNonCanonical sc_ev)
+                       ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev)
+                       ; return (ctEvTerm sc_ev) } }
+
+-------------------
+checkInstConstraints :: (EvBindsVar -> TcM result)
+                     -> TcM (Implication, result)
+-- See Note [Typechecking plan for instance declarations]
+-- The thing_inside is also passed the EvBindsVar,
+-- so that emit_sc_pred can add evidence for the superclass
+-- (not used for methods)
+checkInstConstraints thing_inside
+  = do { ev_binds_var <- newTcEvBinds
+       ; env <- getLclEnv
+       ; (result, tclvl, wanted) <- pushLevelAndCaptureConstraints  $
+                                    thing_inside ev_binds_var
+
+       ; let implic = Implic { ic_tclvl  = tclvl
+                             , ic_skols  = []
+                             , ic_no_eqs = False
+                             , ic_given  = []
+                             , ic_wanted = wanted
+                             , ic_status = IC_Unsolved
+                             , ic_binds  = ev_binds_var
+                             , ic_env    = env
+                             , ic_info   = InstSkol }
+
+       ; return (implic, result) }
 
 {-
 Note [Recursive superclasses]
@@ -1246,94 +1279,8 @@ that were in the original instance declaration.
 
 DFun types are built (only) by MkId.mkDictFunId, so that is where we
 decide what silent arguments are to be added.
-
-
-************************************************************************
-*                                                                      *
-        Specialise instance pragmas
-*                                                                      *
-************************************************************************
-
-Note [SPECIALISE instance pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-   instance (Ix a, Ix b) => Ix (a,b) where
-     {-# SPECIALISE instance Ix (Int,Int) #-}
-     range (x,y) = ...
-
-We make a specialised version of the dictionary function, AND
-specialised versions of each *method*.  Thus we should generate
-something like this:
-
-  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
-  {-# DFUN [$crangePair, ...] #-}
-  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
-  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
-
-  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
-  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
-  $crange da db = <blah>
-
-The SPECIALISE pragmas are acted upon by the desugarer, which generate
-
-  dii :: Ix Int
-  dii = ...
-
-  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
-  {-# DFUN [$crangePair di di, ...] #-}
-  $s$dfIxPair = Ix ($crangePair di di) (...)
-
-  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
-
-  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
-  $c$crangePair = ...specialised RHS of $crangePair...
-
-  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
-
-Note that
-
-  * The specialised dictionary $s$dfIxPair is very much needed, in case we
-    call a function that takes a dictionary, but in a context where the
-    specialised dictionary can be used.  See Trac #7797.
-
-  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
-    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
-
-  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
-       --> {ClassOp rule for range}     $crangePair Int Int d1 d2
-       --> {SPEC rule for $crangePair}  $s$crangePair
-    or thus:
-       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
-       --> {ClassOpRule for range}      $s$crangePair
-    It doesn't matter which way.
-
-  * We want to specialise the RHS of both $dfIxPair and $crangePair,
-    but the SAME HsWrapper will do for both!  We can call tcSpecPrag
-    just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
 -}
 
-tcSpecInstPrags :: DFunId -> InstBindings Name
-                -> TcM ([Located TcSpecPrag], PragFun)
-tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
-  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
-                            filter isSpecInstLSig uprags
-             -- The filter removes the pragmas for methods
-       ; return (spec_inst_prags, mkPragFun uprags binds) }
-
-------------------------------
-tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
-tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
-  = addErrCtxt (spec_ctxt prag) $
-    do  { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
-        ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
-        ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty
-        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
-  where
-    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
-
-tcSpecInst _  _ = panic "tcSpecInst"
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1341,7 +1288,7 @@ tcSpecInst _  _ = panic "tcSpecInst"
 *                                                                      *
 ************************************************************************
 
-tcInstanceMethod
+tcMethod
 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
 - Remembering to use fresh Name (the instance method Name) as the binder
 - Bring the instance method Ids into scope, for the benefit of tcInstSig
@@ -1350,76 +1297,65 @@ tcInstanceMethod
 - Use tcValBinds to do the checking
 -}
 
-tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
-                  -> [EvVar]
-                  -> [TcType]
-                  -> ([Located TcSpecPrag], PragFun)
-                  -> [(Id, DefMeth)]
-                  -> InstBindings Name
-                  -> TcM ([Id], [LHsBind Id])
+tcMethods :: DFunId -> Class
+          -> [TcTyVar] -> [EvVar]
+          -> [TcType]
+          -> TcEvBinds
+          -> ([Located TcSpecPrag], PragFun)
+          -> [(Id, DefMeth)]
+          -> InstBindings Name
+          -> TcM ([Id], LHsBinds Id, Bag Implication)
         -- The returned inst_meth_ids all have types starting
         --      forall tvs. theta => ...
-tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-                  (spec_inst_prags, prag_fn)
-                  op_items (InstBindings { ib_binds = binds
-                                         , ib_tyvars = lexical_tvs
-                                         , ib_pragmas = sigs
-                                         , ib_extensions = exts
-                                         , ib_derived    = is_derived })
+tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+                  dfun_ev_binds prags@(spec_inst_prags,_) op_items
+                  (InstBindings { ib_binds      = binds
+                                , ib_tyvars     = lexical_tvs
+                                , ib_pragmas    = sigs
+                                , ib_extensions = exts
+                                , ib_derived    = is_derived })
   = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
        -- The lexical_tvs scope over the 'where' part
     do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
-       ; let hs_sig_fn = mkHsSigFun sigs
        ; checkMinimalDefinition
-       ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }
+       ; (ids, binds, mb_implics) <- set_exts exts $
+                                     mapAndUnzip3M tc_item op_items
+       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
   where
     set_exts :: [ExtensionFlag] -> TcM a -> TcM a
     set_exts es thing = foldr setXOptM thing es
 
-    ----------------------
-    tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
-    tc_item sig_fn (sel_id, dm_info)
-      = case findMethodBind (idName sel_id) binds of
-            Just (user_bind, bndr_loc)
-                     -> tc_body sig_fn sel_id user_bind bndr_loc
-            Nothing  -> do { traceTc "tc_def" (ppr sel_id)
-                           ; tc_default sig_fn sel_id dm_info }
+    hs_sig_fn = mkHsSigFun sigs
+    inst_loc  = getSrcSpan dfun_id
 
     ----------------------
-    tc_body :: HsSigFun -> Id -> LHsBind Name
-            -> SrcSpan -> TcM (TcId, LHsBind Id)
-    tc_body sig_fn sel_id rn_bind bndr_loc
-      = add_meth_ctxt sel_id rn_bind $
-        do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
-           ; (meth_id, local_meth_sig, hs_wrap)
-                  <- setSrcSpan bndr_loc $
-                     mkMethIds sig_fn clas tyvars dfun_ev_vars
-                               inst_tys sel_id
-           ; let prags = prag_fn (idName sel_id)
-           ; meth_id1 <- addInlinePrags meth_id prags
-           ; spec_prags <- tcSpecPrags meth_id1 prags
-           ; bind <- tcInstanceMethodBody InstSkol
-                          tyvars dfun_ev_vars
-                          meth_id1 local_meth_sig hs_wrap
-                          (mk_meth_spec_prags meth_id1 spec_prags)
-                          rn_bind
-           ; return (meth_id1, bind) }
+    tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id, Maybe Implication)
+    tc_item (sel_id, dm_info)
+      | Just (user_bind, bndr_loc) <- findMethodBind (idName sel_id) binds
+      = tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                              dfun_ev_binds is_derived hs_sig_fn prags
+                              sel_id user_bind bndr_loc
+      | otherwise
+      = do { traceTc "tc_def" (ppr sel_id)
+           ; tc_default sel_id dm_info }
 
     ----------------------
-    tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id)
+    tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id, Maybe Implication)
 
-    tc_default sig_fn sel_id (GenDefMeth dm_name)
+    tc_default sel_id (GenDefMeth dm_name)
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
-           ; tc_body sig_fn sel_id meth_bind inst_loc }
+           ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                                  dfun_ev_binds is_derived hs_sig_fn prags
+                                  sel_id meth_bind inst_loc }
 
-    tc_default sig_fn sel_id NoDefMeth     -- No default method at all
+    tc_default sel_id NoDefMeth     -- No default method at all
       = do { traceTc "tc_def: warn" (ppr sel_id)
-           ; (meth_id, _, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
+           ; (meth_id, _, _) <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars
                                           inst_tys sel_id
            ; dflags <- getDynFlags
-           ; return (meth_id,
-                     mkVarBind meth_id $
-                       mkLHsWrap lam_wrapper (error_rhs dflags)) }
+           ; let meth_bind = mkVarBind meth_id $
+                             mkLHsWrap lam_wrapper (error_rhs dflags)
+           ; return (meth_id, meth_bind, Nothing) }
       where
         error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
         error_fun    = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
@@ -1429,7 +1365,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
         error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ])
         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
 
-    tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
+    tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
       = do {     -- Build the typechecked version directly,
                  -- without calling typecheck_method;
                  -- see Note [Default methods in instances]
@@ -1439,11 +1375,11 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                  -- you to apply a function to a dictionary *expression*.
 
            ; self_dict <- newDict clas inst_tys
-           ; let self_ev_bind = EvBind self_dict
-                                (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
+           ; let self_ev_bind = mkWantedEvBind self_dict
+                                   (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
 
            ; (meth_id, local_meth_sig, hs_wrap)
-                   <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
+                   <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
            ; dm_id <- tcLookupId dm_name
            ; let dm_inline_prag = idInlinePragma dm_id
                  rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
@@ -1458,56 +1394,191 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
 
                  export = ABE { abe_wrap = hs_wrap, abe_poly = meth_id1
                               , abe_mono = local_meth_id
-                              , abe_prags = mk_meth_spec_prags meth_id1 [] }
+                              , abe_prags = mk_meth_spec_prags meth_id1 spec_inst_prags [] }
                  bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
                                  , abs_exports = [export]
-                                 , abs_ev_binds = EvBinds (unitBag self_ev_bind)
+                                 , abs_ev_binds = [EvBinds (unitBag self_ev_bind)]
                                  , abs_binds    = unitBag meth_bind }
              -- Default methods in an instance declaration can't have their own
              -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
              -- currently they are rejected with
              --           "INLINE pragma lacks an accompanying binding"
 
-           ; return (meth_id1, L inst_loc bind) }
+           ; return (meth_id1, L inst_loc bind, Nothing) }
 
     ----------------------
-    mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
-        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
-        -- There are two sources:
-        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
-        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
-        --     These ones have the dfun inside, but [perhaps surprisingly]
-        --     the correct wrapper.
-    mk_meth_spec_prags meth_id spec_prags_for_me
-      = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
+    -- Check if one of the minimal complete definitions is satisfied
+    checkMinimalDefinition
+      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
+          warnUnsatisifiedMinimalDefinition
       where
-        spec_prags_from_inst
-           | isInlinePragma (idInlinePragma meth_id)
-           = []  -- Do not inherit SPECIALISE from the instance if the
-                 -- method is marked INLINE, because then it'll be inlined
-                 -- and the specialisation would do nothing. (Indeed it'll provoke
-                 -- a warning from the desugarer
-           | otherwise
-           = [ L inst_loc (SpecPrag meth_id wrap inl)
-             | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
-
-    inst_loc = getSrcSpan dfun_id
+      methodExists meth = isJust (findMethodBind meth binds)
 
+------------------------
+tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
+             -> TcEvBinds -> Bool
+             -> HsSigFun
+             -> ([LTcSpecPrag], PragFun)
+             -> Id -> LHsBind Name -> SrcSpan
+             -> TcM (TcId, LHsBind Id, Maybe Implication)
+tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                     dfun_ev_binds is_derived
+                     sig_fn (spec_inst_prags, prag_fn)
+                     sel_id (L bind_loc meth_bind) bndr_loc
+  = add_meth_ctxt $
+    do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id))
+       ; (global_meth_id, local_meth_sig, hs_wrap)
+              <- setSrcSpan bndr_loc $
+                 mkMethIds sig_fn clas tyvars dfun_ev_vars
+                           inst_tys sel_id
+
+       ; let prags         = prag_fn (idName sel_id)
+             local_meth_id = sig_id local_meth_sig
+             lm_bind       = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
+                             -- Substitute the local_meth_name for the binder
+                             -- NB: the binding is always a FunBind
+
+       ; global_meth_id <- addInlinePrags global_meth_id prags
+       ; spec_prags     <- tcSpecPrags global_meth_id prags
+       ; (meth_implic, (tc_bind, _, _))
+               <- checkInstConstraints $ \ _ev_binds ->
+                  tcPolyCheck NonRecursive no_prag_fn local_meth_sig
+                              (L bind_loc lm_bind)
+
+        ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
+              export = ABE { abe_poly  = global_meth_id
+                           , abe_mono  = local_meth_id
+                           , abe_wrap  = hs_wrap
+                           , abe_prags = specs }
+
+              local_ev_binds = TcEvBinds (ic_binds meth_implic)
+              full_bind = AbsBinds { abs_tvs      = tyvars
+                                   , abs_ev_vars  = dfun_ev_vars
+                                   , abs_exports  = [export]
+                                   , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
+                                   , abs_binds    = tc_bind }
+
+        ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
+  where
         -- For instance decls that come from deriving clauses
         -- we want to print out the full source code if there's an error
         -- because otherwise the user won't see the code at all
-    add_meth_ctxt sel_id rn_bind thing
-      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
+    add_meth_ctxt thing
+      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
       | otherwise  = thing
 
-    ----------------------
+    no_prag_fn  _ = []          -- No pragmas for local_meth_id;
+                                -- they are all for meth_id
+
+
+------------------------
+mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
+          -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper)
+mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
+  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)
+        ; local_meth_name <- newName sel_occ
+                  -- Base the local_meth_name on the selector name, because
+                  -- type errors from tcMethodBody come from here
+        ; let poly_meth_id  = mkLocalId poly_meth_name  poly_meth_ty
+              local_meth_id = mkLocalId local_meth_name local_meth_ty
+
+        ; case lookupHsSig sig_fn sel_name of
+            Just lhs_ty  -- There is a signature in the instance declaration
+                         -- See Note [Instance method signatures]
+               -> setSrcSpan (getLoc lhs_ty) $
+                  do { inst_sigs <- xoptM Opt_InstanceSigs
+                     ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
+                     ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name True) lhs_ty
+                     ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty
+                     ; tc_sig  <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name
+                     ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $
+                                  tcSubType (FunSigCtxt sel_name False) poly_sig_ty poly_meth_ty
+                     ; return (poly_meth_id, tc_sig, hs_wrap) }
+
+            Nothing     -- No type signature
+               -> do { tc_sig <- instTcTySigFromId local_meth_id
+                     ; return (poly_meth_id, tc_sig, idHsWrapper) } }
+              -- Absent a type sig, there are no new scoped type variables here
+              -- Only the ones from the instance decl itself, which are already
+              -- in scope.  Example:
+              --      class C a where { op :: forall b. Eq b => ... }
+              --      instance C [c] where { op = <rhs> }
+              -- In <rhs>, 'c' is scope but 'b' is not!
+  where
+    sel_name      = idName sel_id
+    sel_occ       = nameOccName sel_name
+    local_meth_ty = instantiateMethod clas sel_id inst_tys
+    poly_meth_ty  = mkSigmaTy tyvars theta local_meth_ty
+    theta         = map idType dfun_ev_vars
+
+methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
+methSigCtxt sel_name sig_ty meth_ty env0
+  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty
+       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
+       ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name))
+                      2 (vcat [ ptext (sLit "is more general than its signature in the class")
+                              , ptext (sLit "Instance sig:") <+> ppr sig_ty
+                              , ptext (sLit "   Class sig:") <+> ppr meth_ty ])
+       ; return (env2, msg) }
+
+misplacedInstSig :: Name -> LHsType Name -> SDoc
+misplacedInstSig name hs_ty
+  = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
+              2 (hang (pprPrefixName name)
+                    2 (dcolon <+> ppr hs_ty))
+         , ptext (sLit "(Use InstanceSigs to allow this)") ]
+
+{-
+Note [Instance method signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XInstanceSigs we allow the user to supply a signature for the
+method in an instance declaration.  Here is an artificial example:
+
+       data Age = MkAge Int
+       instance Ord Age where
+         compare :: a -> a -> Bool
+         compare = error "You can't compare Ages"
+
+The instance signature can be *more* polymorphic than the instantiated
+class method (in this case: Age -> Age -> Bool), but it cannot be less
+polymorphic.  Moreover, if a signature is given, the implementation
+code should match the signature, and type variables bound in the
+singature should scope over the method body.
+
+We achieve this by building a TcSigInfo for the method, whether or not
+there is an instance method signature, and using that to typecheck
+the declaration (in tcMethodBody).  That means, conveniently,
+that the type variables bound in the signature will scope over the body.
+
+What about the check that the instance method signature is more
+polymorphic than the instantiated class method type?  We just do a
+tcSubType call in mkMethIds, and use the HsWrapper thus generated in
+the method AbsBind.  It's very like the tcSubType impedence-matching
+call in mkExport.  We have to pass the HsWrapper into
+tcMethodBody.
+-}
+
+----------------------
+mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
+        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
+        -- There are two sources:
+        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
+        --     These ones have the dfun inside, but [perhaps surprisingly]
+        --     the correct wrapper.
+mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
+  = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
+  where
+    spec_prags_from_inst
+       | isInlinePragma (idInlinePragma meth_id)
+       = []  -- Do not inherit SPECIALISE from the instance if the
+             -- method is marked INLINE, because then it'll be inlined
+             -- and the specialisation would do nothing. (Indeed it'll provoke
+             -- a warning from the desugarer
+       | otherwise
+       = [ L inst_loc (SpecPrag meth_id wrap inl)
+         | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
 
-    -- check if one of the minimal complete definitions is satisfied
-    checkMinimalDefinition
-      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
-          warnUnsatisifiedMinimalDefinition
-      where
-      methodExists meth = isJust (findMethodBind meth binds)
 
 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
 mkGenericDefMethBind clas inst_tys sel_id dm_name
@@ -1525,12 +1596,9 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name
     rhs = nlHsVar dm_name
 
 ----------------------
-wrapId :: HsWrapper -> id -> HsExpr id
-wrapId wrapper id = mkHsWrap wrapper (HsVar id)
-
-derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
-derivBindCtxt sel_id clas tys _bind
-   = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
+derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
+derivBindCtxt sel_id clas tys
+   = vcat [ ptext (sLit "When typechecking the code for") <+> quotes (ppr sel_id)
           , nest 2 (ptext (sLit "in a derived instance for")
                     <+> quotes (pprClassPred clas tys) <> colon)
           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
@@ -1659,6 +1727,93 @@ Note carefully:
 
 ************************************************************************
 *                                                                      *
+        Specialise instance pragmas
+*                                                                      *
+************************************************************************
+
+Note [SPECIALISE instance pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   instance (Ix a, Ix b) => Ix (a,b) where
+     {-# SPECIALISE instance Ix (Int,Int) #-}
+     range (x,y) = ...
+
+We make a specialised version of the dictionary function, AND
+specialised versions of each *method*.  Thus we should generate
+something like this:
+
+  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
+  {-# DFUN [$crangePair, ...] #-}
+  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
+  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
+
+  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
+  $crange da db = <blah>
+
+The SPECIALISE pragmas are acted upon by the desugarer, which generate
+
+  dii :: Ix Int
+  dii = ...
+
+  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
+  {-# DFUN [$crangePair di di, ...] #-}
+  $s$dfIxPair = Ix ($crangePair di di) (...)
+
+  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
+
+  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
+  $c$crangePair = ...specialised RHS of $crangePair...
+
+  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
+
+Note that
+
+  * The specialised dictionary $s$dfIxPair is very much needed, in case we
+    call a function that takes a dictionary, but in a context where the
+    specialised dictionary can be used.  See Trac #7797.
+
+  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
+    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
+
+  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
+       --> {ClassOp rule for range}     $crangePair Int Int d1 d2
+       --> {SPEC rule for $crangePair}  $s$crangePair
+    or thus:
+       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
+       --> {ClassOpRule for range}      $s$crangePair
+    It doesn't matter which way.
+
+  * We want to specialise the RHS of both $dfIxPair and $crangePair,
+    but the SAME HsWrapper will do for both!  We can call tcSpecPrag
+    just once, and pass the result (in spec_inst_info) to tcMethods.
+-}
+
+tcSpecInstPrags :: DFunId -> InstBindings Name
+                -> TcM ([Located TcSpecPrag], PragFun)
+tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+                            filter isSpecInstLSig uprags
+             -- The filter removes the pragmas for methods
+       ; return (spec_inst_prags, mkPragFun uprags binds) }
+
+------------------------------
+tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
+tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
+  = addErrCtxt (spec_ctxt prag) $
+    do  { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
+        ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
+        ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty
+        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
+  where
+    spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
+
+tcSpecInst _  _ = panic "tcSpecInst"
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{Error messages}
 *                                                                      *
 ************************************************************************
index 79a61a3..d38036c 100644 (file)
@@ -39,6 +39,7 @@ import Data.List( partition, foldl', deleteFirstsBy )
 import VarEnv
 
 import Control.Monad
+import Maybes( isJust )
 import Pair (Pair(..))
 import Unique( hasKey )
 import FastString ( sLit )
@@ -109,7 +110,6 @@ to float. This means that
 
 Note [Running plugins on unflattened wanteds]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 There is an annoying mismatch between solveSimpleGivens and
 solveSimpleWanteds, because the latter needs to fiddle with the inert
 set, unflatten and and zonk the wanteds.  It passes the zonked wanteds
@@ -151,6 +151,7 @@ solveSimpleWanteds = go emptyBag
            ; (wanteds', insols', rerun) <- runTcPluginsWanted zonked
               -- See Note [Running plugins on unflattened wanteds]
            ; let all_insols = insols0 `unionBags` insols `unionBags` insols'
+
            ; if rerun then do { updInertTcS prepareInertsForImplications
                               ; go all_insols wanteds' }
                       else return (WC { wc_simple = wanteds'
@@ -220,7 +221,7 @@ runTcPluginsWanted zonked_wanteds
   where
     setEv :: (EvTerm,Ct) -> TcS ()
     setEv (ev,ct) = case ctEvidence ct of
-      CtWanted {ctev_evar = evar} -> setEvBind evar ev
+      CtWanted {ctev_evar = evar} -> setWantedEvBind evar ev
       _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
 
 -- | A triple of (given, derived, wanted) constraints to pass to plugins
@@ -476,26 +477,37 @@ solveOneFromTheOther ev_i ev_w
   = return (IRDelete, False)
 
   | CtWanted { ctev_evar = ev_id } <- ev_w
-  = do { setEvBind ev_id (ctEvTerm ev_i)
+  = do { setWantedEvBind ev_id (ctEvTerm ev_i)
        ; return (IRKeep, True) }
 
   | CtWanted { ctev_evar = ev_id } <- ev_i
-  = do { setEvBind ev_id (ctEvTerm ev_w)
+  = do { setWantedEvBind ev_id (ctEvTerm ev_w)
        ; return (IRReplace, True) }
 
-  | otherwise   -- Both are Given
-  = return (if use_replacement then IRReplace else IRKeep, True)
+  -- So they are both Given
+  -- See Note [Replacement vs keeping]
+  | lvl_i == lvl_w
+  = do { binds <- getTcEvBindsMap
+       ; if has_binding binds ev_w && not (has_binding binds ev_i)
+         then return (IRReplace, True)
+         else return (IRKeep,    True) }
 
-  where
-    pred  = ctEvPred ev_i
-    loc_i = ctEvLoc ev_i
-    loc_w = ctEvLoc ev_w
-    lvl_i = ctLocLevel loc_i
-    lvl_w = ctLocLevel loc_w
+   | otherwise   -- Both are Given
+   = return (if use_replacement then IRReplace else IRKeep, True)
+   where
+     pred  = ctEvPred ev_i
+     loc_i = ctEvLoc ev_i
+     loc_w = ctEvLoc ev_w
+     lvl_i = ctLocLevel loc_i
+     lvl_w = ctLocLevel loc_w
 
-    use_replacement  -- See Note [Replacement vs keeping]
-      | isIPPred pred = lvl_w > lvl_i
-      | otherwise     = lvl_w < lvl_i
+     has_binding binds ev
+       | EvId v <- ctEvTerm ev = isJust (lookupEvBind binds v)
+       | otherwise             = True
+
+     use_replacement
+       | isIPPred pred = lvl_w > lvl_i
+       | otherwise     = lvl_w < lvl_i
 
 {-
 Note [Replacement vs keeping]
@@ -509,10 +521,23 @@ we keep?
 
   * For everything else, we want to keep the outermost one.  Reason: that
     makes it more likely that the inner one will turn out to be unused,
-    and can be reported as redundant.
+    and can be reported as redundant.  See Note [Tracking redundant constraints]
+    in TcSimplify.
+
+    It transpires that using the outermost one is reponsible for an
+    8% performance improvement in nofib cryptarithm2, compared to
+    just rolling the dice.  I didn't investigate why.
+
+  * If there is no "outermost" one, we keep the one that has a non-trivial
+    evidence binding.  Note [Tracking redundant constraints] again.
+    Example:  f :: (Eq a, Ord a) => blah
+    then we may find [G] sc_sel (d1::Ord a) :: Eq a
+                     [G] d2 :: Eq a
+    We want to discard d2 in favour of the superclass selection from
+    the Ord dictionary.
 
-When there is a choice, use IRKeep rather than IRReplace, to avoid unnecesary
-munging of the inert set.
+  * Finally, when there is still a choice, use IRKeep rather than
+    IRReplace, to avoid unnecesary munging of the inert set.
 
 Doing the depth-check for implicit parameters, rather than making the work item
 always overrride, is important.  Consider
@@ -872,8 +897,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
                          , rhs_i `tcEqType` rhs ]
   =  -- Inert:     a ~ b
      -- Work item: a ~ b
-    do { when (isWanted ev) $
-         setEvBind (ctev_evar ev) (ctEvTerm ev_i)
+    do { setEvBindIfWanted ev (ctEvTerm ev_i)
        ; stopWith ev "Solved from inert" }
 
   | Just tv_rhs <- getTyVar_maybe rhs
@@ -883,8 +907,7 @@ interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
                          , rhs_i `tcEqType` mkTyVarTy tv ]
   =  -- Inert:     a ~ b
      -- Work item: b ~ a
-    do { when (isWanted ev) $
-         setEvBind (ctev_evar ev)
+    do { setEvBindIfWanted ev
                    (EvCoercion (mkTcSymCo (ctEvCoercion ev_i)))
        ; stopWith ev "Solved from inert (r)" }
 
@@ -974,8 +997,7 @@ solveByUnification wd tv xi
                -- cf TcUnify.uUnboundKVar
 
        ; setWantedTyBind tv xi'
-       ; when (isWanted wd) $
-         setEvBind (ctEvId wd) (EvCoercion (mkTcNomReflCo xi')) }
+       ; setEvBindIfWanted wd (EvCoercion (mkTcNomReflCo xi')) }
 
 
 ppr_kicked :: Int -> SDoc
@@ -1227,7 +1249,7 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
   = try_fundeps_and_return
 
   | Just ev <- lookupSolvedDict inerts loc cls xis   -- Cached
-  = do { setEvBind dict_id (ctEvTerm ev);
+  = do { setWantedEvBind dict_id (ctEvTerm ev);
        ; stopWith fl "Dict/Top (cached)" }
 
   | otherwise  -- Not cached
@@ -1247,12 +1269,12 @@ doTopReactDict inerts work_item@(CDictCan { cc_ev = fl, cc_class = cls
         | null evs
         = do { traceTcS "doTopReact/found nullary instance for" $
                ppr dict_id
-             ; setEvBind dict_id ev_term
+             ; setWantedEvBind dict_id ev_term
              ; stopWith fl "Dict/Top (solved, no new work)" }
         | otherwise
         = do { traceTcS "doTopReact/found non-nullary instance for" $
                ppr dict_id
-             ; setEvBind dict_id ev_term
+             ; setWantedEvBind dict_id ev_term
              ; let mk_new_wanted ev
                        = mkNonCanonical (ev {ctev_loc = bumpCtLocDepth CountConstraints loc })
              ; updWorkListTcS (extendWorkListCts (map mk_new_wanted evs))
@@ -1378,7 +1400,7 @@ shortCutReduction old_ev fsk ax_co fam_tc tc_args
                -- old_ev :: F args ~ fsk := ax_co ; sym (G cos) ; new_ev
 
        ; new_ev <- newWantedEvVarNC loc (mkTcEqPred (mkTyConApp fam_tc xis) (mkTyVarTy fsk))
-       ; setEvBind (ctEvId old_ev)
+       ; setWantedEvBind (ctEvId old_ev)
                    (EvCoercion (ax_co `mkTcTransCo` mkTcSymCo (mkTcTyConAppCo Nominal fam_tc cos)
                                       `mkTcTransCo` ctEvCoercion new_ev))
 
@@ -1401,7 +1423,7 @@ dischargeFmv :: EvVar -> TcTyVar -> TcCoercion -> TcType -> TcS ()
 dischargeFmv evar fmv co xi
   = ASSERT2( not (fmv `elemVarSet` tyVarsOfType xi), ppr evar $$ ppr fmv $$ ppr xi )
     do { setWantedTyBind fmv xi
-       ; setEvBind evar (EvCoercion co)
+       ; setWantedEvBind evar (EvCoercion co)
        ; n_kicked <- kickOutRewritable Given NomEq fmv
        ; traceTcS "dischargeFuv" (ppr fmv <+> equals <+> ppr xi $$ ppr_kicked n_kicked) }
 
index d740f7c..71fc8ff 100644 (file)
@@ -30,7 +30,6 @@ module TcMType (
   -- Creating new evidence variables
   newEvVar, newEvVars, newEq, newDict,
   newTcEvBinds, addTcEvBind,
-  newSimpleWanted, newSimpleWanteds,
 
   --------------------------------
   -- Instantiation
@@ -147,25 +146,6 @@ predTypeOccName ty = case classifyPredType ty of
     TuplePred _     -> mkVarOccFS (fsLit "tup")
     IrredPred _     -> mkVarOccFS (fsLit "irred")
 
-{-
-*********************************************************************************
-*                                                                               *
-*                   Wanted constraints
-*                                                                               *
-*********************************************************************************
--}
-
-newSimpleWanted :: CtOrigin -> PredType -> TcM Ct
-newSimpleWanted orig pty
-  = do loc <- getCtLoc orig
-       v <- newEvVar pty
-       return $ mkNonCanonical $
-            CtWanted { ctev_evar = v
-                     , ctev_pred = pty
-                     , ctev_loc = loc }
-
-newSimpleWanteds :: CtOrigin -> ThetaType -> TcM [Ct]
-newSimpleWanteds orig = mapM (newSimpleWanted orig)
 
 {-
 ************************************************************************
@@ -742,7 +722,7 @@ zonkTcPredType = zonkTcType
 ************************************************************************
 -}
 
-zonkImplication :: Implication -> TcM (Bag Implication)
+zonkImplication :: Implication -> TcM Implication
 zonkImplication implic@(Implic { ic_skols  = skols
                                , ic_given  = given
                                , ic_wanted = wanted
@@ -752,13 +732,10 @@ zonkImplication implic@(Implic { ic_skols  = skols
        ; given'  <- mapM zonkEvVar given
        ; info'   <- zonkSkolemInfo info
        ; wanted' <- zonkWCRec wanted
-       ; if isEmptyWC wanted'
-         then return emptyBag
-         else return $ unitBag $
-              implic { ic_skols  = skols'
-                     , ic_given  = given'
-                     , ic_wanted = wanted'
-                     , ic_info   = info' } }
+       ; return (implic { ic_skols  = skols'
+                        , ic_given  = given'
+                        , ic_wanted = wanted'
+                        , ic_info   = info' }) }
 
 zonkEvVar :: EvVar -> TcM EvVar
 zonkEvVar var = do { ty' <- zonkTcType (varType var)
@@ -771,7 +748,7 @@ zonkWC wc = zonkWCRec wc
 zonkWCRec :: WantedConstraints -> TcM WantedConstraints
 zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
   = do { simple' <- zonkSimples simple
-       ; implic' <- flatMapBagM zonkImplication implic
+       ; implic' <- mapBagM zonkImplication implic
        ; insol'  <- zonkSimples insol
        ; return (WC { wc_simple = simple', wc_impl = implic', wc_insol = insol' }) }
 
index dda97d1..af80e2e 100644 (file)
@@ -79,7 +79,7 @@ tcMatchesFun fun_name inf matches exp_ty
         ; checkArgs fun_name matches
 
         ; (wrap_gen, (wrap_fun, group))
-            <- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
+            <- tcGen (FunSigCtxt fun_name True) exp_ty $ \ _ exp_rho ->
                   -- Note [Polymorphic expected type for tcMatchesFun]
                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
                tcMatches match_ctxt pat_tys rhs_ty matches
index a8889b5..819d3ec 100644 (file)
@@ -28,7 +28,6 @@ import Var
 import Name
 import NameSet
 import TcEnv
---import TcExpr
 import TcMType
 import TcValidity( arityErr )
 import TcType
@@ -120,10 +119,10 @@ data LetBndrSpec
   = LetLclBndr            -- The binder is just a local one;
                           -- an AbsBinds will provide the global version
 
-  | LetGblBndr TcPragFun  -- Genrealisation plan is NoGen, so there isn't going
+  | LetGblBndr TcPragFun  -- Generalisation plan is NoGen, so there isn't going
                           -- to be an AbsBinds; So we must bind the global version
                           -- of the binder right away.
-                          -- Oh, and dhhere is the inline-pragma information
+                          -- Oh, and here is the inline-pragma information
 
 makeLazy :: PatEnv -> PatEnv
 makeLazy penv = penv { pe_lazy = True }
@@ -162,8 +161,17 @@ data TcSigInfo
 
         sig_loc    :: SrcSpan,      -- The location of the signature
 
-        sig_partial :: Bool         -- True <=> a partial type signature
+        sig_partial :: Bool,        -- True <=> a partial type signature
                                     -- containing wildcards
+
+        sig_warn_redundant :: Bool  -- True <=> report redundant constraints
+                                    --          when typechecking the value binding
+                                    --          for this type signature
+           -- This is usually True, but False for
+           --   * Record selectors (not important here)
+           --   * Class and instance methods.  Here the code may legitimately
+           --     be more polymorphic than the signature generated from the
+           --     class declaration
     }
   | TcPatSynInfo TcPatSynInfo
 
@@ -290,8 +298,7 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
        ; return (mkTcNomReflCo pat_ty, bndr_id) }
 
 tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
-  = do { bndr <- mkLocalBinder bndr_name pat_ty
-       ; return (mkTcNomReflCo pat_ty, bndr) }
+  = return (mkTcNomReflCo pat_ty, mkLocalId bndr_name pat_ty)
 
 ------------
 newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
@@ -302,10 +309,9 @@ newNoSigLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
 --    use the original name directly
 newNoSigLetBndr LetLclBndr name ty
   =do  { mono_name <- newLocalName name
-       ; mkLocalBinder mono_name ty }
+       ; return (mkLocalId mono_name ty) }
 newNoSigLetBndr (LetGblBndr prags) name ty
-  = do { id <- mkLocalBinder name ty
-       ; addInlinePrags id (prags name) }
+  = addInlinePrags (mkLocalId name ty) (prags name)
 
 ----------
 addInlinePrags :: TcId -> [LSig Name] -> TcM TcId
@@ -331,11 +337,6 @@ warnPrags id bad_sigs herald
   where
     ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)
 
------------------
-mkLocalBinder :: Name -> TcType -> TcM TcId
-mkLocalBinder name ty
-  = return (Id.mkLocalId name ty)
-
 {-
 Note [Typing patterns in pattern bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 9287757..f572f78 100644 (file)
@@ -67,9 +67,8 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
        ; let (arg_names, is_infix) = case details of
                  PrefixPatSyn names      -> (map unLoc names, False)
                  InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True)
-       ; (((lpat', (args, pat_ty)), tclvl), wanted)
-            <- captureConstraints  $
-               captureTcLevel      $
+       ; ((lpat', (args, pat_ty)), tclvl, wanted)
+            <- pushLevelAndCaptureConstraints  $
                do { pat_ty <- newFlexiTyVarTy openTypeKind
                   ; tcPat PatSyn lpat pat_ty $
                do { args <- mapM tcLookupId arg_names
@@ -120,7 +119,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
        ; req_dicts <- newEvVars req_theta
 
        -- TODO: find a better SkolInfo
-       ; let skol_info = SigSkol (FunSigCtxt name) (mkFunTys arg_tys pat_ty)
+       ; let skol_info = SigSkol (FunSigCtxt name True) (mkFunTys arg_tys pat_ty)
 
        ; let (arg_names, is_infix) = case details of
                  PrefixPatSyn names      -> (map unLoc names, False)
@@ -373,6 +372,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
                             , sig_loc = noSrcSpan
                             , sig_extra_cts = Nothing
                             , sig_partial = False
+                            , sig_warn_redundant = False  -- See Note [Redundant constraints for builder]
                             , sig_nwcs = []
                             }
 
@@ -416,6 +416,14 @@ tcPatSynBuilderOcc orig ps
     builder = patSynBuilder ps
 
 {-
+Note [Redundant constraints for builder]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The builder can have redundant constraints, which are awkard to eliminate.
+Consider
+   pattern P = Just 34
+To match against this pattern we need (Eq a, Num a).  But to build
+(Just 34) we need only (Num a).
+
 ************************************************************************
 *                                                                      *
          Helper functions
index 8cfd43c..b78b69d 100644 (file)
@@ -1759,9 +1759,8 @@ tcRnExpr hsc_env rdr_expr
         -- it might have a rank-2 type (e.g. :t runST)
     uniq <- newUnique ;
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
-    (((_tc_expr, res_ty), tclvl), lie) <- captureConstraints $
-                                          captureTcLevel     $
-                                          tcInferRho rn_expr ;
+    ((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $
+                                        tcInferRho rn_expr ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
                                       {-# SCC "simplifyInfer" #-}
                                       simplifyInfer tclvl
index 44c71e4..31391e4 100644 (file)
@@ -32,7 +32,6 @@ import InstEnv
 import FamInstEnv
 import PrelNames
 
-import Var
 import Id
 import VarSet
 import VarEnv
@@ -1096,13 +1095,12 @@ newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
                   ; uniq <- newUnique
                   ; return (EvBindsVar ref uniq) }
 
-addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
+addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
 -- Add a binding to the TcEvBinds by side effect
-addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm
-  = do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id
-                                      , text "ev_tm =" <+> ppr ev_tm ]
+addTcEvBind (EvBindsVar ev_ref _) ev_bind
+  = do { traceTc "addTcEvBind" $ ppr ev_bind
        ; bnds <- readTcRef ev_ref
-       ; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) }
+       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
 
 getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
 getTcEvBinds (EvBindsVar ev_ref _)
@@ -1165,24 +1163,31 @@ captureConstraints thing_inside
          lie <- readTcRef lie_var ;
          return (res, lie) }
 
-captureTcLevel :: TcM a -> TcM (a, TcLevel)
-captureTcLevel thing_inside
+pushLevelAndCaptureConstraints :: TcM a -> TcM (a, TcLevel, WantedConstraints)
+pushLevelAndCaptureConstraints thing_inside
   = do { env <- getLclEnv
+       ; lie_var <- newTcRef emptyWC ;
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
-       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl'
+                               , tcl_lie   = lie_var })
                 thing_inside
-       ; return (res, tclvl') }
+       ; lie <- readTcRef lie_var
+       ; return (res, tclvl', lie) }
+
+pushTcLevelM_ :: TcM a -> TcM a
+pushTcLevelM_ = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) })
 
-pushTcLevelM :: TcM a -> TcM a
+pushTcLevelM :: TcM a -> TcM (a, TcLevel)
 pushTcLevelM thing_inside
   = do { env <- getLclEnv
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
-       ; setLclEnv (env { tcl_tclvl = tclvl' })
-                   thing_inside }
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
+                          thing_inside
+       ; return (res, tclvl') }
 
 getTcLevel :: TcM TcLevel
 getTcLevel = do { env <- getLclEnv
-                     ; return (tcl_tclvl env) }
+                ; return (tcl_tclvl env) }
 
 setTcLevel :: TcLevel -> TcM a -> TcM a
 setTcLevel tclvl thing_inside
index 5b77ebe..90aba1d 100644 (file)
@@ -61,9 +61,9 @@ module TcRnTypes(
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         andWC, unionsWC, addSimples, addImplics, mkSimpleWC, addInsols,
-        dropDerivedWC,
+        dropDerivedWC, insolubleImplic, trulyInsoluble,
 
-        Implication(..),
+        Implication(..), ImplicStatus(..), isInsolubleStatus,
         SubGoalCounter(..),
         SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
         bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded,
@@ -1413,22 +1413,16 @@ data WantedConstraints
 emptyWC :: WantedConstraints
 emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag, wc_insol = emptyBag }
 
-mkSimpleWC :: [Ct] -> WantedConstraints
+mkSimpleWC :: [CtEvidence] -> WantedConstraints
 mkSimpleWC cts
-  = WC { wc_simple = listToBag cts, wc_impl = emptyBag, wc_insol = emptyBag }
+  = WC { wc_simple = listToBag (map mkNonCanonical cts)
+       , wc_impl = emptyBag
+       , wc_insol = emptyBag }
 
 isEmptyWC :: WantedConstraints -> Bool
 isEmptyWC (WC { wc_simple = f, wc_impl = i, wc_insol = n })
   = isEmptyBag f && isEmptyBag i && isEmptyBag n
 
-insolubleWC :: WantedConstraints -> Bool
--- True if there are any insoluble constraints in the wanted bag. Ignore
--- constraints arising from PartialTypeSignatures to solve as much of the
--- constraints as possible before reporting the holes.
-insolubleWC wc = not (isEmptyBag (filterBag (not . isTypeHoleCt)
-                                  (wc_insol wc)))
-               || anyBag ic_insol (wc_impl wc)
-
 andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints
 andWC (WC { wc_simple = f1, wc_impl = i1, wc_insol = n1 })
       (WC { wc_simple = f2, wc_impl = i2, wc_insol = n2 })
@@ -1450,6 +1444,24 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
 addInsols wc cts
   = wc { wc_insol = wc_insol wc `unionBags` cts }
 
+isInsolubleStatus :: ImplicStatus -> Bool
+isInsolubleStatus IC_Insoluble = True
+isInsolubleStatus _            = False
+
+insolubleImplic :: Implication -> Bool
+insolubleImplic ic = isInsolubleStatus (ic_status ic)
+
+insolubleWC :: WantedConstraints -> Bool
+insolubleWC (WC { wc_impl = implics, wc_insol = insols })
+  =  anyBag trulyInsoluble  insols
+  || anyBag insolubleImplic implics
+
+trulyInsoluble :: Ct -> Bool
+-- The constraint is in the wc_insol set, but we do not
+-- treat type-holes, arising from PartialTypeSignatures,
+-- as "truly insoluble". Yuk.
+trulyInsoluble insol = not (isTypeHoleCt insol)
+
 instance Outputable WantedConstraints where
   ppr (WC {wc_simple = s, wc_impl = i, wc_insol = n})
    = ptext (sLit "WC") <+> braces (vcat
@@ -1488,32 +1500,63 @@ data Implication
                                  -- False <=> ic_givens might have equalities
 
       ic_env   :: TcLclEnv,      -- Gives the source location and error context
-                                 -- for the implicatdion, and hence for all the
+                                 -- for the implication, and hence for all the
                                  -- given evidence variables
 
       ic_wanted :: WantedConstraints,  -- The wanted
-      ic_insol  :: Bool,               -- True iff insolubleWC ic_wanted is true
 
-      ic_binds  :: EvBindsVar   -- Points to the place to fill in the
-                                -- abstraction and bindings
+      ic_binds  :: EvBindsVar,    -- Points to the place to fill in the
+                                  -- abstraction and bindings
+
+      ic_status   :: ImplicStatus
     }
 
+data ImplicStatus
+  = IC_Solved     -- All wanteds in the tree are solved, all the way down
+       { ics_need :: VarSet     -- Evidence variables needed by this implication
+       , ics_dead :: [EvVar] }  -- Subset of ic_given that are not needed
+         -- See Note [Tracking redundant constraints] in TcSimplify
+
+  | IC_Insoluble  -- At least one insoluble constraint in the tree
+
+  | IC_Unsolved   -- Neither of the above; might go either way
+
 instance Outputable Implication where
   ppr (Implic { ic_tclvl = tclvl, ic_skols = skols
               , ic_given = given, ic_no_eqs = no_eqs
-              , ic_wanted = wanted, ic_insol = insol
+              , ic_wanted = wanted, ic_status = status
               , ic_binds = binds, ic_info = info })
    = hang (ptext (sLit "Implic") <+> lbrace)
         2 (sep [ ptext (sLit "TcLevel =") <+> ppr tclvl
                , ptext (sLit "Skolems =") <+> pprTvBndrs skols
                , ptext (sLit "No-eqs =") <+> ppr no_eqs
-               , ptext (sLit "Insol =") <+> ppr insol
+               , ptext (sLit "Status =") <+> ppr status
                , hang (ptext (sLit "Given ="))  2 (pprEvVars given)
                , hang (ptext (sLit "Wanted =")) 2 (ppr wanted)
                , ptext (sLit "Binds =") <+> ppr binds
                , pprSkolInfo info ] <+> rbrace)
 
+instance Outputable ImplicStatus where
+  ppr IC_Insoluble   = ptext (sLit "Insoluble")
+  ppr IC_Unsolved    = ptext (sLit "Unsolved")
+  ppr (IC_Solved { ics_need = vs, ics_dead = dead })
+    = ptext (sLit "Solved")
+      <+> (braces $ vcat [ ptext (sLit "Dead givens =") <+> ppr dead
+                         , ptext (sLit "Needed =") <+> ppr vs ])
+
 {-
+Note [Needed evidence variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Th ic_need_evs field holds the free vars of ic_binds, and all the
+ic_binds in nested implications.
+
+  * Main purpose: if one of the ic_givens is not mentioned in here, it
+    is redundant.
+
+  * solveImplication may drop an implication altogether if it has no
+    remaining 'wanteds'. But we still track the free vars of its
+    evidence binds, even though it has now disappeared.
+
 Note [Shadowing in a constraint]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We assume NO SHADOWING in a constraint.  Specifically
index 7e86e00..17d548f 100644 (file)
@@ -166,29 +166,29 @@ tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
            -- Simplify the RHS constraints
        ; lcl_env <- getLclEnv
        ; rhs_binds_var <- newTcEvBinds
-       ; emitImplication $ Implic { ic_tclvl  = topTcLevel
-                                  , ic_skols  = qtkvs
-                                  , ic_no_eqs = False
-                                  , ic_given  = lhs_evs
-                                  , ic_wanted = rhs_wanted
-                                  , ic_insol  = insolubleWC rhs_wanted
-                                  , ic_binds  = rhs_binds_var
-                                  , ic_info   = RuleSkol (unLoc name)
-                                  , ic_env    = lcl_env }
+       ; emitImplication $ Implic { ic_tclvl    = topTcLevel
+                                  , ic_skols    = qtkvs
+                                  , ic_no_eqs   = False
+                                  , ic_given    = lhs_evs
+                                  , ic_wanted   = rhs_wanted
+                                  , ic_status   = IC_Unsolved
+                                  , ic_binds    = rhs_binds_var
+                                  , ic_info     = RuleSkol (unLoc name)
+                                  , ic_env      = lcl_env }
 
            -- For the LHS constraints we must solve the remaining constraints
            -- (a) so that we report insoluble ones
            -- (b) so that we bind any soluble ones
        ; lhs_binds_var <- newTcEvBinds
-       ; emitImplication $ Implic { ic_tclvl  = topTcLevel
-                                  , ic_skols  = qtkvs
-                                  , ic_no_eqs = False
-                                  , ic_given  = lhs_evs
-                                  , ic_wanted = other_lhs_wanted
-                                  , ic_insol  = insolubleWC other_lhs_wanted
-                                  , ic_binds  = lhs_binds_var
-                                  , ic_info   = RuleSkol (unLoc name)
-                                  , ic_env    = lcl_env }
+       ; emitImplication $ Implic { ic_tclvl    = topTcLevel
+                                  , ic_skols    = qtkvs
+                                  , ic_no_eqs   = False
+                                  , ic_given    = lhs_evs
+                                  , ic_wanted   = other_lhs_wanted
+                                  , ic_status   = IC_Unsolved
+                                  , ic_binds    = lhs_binds_var
+                                  , ic_info     = RuleSkol (unLoc name)
+                                  , ic_env      = lcl_env }
 
        ; return (HsRule name act
                     (map (noLoc . RuleBndr . noLoc) (qtkvs ++ tpl_ids))
index d7c58d5..16ac114 100644 (file)
@@ -27,7 +27,7 @@ module TcSMonad (
 
     newTcEvBinds, newWantedEvVar, newWantedEvVarNC,
     setWantedTyBind, reportUnifications,
-    setEvBind,
+    setEvBind, setWantedEvBind, setEvBindIfWanted,
     newEvVar, newGivenEvVar, newGivenEvVars,
     newDerived, emitNewDerived,
 
@@ -1355,10 +1355,11 @@ checkForCyclicBinds ev_binds
     cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVertices edges]
 
     coercion_cycles = [c | c <- cycles, any is_co_bind c]
-    is_co_bind (EvBind b _) = isEqVar b
+    is_co_bind (EvBind { eb_lhs = b }) = isEqVar b
 
     edges :: [(EvBind, EvVar, [EvVar])]
-    edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) | bind@(EvBind bndr rhs) <- bagToList ev_binds]
+    edges = [(bind, bndr, varSetElems (evVarsOfTerm rhs)) 
+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs }) <- bagToList ev_binds]
 #endif
 
 nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a
@@ -1760,10 +1761,19 @@ isFresh Cached = False
 freshGoals :: [(CtEvidence, Freshness)] -> [CtEvidence]
 freshGoals mns = [ ctev | (ctev, Fresh) <- mns ]
 
-setEvBind :: EvVar -> EvTerm -> TcS ()
-setEvBind the_ev tm
+setEvBind :: EvBind -> TcS ()
+setEvBind ev_bind
   = do { tc_evbinds <- getTcEvBinds
-       ; wrapTcS $ TcM.addTcEvBind tc_evbinds the_ev tm }
+       ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev_bind }
+
+setWantedEvBind :: EvVar -> EvTerm -> TcS ()
+setWantedEvBind ev_id tm = setEvBind (mkWantedEvBind ev_id tm)
+
+setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
+setEvBindIfWanted ev tm
+  = case ev of
+      CtWanted { ctev_evar = ev_id } -> setWantedEvBind ev_id tm
+      _                              -> return ()
 
 newTcEvBinds :: TcS EvBindsVar
 newTcEvBinds = wrapTcS TcM.newTcEvBinds
@@ -1780,7 +1790,7 @@ newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
 newGivenEvVar loc (pred, rhs)
   = ASSERT2( not (isKindEquality pred), ppr pred $$ pprCtOrigin (ctLocOrigin loc) )
     do { new_ev <- newEvVar pred
-       ; setEvBind new_ev rhs
+       ; setEvBind (mkGivenEvBind new_ev rhs)
        ; return (CtGiven { ctev_pred = pred, ctev_evtm = EvId new_ev, ctev_loc = loc }) }
 
 newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]
@@ -1920,15 +1930,15 @@ deferTcSForAllEq role loc (tvs1,body1) (tvs2,body2)
                          ; let wc = WC { wc_simple = singleCt new_ct
                                        , wc_impl   = emptyBag
                                        , wc_insol  = emptyCts }
-                               imp = Implic { ic_tclvl  = new_tclvl
-                                            , ic_skols  = skol_tvs
-                                            , ic_no_eqs = True
-                                            , ic_given  = []
-                                            , ic_wanted = wc
-                                            , ic_insol  = False
-                                            , ic_binds  = ev_binds_var
-                                            , ic_env    = env
-                                            , ic_info   = skol_info }
+                               imp = Implic { ic_tclvl    = new_tclvl
+                                            , ic_skols    = skol_tvs
+                                            , ic_no_eqs   = True
+                                            , ic_given    = []
+                                            , ic_wanted   = wc
+                                            , ic_status   = IC_Unsolved
+                                            , ic_binds    = ev_binds_var
+                                            , ic_env      = env
+                                            , ic_info     = skol_info }
                          ; updWorkListTcS (extendWorkListImplic imp)
                          ; return (TcLetCo ev_binds new_co) }
 
index 68978df..761a7a5 100644 (file)
@@ -40,6 +40,7 @@ import Control.Monad    ( unless )
 import DynFlags         ( ExtensionFlag( Opt_AllowAmbiguousTypes ) )
 import Class            ( classKey )
 import BasicTypes       ( RuleName )
+import Maybes           ( isNothing )
 import Outputable
 import FastString
 import TrieMap () -- DV: for now
@@ -217,7 +218,7 @@ simplifyDefault :: ThetaType    -- Wanted; has no type variables in it
                 -> TcM ()       -- Succeeds iff the constraint is soluble
 simplifyDefault theta
   = do { traceTc "simplifyInteractive" empty
-       ; wanted <- newSimpleWanteds DefaultOrigin theta
+       ; wanted <- newWanteds DefaultOrigin theta
        ; (unsolved, _binds) <- solveWantedsTcM (mkSimpleWC wanted)
 
        ; traceTc "reportUnsolved {" empty
@@ -245,7 +246,7 @@ Consider
 To infer f's type we do the following:
  * Gather the constraints for the RHS with ambient level *one more than*
    the current one.  This is done by the call
-        captureConstraints (captureTcLevel (tcMonoBinds...))
+        pushLevelAndCaptureConstraints (tcMonoBinds...)
    in TcBinds.tcPolyInfer
 
  * Call simplifyInfer to simplify the constraints and decide what to
@@ -365,7 +366,7 @@ simplifyInfer rhs_tclvl apply_mr name_taus wanteds
                              , ic_no_eqs   = False
                              , ic_given    = minimal_bound_ev_vars
                              , ic_wanted   = wanted_transformed
-                             , ic_insol    = False
+                             , ic_status   = IC_Unsolved
                              , ic_binds    = ev_binds_var
                              , ic_info     = skol_info
                              , ic_env      = tc_lcl_env }
@@ -782,15 +783,14 @@ solveWanteds wanteds
        ; return final_wanteds }
 
 solveSimples :: WantedConstraints -> TcS WantedConstraints
--- Solve the wc_simple and wc_insol components of the WantedConstraints
+-- Solve the wc_simple component of the WantedConstraints
+-- No point in looking at wc_insol because they are, well, insoluble
 -- Do not affect the inerts
 solveSimples (WC { wc_simple = simples, wc_insol = insols, wc_impl = implics })
   = nestTcS $
-    do { let all_simples = simples `unionBags` filterBag (not . isDerivedCt) insols
-                     -- See Note [Dropping derived constraints] in TcRnTypes for
-                     -- why the insolubles may have derived constraints
-       ; wc <- solveSimpleWanteds all_simples
-       ; return ( wc { wc_impl = implics `unionBags` wc_impl wc } ) }
+    do { wc <- solveSimpleWanteds simples
+       ; return ( wc { wc_impl  = implics `unionBags` wc_impl  wc
+                     , wc_insol = insols  `unionBags` wc_insol wc } ) }
 
 simpl_loop :: Int
            -> WantedConstraints
@@ -833,17 +833,9 @@ solveNestedImplications implics
   | isEmptyBag implics
   = return (emptyBag, emptyBag)
   | otherwise
-  = do {
---         inerts <- getTcSInerts
---       ; let thinner_inerts = prepareInertsForImplications inerts
---                 -- See Note [Preparing inert set for implications]
---
-           traceTcS "solveNestedImplications starting {" empty
---           vcat [ text "original inerts = " <+> ppr inerts
---                , text "thinner_inerts  = " <+> ppr thinner_inerts ]
-
-       ; (floated_eqs, unsolved_implics)
-           <- flatMapBagPairM solveImplication implics
+  = do { traceTcS "solveNestedImplications starting {" empty
+       ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics
+       ; let floated_eqs = concatBag floated_eqs_s
 
        -- ... and we are back in the original TcS inerts
        -- Notice that the original includes the _insoluble_simples so it was safe to ignore
@@ -852,11 +844,11 @@ solveNestedImplications implics
                   vcat [ text "all floated_eqs ="  <+> ppr floated_eqs
                        , text "unsolved_implics =" <+> ppr unsolved_implics ]
 
-       ; return (floated_eqs, unsolved_implics) }
+       ; return (floated_eqs, catBagMaybes unsolved_implics) }
 
 solveImplication :: Implication    -- Wanted
                  -> TcS (Cts,      -- All wanted or derived floated equalities: var = type
-                         Bag Implication) -- Unsolved rest (always empty or singleton)
+                         Maybe Implication) -- Simplified implication (empty or singleton)
 -- Precondition: The TcS monad contains an empty worklist and given-only inerts
 -- which after trying to solve this implication we must restore to their original value
 solveImplication imp@(Implic { ic_tclvl  = tclvl
@@ -865,7 +857,15 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
                              , ic_given  = givens
                              , ic_wanted = wanteds
                              , ic_info   = info
+                             , ic_status = status
                              , ic_env    = env })
+  | IC_Solved {} <- status
+  = return (emptyCts, Just imp)  -- Do nothing
+
+  | otherwise  -- Even for IC_Insoluble it is worth doing more work
+               -- The insoluble stuff might be in one sub-implication
+               -- and other unsolved goals in another; and we want to
+               -- solve the latter as much as possible
   = do { inerts <- getTcSInerts
        ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
 
@@ -886,15 +886,8 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
        ; (floated_eqs, final_wanted)
              <- floatEqualities skols no_given_eqs residual_wanted
 
-       ; let res_implic | isEmptyWC final_wanted -- && no_given_eqs
-                        = emptyBag  -- Reason for the no_given_eqs: we don't want to
-                                    -- lose the "inaccessible code" error message
-                                    -- BUT: final_wanted still has the derived insolubles
-                                    --      so it should be fine
-                        | otherwise
-                        = unitBag (imp { ic_no_eqs = no_given_eqs
-                                       , ic_wanted = dropDerivedWC final_wanted
-                                       , ic_insol  = insolubleWC final_wanted })
+       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs
+                                                 , ic_wanted = final_wanted })
 
        ; evbinds <- getTcEvBindsMap
        ; traceTcS "solveImplication end }" $ vcat
@@ -905,7 +898,213 @@ solveImplication imp@(Implic { ic_tclvl  = tclvl
 
        ; return (floated_eqs, res_implic) }
 
+----------------------
+setImplicationStatus :: Implication -> TcS (Maybe Implication)
+-- Finalise the implication returned from solveImplication:
+--    * Set the ic_status field
+--    * Trim the ic_wanted field
+-- Return Nothing if we can discard the implication altogether
+setImplicationStatus implic@(Implic { ic_binds = EvBindsVar ev_binds_var _
+                                    , ic_info = info
+                                    , ic_wanted = wc, ic_given = givens })
+ | some_insoluble
+ = return $ Just $
+   implic { ic_status = IC_Insoluble
+          , ic_wanted = trimmed_wc }
+
+ | some_unsolved
+ = return $ Just $
+   implic { ic_status = IC_Unsolved
+          , ic_wanted = trimmed_wc }
+
+ | otherwise  -- Everything is solved; look at the implications
+              -- See Note [Tracking redundant constraints]
+ = do { ev_binds <- TcS.readTcRef ev_binds_var
+      ; let all_needs = neededEvVars ev_binds implic_needs
+
+            dead_givens | warnRedundantGivens info
+                        = filterOut (`elemVarSet` all_needs) givens
+                        | otherwise = []   -- None to report
+
+            final_needs = all_needs `delVarSetList` givens
+
+            discard_implic  -- Can we discard the entire implication?
+              =  null dead_givens           -- No warning from this implication
+              && isEmptyBag keep_implics    -- No live children
+              && isEmptyVarSet final_needs  -- No needed vars to pass up to parent
+
+            final_implic = implic { ic_status = IC_Solved { ics_need = final_needs
+                                                          , ics_dead = dead_givens }
+                                  , ic_wanted = trimmed_wc }
+
+      ; return $ if discard_implic then Nothing else Just final_implic }
+ where
+   WC { wc_simple = simples, wc_impl = implics, wc_insol = insols } = wc
+   trimmed_wc = wc { wc_simple = drop_der_simples
+                   , wc_impl   = keep_implics }
+
+   some_insoluble = insolubleWC wc
+   some_unsolved = not (isEmptyBag simples && isEmptyBag insols)
+                 || isNothing mb_implic_needs
+
+   drop_der_simples = filterBag isWantedCt simples
+   keep_implics     = filterBag need_to_keep_implic implics
+
+   mb_implic_needs :: Maybe VarSet
+        -- Just vs => all implics are IC_Solved, with 'vs' needed
+        -- Nothing => at least one implic is not IC_Solved
+   mb_implic_needs   = foldrBag add_implic (Just emptyVarSet) implics
+   Just implic_needs = mb_implic_needs
+
+   add_implic implic acc
+      | Just vs_acc <- acc
+      , IC_Solved { ics_need = vs } <- ic_status implic
+      = Just (vs `unionVarSet` vs_acc)
+      | otherwise = Nothing
+
+   need_to_keep_implic ic
+     | IC_Solved { ics_dead = [] } <- ic_status ic
+           -- Fully solved, and no redundant givens to report
+     , isEmptyBag (wc_impl (ic_wanted ic))
+           -- And no children that might have things to report
+     = False
+     | otherwise
+     = True
+
+warnRedundantGivens :: SkolemInfo -> Bool
+warnRedundantGivens (SigSkol ctxt _)
+  = case ctxt of
+       FunSigCtxt _ warn_redundant -> warn_redundant
+       ExprSigCtxt                 -> True
+       _                           -> False
+warnRedundantGivens InstSkol = True
+warnRedundantGivens _        = False
+
+neededEvVars :: EvBindMap -> VarSet -> VarSet
+-- Find all the evidence variables that are "needed",
+--    and then delete all those bound by the evidence bindings
+-- A variable is "needed" if
+--  a) it is free in the RHS of a Wanted EvBind (add_wanted)
+--  b) it is free in the RHS of an EvBind whose LHS is needed (transClo)
+--  c) it is in the ic_need_evs of a nested implication (initial_seeds)
+--     (after removing the givens)
+neededEvVars ev_binds initial_seeds
+ = needed `minusVarSet` bndrs
+ where
+   seeds  = foldEvBindMap add_wanted initial_seeds ev_binds
+   needed = transCloVarSet also_needs seeds
+   bndrs  = foldEvBindMap add_bndr emptyVarSet ev_binds
+
+   add_wanted :: EvBind -> VarSet -> VarSet
+   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
+     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only
+     | otherwise = evVarsOfTerm rhs `unionVarSet` needs
+
+   also_needs :: VarSet -> VarSet
+   also_needs needs
+     = foldVarSet add emptyVarSet needs
+     where
+       add v needs
+        | Just ev_bind <- lookupEvBind ev_binds v
+        , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind
+        , is_given
+        = evVarsOfTerm rhs `unionVarSet` needs
+        | otherwise
+        = needs
+
+   add_bndr :: EvBind -> VarSet -> VarSet
+   add_bndr (EvBind { eb_lhs = v }) vs = extendVarSet vs v
+
+
 {-
+Note [Tracking redundant constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With Opt_WarnRedundantConstraints, GHC can report which
+constraints of a type signature (or instance declaration) are
+redundant, and can be omitted.  Here is an overview of how it
+works:
+
+----- What is a redudant constraint?
+
+* The things that can be redundant are precisely the Given
+  constraints of an implication.
+
+* A constraint can be redundant in two different ways:
+  a) It is implied by other givens.  E.g.
+       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary
+       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary
+  b) It is not needed by the Wanted constraints covered by the
+     implication E.g.
+       f :: Eq a => a -> Bool
+       f x = True  -- Equality not uesd
+
+*  To find (a), when we have two Given constraints,
+   we must be careful to drop the one that is a naked variable (if poss).
+   So if we have
+       f :: (Eq a, Ord a) => blah
+   then we may find [G] sc_sel (d1::Ord a) :: Eq a
+                    [G] d2 :: Eq a
+   We want to discard d2 in favour of the superclass selection from
+   the Ord dictionary.  This is done by TcInteract.solveOneFromTheOther
+   See Note [Replacement vs keeping].
+
+* To find (b) we need to know which evidence bindings are 'wanted';
+  hence the eb_is_given field on an EvBind.
+
+----- How tracking works
+
+* When the constraint solver finishes solving all the wanteds in
+  an implication, it sets its status to IC_Solved
+
+  - The ics_dead field of IC_Solved records the subset of the ic_given
+    of this implication that are redundant (not needed).
+
+  - The ics_need field of IC_Solved then records all the
+    in-scope (given) evidence variables, bound by the context, that
+    were needed to solve this implication, including all its nested
+    implications.  (We remove the ic_given of this implication from
+    the set, of course.)
+
+* We compute which evidence variables are needed by an implication
+  in setImplicationStatus.  A variable is needed if
+    a) it is free in the RHS of a Wanted EvBind
+    b) it is free in the RHS of an EvBind whose LHS is needed
+    c) it is in the ics_need of a nested implication
+
+* We need to be careful not to discard an implication
+  prematurely, even one that is fully solved, because we might
+  thereby forget which variables it needs, and hence wrongly
+  report a constraint as redundant.  But we can discard it once
+  its free vars have been incorporated into its parent; or if it
+  simply has no free vars. This careful discarding is also
+  handled in setImplicationStatus
+
+----- Reporting redundant constraints
+
+* TcErrors does the actual warning, in warnRedundantConstraints.
+
+* We don't report redundant givens for *every* implication; only
+  for those which reply True to TcSimplify.warnRedundantGivens:
+
+   - For example, in a class declaration, the default method *can*
+     use the class constraint, but it certainly doesn't *have* to,
+     and we don't want to report an error there.
+
+   - More subtly, in a function definition
+       f :: (Ord a, Ord a, Ix a) => a -> a
+       f x = rhs
+     we do an ambiguity check on the type (which would find that one
+     of the Ord a constraints was redundant), and then we check that
+     the definition has that type (which might find that both are
+     redundant).  We don't want to report the same error twice, so
+     we disable it for the ambiguity check.  Hence the flag in
+     TcType.FunSigCtxt.
+
+  This decision is taken in setImplicationStatus, rather than TcErrors
+  so that we can discard implication constraints that we don't need.
+  So ics_dead consists only of the *reportable* redundant givens.
+
+
 Note [Cutting off simpl_loop]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 It is very important not to iterate in simpl_loop unless there is a chance
@@ -945,7 +1144,7 @@ Consider floated_eqs (all wanted or derived):
     simpl_loop.  So we iterate if there any of these
 -}
 
-promoteTyVar :: TcLevel -> TcTyVar  -> TcS ()
+promoteTyVar :: TcLevel -> TcTyVar  -> TcS TcTyVar
 -- When we float a constraint out of an implication we must restore
 -- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType
 -- See Note [Promoting unification variables]
@@ -953,11 +1152,12 @@ promoteTyVar tclvl tv
   | isFloatedTouchableMetaTyVar tclvl tv
   = do { cloned_tv <- TcS.cloneMetaTyVar tv
        ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
-       ; setWantedTyBind tv (mkTyVarTy rhs_tv) }
+       ; setWantedTyBind tv (mkTyVarTy rhs_tv)
+       ; return rhs_tv }
   | otherwise
-  = return ()
+  = return tv
 
-promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TyVar -> TcS ()
+promoteAndDefaultTyVar :: TcLevel -> TcTyVarSet -> TcTyVar -> TcS TcTyVar
 -- See Note [Promote _and_ default when inferring]
 promoteAndDefaultTyVar tclvl gbl_tvs tv
   = do { tv1 <- if tv `elemVarSet` gbl_tvs
index 6545e7b..d187b09 100644 (file)
@@ -1690,15 +1690,15 @@ checkValidClass cls
 
         ; case dm of
             GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
-                                     ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+                                     ; checkValidType ctxt (idType dm_id) }
             _                  -> return ()
         }
         where
-          ctxt    = FunSigCtxt op_name
+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints
           op_name = idName sel_id
           op_ty   = idType sel_id
           (_,theta1,tau1) = tcSplitSigmaTy op_ty
-          (_,theta2,tau2)  = tcSplitSigmaTy tau1
+          (_,theta2,tau2) = tcSplitSigmaTy tau1
           (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
                       | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
                 -- Ugh!  The function might have a type like
index e0ce00f..1cd2b00 100644 (file)
@@ -366,8 +366,12 @@ data MetaInfo
 -- in the places where we need to an expression has that type
 
 data UserTypeCtxt
-  = FunSigCtxt Name     -- Function type signature
-                        -- Also used for types in SPECIALISE pragmas
+  = FunSigCtxt Name Bool    -- Function type signature, when checking the type
+                            -- Also used for types in SPECIALISE pragmas
+                            -- Bool = True  <=> report redundant class constraints
+                            --        False <=> do not
+                            -- See Note [Tracking redundant constraints] in TcSimplify
+
   | InfSigCtxt Name     -- Inferred type for function
   | ExprSigCtxt         -- Expression type signature
   | ConArgCtxt Name     -- Data constructor argument
@@ -528,8 +532,8 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })
                 FlatMetaTv  -> ptext (sLit "fuv")
 
 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
+pprUserTypeCtxt (FunSigCtxt n _)  = ptext (sLit "the type signature for") <+> quotes (ppr n)
 pprUserTypeCtxt (InfSigCtxt n)    = ptext (sLit "the inferred type for") <+> quotes (ppr n)
-pprUserTypeCtxt (FunSigCtxt n)    = ptext (sLit "the type signature for") <+> quotes (ppr n)
 pprUserTypeCtxt (RuleSigCtxt n)   = ptext (sLit "a RULE for") <+> quotes (ppr n)
 pprUserTypeCtxt ExprSigCtxt       = ptext (sLit "an expression type signature")
 pprUserTypeCtxt (ConArgCtxt c)    = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
@@ -556,10 +560,10 @@ pprSigCtxt ctxt extra pp_ty
   = sep [ ptext (sLit "In") <+> extra <+> pprUserTypeCtxt ctxt <> colon
         , nest 2 (pp_sig ctxt) ]
   where
-    pp_sig (FunSigCtxt n = pp_n_colon n
-    pp_sig (ConArgCtxt n)  = pp_n_colon n
-    pp_sig (ForSigCtxt n)  = pp_n_colon n
-    pp_sig _               = pp_ty
+    pp_sig (FunSigCtxt n _) = pp_n_colon n
+    pp_sig (ConArgCtxt n)   = pp_n_colon n
+    pp_sig (ForSigCtxt n)   = pp_n_colon n
+    pp_sig _                = pp_ty
 
     pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty
 
index 21e81db..93f3f11 100644 (file)
@@ -12,7 +12,7 @@ module TcUnify (
   -- Full-blown subsumption
   tcWrapResult, tcGen,
   tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC,
-  checkConstraints, checkScConstraints,
+  checkConstraints,
 
   -- Various unifications
   unifyType, unifyTypeList, unifyTheta,
@@ -567,9 +567,7 @@ checkConstraints skol_info skol_tvs given thing_inside
   | otherwise
   = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
     ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
-    do { ((result, tclvl), wanted) <- captureConstraints  $
-                                      captureTcLevel $
-                                      thing_inside
+    do { (result, tclvl, wanted) <- pushLevelAndCaptureConstraints thing_inside
 
        ; if isEmptyWC wanted && null given
             -- Optimisation : if there are no wanteds, and no givens
@@ -586,42 +584,13 @@ checkConstraints skol_info skol_tvs given thing_inside
                                   , ic_no_eqs = False
                                   , ic_given = given
                                   , ic_wanted = wanted
-                                  , ic_insol  = insolubleWC wanted
+                                  , ic_status  = IC_Unsolved
                                   , ic_binds = ev_binds_var
                                   , ic_env = env
                                   , ic_info = skol_info }
 
        ; return (TcEvBinds ev_binds_var, result) } }
 
-checkScConstraints :: SkolemInfo
-                   -> [TcTyVar]           -- Skolems
-                   -> [EvVar]             -- Given
-                   -> (EvBindsVar -> TcM (Bool, result))
-                   -> TcM (TcEvBinds, result)
-
--- Like checkConstraints, but the thing_inside 
--- can generate its own evidence bindings
-checkScConstraints skol_info skol_tvs given thing_inside
-  = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
-    ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
-    do { ev_binds_var <- newTcEvBinds
-       ; (((ok, result), tclvl), wanted) <- captureConstraints  $
-                                            captureTcLevel $
-                                            thing_inside ev_binds_var
-
-       ; env <- getLclEnv
-       ; emitImplication $ Implic { ic_tclvl  = tclvl
-                                  , ic_skols  = skol_tvs
-                                  , ic_no_eqs = False
-                                  , ic_given  = if ok then given else []
-                                  , ic_wanted = wanted
-                                  , ic_insol  = insolubleWC wanted
-                                  , ic_binds  = ev_binds_var
-                                  , ic_env    = env
-                                  , ic_info   = skol_info }
-
-       ; return (TcEvBinds ev_binds_var, result) }
-
 {-
 ************************************************************************
 *                                                                      *
index 5078ede..f6067e6 100644 (file)
@@ -159,7 +159,7 @@ checkValidType ctxt ty
                  TySynCtxt _    -> rank0
 
                  ExprSigCtxt    -> rank1
-                 FunSigCtxt _   -> rank1
+                 FunSigCtxt _ _ -> rank1
                  InfSigCtxt _   -> ArbitraryRank        -- Inferred type
                  ConArgCtxt _   -> rank1 -- We are given the type of the entire
                                          -- constructor, hence rank 1
index 95feaed..8fbfa13 100644 (file)
@@ -15,7 +15,7 @@ module Bag (
         mapBag,
         elemBag, lengthBag,
         filterBag, partitionBag, partitionBagWith,
-        concatBag, foldBag, foldrBag, foldlBag,
+        concatBag, catBagMaybes, foldBag, foldrBag, foldlBag,
         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
         listToBag, bagToList,
         foldrBagM, foldlBagM, mapBagM, mapBagM_,
@@ -99,10 +99,15 @@ anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2
 anyBag p (ListBag xs)    = any p xs
 
 concatBag :: Bag (Bag a) -> Bag a
-concatBag EmptyBag        = EmptyBag
-concatBag (UnitBag b)     = b
-concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2
-concatBag (ListBag bs)    = unionManyBags bs
+concatBag bss = foldrBag add emptyBag bss
+  where
+    add bs rs = bs `unionBags` rs
+
+catBagMaybes :: Bag (Maybe a) -> Bag a
+catBagMaybes bs = foldrBag add emptyBag bs
+  where
+    add Nothing rs = rs
+    add (Just x) rs = x `consBag` rs
 
 partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
                                          Bag a {- Don't -})
index aa3a19b..a1dacb4 100644 (file)
@@ -553,6 +553,8 @@ list giving the break-off point:
 -}
 
 takeList :: [b] -> [a] -> [a]
+-- (takeList as bs) trims bs to the be same length
+-- as as, unless as is longer in which case it's a no-op
 takeList [] _ = []
 takeList (_:xs) ls =
    case ls of
index 3059cff..88dbdb7 100644 (file)
@@ -1408,6 +1408,38 @@ foreign import "&amp;f" f :: FunPtr t
           The warning will indicate the duplicated <literal>Eq a</literal> constraint.
           </para>
 
+          <para>This option is now deprecated in favour of <option>-fwarn-redundant-constraints</option>.</para>
+        </listitem>
+      </varlistentry>
+
+      <varlistentry>
+        <term><option>-fwarn-redundant-constraints</option>:</term>
+        <listitem>
+          <indexterm><primary><option>-fwarn-redundant-constraints</option></primary></indexterm>
+          <indexterm><primary>redundant constraints, warning</primary></indexterm>
+
+          <para>Have the compiler warn about redundant constraints in a type signature. For
+          example
+          <itemizedlist>
+          <listitem><para>
+          <programlisting>
+             f :: (Eq a, Ord a) => a -> a
+          </programlisting>
+          The warning will indicate the redundant <literal>Eq a</literal> constraint:
+          it is subsumed by the <literal>Ord a</literal> constraint.
+          </para></listitem>
+          <listitem><para>
+          <programlisting>
+             f :: Eq a => a -> a -> Bool
+             f x y = True
+          </programlisting>
+          The warning will indicate the redundant <literal>Eq a</literal> constraint:
+          : it is not used by the definition of <literal>f</literal>.)
+          </para></listitem>
+          </itemizedlist>
+          Similar warnings are given for a redundant constraint in an instance declaration.
+          </para>
+
           <para>This option is on by default.</para>
         </listitem>
       </varlistentry>
index 56b1117..dda06cf 100644 (file)
@@ -1,4 +1,5 @@
-{-# OPTIONS -XArrows #-}
+{-# LANGUAGE Arrows #-}
+{-# OPTIONS -fno-warn-redundant-constraints #-}
 
 -- Test for Trac #1662
 
index 0cc852d..22c810d 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-redundant-constraints #-}
 
 module T3286 (train) where
 
index c8f81a0..fc30958 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances #-}
 
 -- Test Trac #2856
index 363627a..85245b7 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS -fno-warn-redundant-constraints #-}
+
 {-# LANGUAGE DatatypeContexts #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleInstances #-}
index dceeaa6..765c697 100644 (file)
@@ -1,8 +1,8 @@
 
-T4966.hs:1:14: Warning:
+T4966.hs:3:14: Warning:
     -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language.
 
-T4966.hs:33:30: Warning:
+T4966.hs:35:30: Warning:
     No explicit implementation for
       either ‘==’ or ‘/=’
     In the instance declaration for ‘Eq (TreeListObject a)’
index 5b3bca0..8bccd58 100644 (file)
@@ -3,6 +3,8 @@
 -- Trac #1935
 -- See Note [Superclasses of derived instance] in TcDeriv
 
+{-# OPTIONS -fno-warn-redundant-constraints #-}
+
 module Foo where
 
  import Data.Data
index bf2c79c..9901a36 100644 (file)
@@ -1,15 +1,15 @@
 
-deriving-1935.hs:15:11: Warning:
+deriving-1935.hs:17:11: Warning:
     No explicit implementation for
       either ‘==’ or ‘/=’
     In the instance declaration for ‘Eq (T a)’
 
-deriving-1935.hs:18:11: Warning:
+deriving-1935.hs:20:11: Warning:
     No explicit implementation for
       either ‘==’ or ‘/=’
     In the instance declaration for ‘Eq (S a)’
 
-deriving-1935.hs:19:11: Warning:
+deriving-1935.hs:21:11: Warning:
     No explicit implementation for
       either ‘compare’ or ‘<=’
     In the instance declaration for ‘Ord (S a)’
index 694af6a..3afd394 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS -fno-warn-redundant-constraints #-}
+
 -- !!! canonical weird example for "deriving"
 module ShouldSucceed where
 
index 15eb2d9..9ccb7b7 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS -fno-warn-redundant-constraints #-}
+
 module ShouldSucceed where
 
 data Z a b
index 0b8149c..6fdd763 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS -fno-warn-redundant-constraints #-}
+
 -- !!! This is the example given in TcDeriv
 --
 module ShouldSucceed where
index 6d9819f..ead606d 100644 (file)
@@ -1,10 +1,10 @@
 
-drv003.hs:12:10: Warning:
+drv003.hs:14:10: Warning:
     No explicit implementation for
       either ‘==’ or ‘/=’
     In the instance declaration for ‘Eq (Foo a)’
 
-drv003.hs:15:10: Warning:
+drv003.hs:17:10: Warning:
     No explicit implementation for
       either ‘==’ or ‘/=’
     In the instance declaration for ‘Eq (Bar b)’
index 6f8bf7f..954b2d9 100644 (file)
@@ -5,7 +5,7 @@ T9576: T9576.hs:6:31:
       ‘((.) (showString "MkBar ") (showsPrec 11 b1))’
     In the expression:
       showParen ((a >= 11)) ((.) (showString "MkBar ") (showsPrec 11 b1))
-    When typechecking the code for  ‘showsPrec’
+    When typechecking the code for ‘showsPrec’
       in a derived instance for ‘Show Bar’:
       To see the code I am typechecking, use -ddump-deriv
 (deferred type error)
index 30b5713..e3b8e3a 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -O #-}
+{-# OPTIONS_GHC -O -fno-warn-redundant-constraints #-}
 
 module Gadt17_help (
       TernOp (..), applyTernOp
index b5b8503..084dc2f 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE Arrows, FunctionalDependencies, FlexibleContexts, 
              MultiParamTypeClasses, RecordWildCards  #-}
 
index 29fe7a8..82a34af 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE KindSignatures #-}
index 1527476..b0c52d3 100644 (file)
@@ -1,3 +1,4 @@
+:set -fno-warn-redundant-constraints
 :m +Data.Typeable
 let {f :: Typeable a => (a->Bool) -> Bool; f _ = True}
 f (\x -> (x == 3))
index d6f12ad..d86557d 100644 (file)
@@ -1,3 +1,4 @@
+:set -fno-warn-redundant-constraints
 --Testing flexible and Overlapping instances
 class C a where { f :: a -> String; f _ = "Default" }
 instance C Int where { f _ = "Zeroth" }
index 9bc8df9..625696a 100644 (file)
@@ -1,8 +1,8 @@
 
-<interactive>:9:1:
+<interactive>:10:1:
     Overlapping instances for C [Int] arising from a use of ‘f’
     Matching instances:
-      instance C [Int] -- Defined at <interactive>:6:10
-      instance C a => C [a] -- Defined at <interactive>:8:10
+      instance C [Int] -- Defined at <interactive>:7:10
+      instance C a => C [a] -- Defined at <interactive>:9:10
     In the expression: f [4 :: Int]
     In an equation for ‘it’: it = f [4 :: Int]
index 70cc518..d1ceefd 100644 (file)
@@ -1,4 +1,5 @@
 --Testing GADTs, type families as well as a ton of crazy type stuff
+:set -fno-warn-redundant-constraints
 :set -XGADTs
 :set -XTypeFamilies
 :set -XFunctionalDependencies
index dc8dfc9..9428dbc 100644 (file)
@@ -1,5 +1,5 @@
 
-<interactive>:38:1:
+<interactive>:39:1:
     Couldn't match type ‘HFalse’ with ‘HTrue’
     Expected type: HTrue
       Actual type: Or HFalse HFalse
@@ -7,7 +7,7 @@
     In the expression: f $ Baz 'a'
     In an equation for ‘it’: it = f $ Baz 'a'
 
-<interactive>:39:1:
+<interactive>:40:1:
     Couldn't match type ‘HFalse’ with ‘HTrue’
     Expected type: HTrue
       Actual type: Or HFalse HFalse
index 8336cb5..da149d0 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Test
index cde205a..2522579 100644 (file)
@@ -186,10 +186,10 @@ m = undefined
 
 
 
-Test.hs:32:9: Warning: ‘p’ is exported by ‘p’ and ‘R(..)’
+Test.hs:33:9: Warning: ‘p’ is exported by ‘p’ and ‘R(..)’
 
-Test.hs:32:12: Warning: ‘q’ is exported by ‘q’ and ‘R(..)’
+Test.hs:33:12: Warning: ‘q’ is exported by ‘q’ and ‘R(..)’
 
-Test.hs:32:15: Warning: ‘u’ is exported by ‘u’ and ‘R(..)’
+Test.hs:33:15: Warning: ‘u’ is exported by ‘u’ and ‘R(..)’
 
-Test.hs:38:9: Warning: ‘a’ is exported by ‘a’ and ‘C(a, b)’
+Test.hs:39:9: Warning: ‘a’ is exported by ‘a’ and ‘C(a, b)’
index e197a6b..4d1f407 100644 (file)
@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module ShouldCompile where
 
-test :: (Eq a) => [a] -- ^ doc1 
-               -> [a] {-^ doc2 -} 
+test :: (Eq a) => [a] -- ^ doc1
+               -> [a] {-^ doc2 -}
                -> [a] -- ^ doc3
 test xs ys = xs
index cc2d8bf..14d7a26 100644 (file)
@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module ShouldCompile where
 
-test :: (Eq a) => [a] -- ^ doc1 
-               -> forall b . [b] {-^ doc2 -} 
+test :: (Eq a) => [a] -- ^ doc1
+               -> forall b . [b] {-^ doc2 -}
                -> [a] -- ^ doc3
 test xs ys = xs
index 1aa6e37..8e03bc2 100644 (file)
@@ -1,7 +1,9 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module ShouldCompile where
 
-test :: [a] -- ^ doc1 
-        -> forall b. (Ord b) => [b] {-^ doc2 -} 
+test :: [a] -- ^ doc1
+        -> forall b. (Ord b) => [b] {-^ doc2 -}
         -> forall c. (Num c) => [c] -- ^ doc3
         -> [a]
 test xs ys zs = xs
index cc2d8bf..14d7a26 100644 (file)
@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module ShouldCompile where
 
-test :: (Eq a) => [a] -- ^ doc1 
-               -> forall b . [b] {-^ doc2 -} 
+test :: (Eq a) => [a] -- ^ doc1
+               -> forall b . [b] {-^ doc2 -}
                -> [a] -- ^ doc3
 test xs ys = xs
index c22be2f..4d6a8c2 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 module ShouldCompile where
 
 -- I bet this test is a mistake!  From the layout it 
index f0d90f3..04da8d5 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Class2 where
index 7ceedfd..5406493 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
              FlexibleInstances,
              UndecidableInstances #-}
index 58ff8f8..87aecb0 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts #-}
 {-# LANGUAGE EmptyDataDecls, FlexibleInstances, UndecidableInstances #-}
 
index e178e11..f3bf5cf 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module InstEqContext  where 
index c5d017a..0140d3e 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, EmptyDataDecls #-}
 
 module InstEqContext2  where 
index 3f307f8..032ef34 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module InstEqContext  where 
index 26ea632..d500b32 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, EmptyDataDecls, FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
index b936349..afb8bc2 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Rules1 where
index de33458..fbca4aa 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}
 
 module Simple24 where
index 806df3f..7393eb1 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, UndecidableInstances #-}
 
 module T2448 where
index 26966da..116e9c7 100644 (file)
@@ -1,5 +1,6 @@
-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# OPTIONS_GHC -fwarn-missing-signatures #-}
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}
 
 module Bug where
 
index 68066ba..81afa91 100644 (file)
@@ -1,4 +1,3 @@
 
-T3023.hs:17:1:
-    Warning: Top-level binding with no type signature:
-               bar :: Bool -> Bool
+T3023.hs:18:1: Warning:
+    Top-level binding with no type signature: bar :: Bool -> Bool
index 4d15709..e558cbb 100644 (file)
@@ -1,5 +1,6 @@
+{-# OPTIONS_GHC -Wall -fno-warn-redundant-constraints #-}
 {-# LANGUAGE GADTs, RankNTypes, TypeFamilies, FlexibleContexts, ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wall #-}
+
 module Absurd where
 
 data Z = Z
index 0d0e23a..feb91e8 100644 (file)
@@ -1,12 +1,13 @@
-{-# LANGUAGE TypeFamilies #-}\r
-\r
-module T4200 where\r
-\r
-class C a where\r
-  type In a :: *\r
-  op :: In a -> Int\r
-\r
--- Should be ok; no -XUndecidableInstances required\r
-instance (In c ~ Int) => C [c] where \r
-  type In [c] = In c\r
-  op x = 3\r
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module T4200 where
+
+class C a where
+  type In a :: *
+  op :: In a -> Int
+
+-- Should be ok; no -XUndecidableInstances required
+instance (In c ~ Int) => C [c] where 
+  type In [c] = In c
+  op x = 3
index 57d3d48..07702be 100644 (file)
@@ -1,15 +1,16 @@
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}  \r
-\r
-module T4497 where\r
-\r
-norm2PropR a = twiddle (norm2 a) a\r
-\r
-twiddle :: Normed a => a -> a -> Double  \r
-twiddle a b = undefined\r
-\r
-norm2 :: e -> RealOf e\r
-norm2 = undefined\r
-\r
-class (Num (RealOf t)) => Normed t\r
-\r
-type family RealOf x\r
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, TypeFamilies #-}  
+
+module T4497 where
+
+norm2PropR a = twiddle (norm2 a) a
+
+twiddle :: Normed a => a -> a -> Double  
+twiddle a b = undefined
+
+norm2 :: e -> RealOf e
+norm2 = undefined
+
+class (Num (RealOf t)) => Normed t
+
+type family RealOf x
index 6290287..47e3b1c 100644 (file)
@@ -1,34 +1,36 @@
-{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}\r
-module Class ( cleverNamedResolve ) where\r
-\r
-data FL p = FL p\r
-\r
-class PatchInspect p where\r
-instance PatchInspect p => PatchInspect (FL p) where\r
-\r
-type family PrimOf p\r
-type instance PrimOf (FL p) = PrimOf p\r
-\r
-data WithName prim = WithName prim\r
-\r
-instance PatchInspect prim => PatchInspect (WithName prim) where\r
-\r
-class (PatchInspect (PrimOf p)) => Conflict p where\r
-    resolveConflicts :: p -> PrimOf p\r
-\r
-instance Conflict p => Conflict (FL p) where\r
-    resolveConflicts = undefined\r
-\r
-type family OnPrim p\r
-\r
-class FromPrims p where\r
-\r
-instance FromPrims (FL p) where\r
-\r
-joinPatches :: FromPrims p => p -> p\r
-joinPatches = id \r
-\r
-cleverNamedResolve :: (Conflict (OnPrim p)\r
-                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))\r
-                   => p -> FL (OnPrim p) -> WithName (PrimOf p)\r
-cleverNamedResolve x = resolveConflicts . joinPatches\r
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}
+
+module Class ( cleverNamedResolve ) where
+
+data FL p = FL p
+
+class PatchInspect p where
+instance PatchInspect p => PatchInspect (FL p) where
+
+type family PrimOf p
+type instance PrimOf (FL p) = PrimOf p
+
+data WithName prim = WithName prim
+
+instance PatchInspect prim => PatchInspect (WithName prim) where
+
+class (PatchInspect (PrimOf p)) => Conflict p where
+    resolveConflicts :: p -> PrimOf p
+
+instance Conflict p => Conflict (FL p) where
+    resolveConflicts = undefined
+
+type family OnPrim p
+
+class FromPrims p where
+
+instance FromPrims (FL p) where
+
+joinPatches :: FromPrims p => p -> p
+joinPatches = id 
+
+cleverNamedResolve :: (Conflict (OnPrim p)
+                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
+                   => p -> FL (OnPrim p) -> WithName (PrimOf p)
+cleverNamedResolve x = resolveConflicts . joinPatches
index 716f161..6b1d472 100644 (file)
@@ -1,31 +1,33 @@
-{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}\r
-module Class ( cleverNamedResolve ) where\r
-\r
-data FL p = FL p\r
-\r
-class PatchInspect p where\r
-instance PatchInspect p => PatchInspect (FL p) where\r
-\r
-type family PrimOf p\r
-type instance PrimOf (FL p) = PrimOf p\r
-\r
-data WithName prim = WithName prim\r
-\r
-instance PatchInspect prim => PatchInspect (WithName prim) where\r
-\r
-class (PatchInspect (PrimOf p)) => Conflict p where\r
-    resolveConflicts :: p -> PrimOf p\r
-\r
-instance Conflict p => Conflict (FL p) where\r
-    resolveConflicts = undefined\r
-\r
-type family OnPrim p\r
-\r
-joinPatches :: FL p -> FL p\r
-\r
-joinPatches = id\r
-\r
-cleverNamedResolve :: (Conflict (OnPrim p)\r
-                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))\r
-                   => p -> FL (OnPrim p) -> WithName (PrimOf p)\r
-cleverNamedResolve x = resolveConflicts . joinPatches\r
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}
+
+module Class ( cleverNamedResolve ) where
+
+data FL p = FL p
+
+class PatchInspect p where
+instance PatchInspect p => PatchInspect (FL p) where
+
+type family PrimOf p
+type instance PrimOf (FL p) = PrimOf p
+
+data WithName prim = WithName prim
+
+instance PatchInspect prim => PatchInspect (WithName prim) where
+
+class (PatchInspect (PrimOf p)) => Conflict p where
+    resolveConflicts :: p -> PrimOf p
+
+instance Conflict p => Conflict (FL p) where
+    resolveConflicts = undefined
+
+type family OnPrim p
+
+joinPatches :: FL p -> FL p
+
+joinPatches = id
+
+cleverNamedResolve :: (Conflict (OnPrim p)
+                      ,PrimOf (OnPrim p) ~ WithName (PrimOf p))
+                   => p -> FL (OnPrim p) -> WithName (PrimOf p)
+cleverNamedResolve x = resolveConflicts . joinPatches
index e6bcd47..e0cd7ed 100644 (file)
@@ -1,4 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE CPP, TypeFamilies, FlexibleContexts #-}
+
 module Class ( cleverNamedResolve ) where
 
 data FL p = FL p
index cfc82d5..390c6ae 100644 (file)
@@ -1,29 +1,30 @@
-{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances, FlexibleContexts #-}\r
-\r
-class A a\r
-class B a where b :: a -> ()\r
-instance A a => B a where b = undefined\r
-\r
-newtype Y a = Y (a -> ())\r
-\r
-okIn701 :: B a => Y a\r
-okIn701 = wrap $ const () . b\r
-\r
-okIn702 :: B a => Y a\r
-okIn702 = wrap $ b\r
-\r
-okInBoth :: B a => Y a\r
-okInBoth = Y $ const () . b\r
-\r
-class Wrapper a where\r
-    type Wrapped a\r
-    wrap :: Wrapped a -> a\r
-instance Wrapper (Y a) where\r
-  type Wrapped (Y a) = a -> ()\r
-  wrap = Y\r
-\r
-fromTicket3018 :: Eq [a] => a -> ()\r
-fromTicket3018 x = let {g :: Int -> Int; g = [x]==[x] `seq` id} in ()\r
-\r
-main = undefined\r
-\r
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
+
+class A a
+class B a where b :: a -> ()
+instance A a => B a where b = undefined
+
+newtype Y a = Y (a -> ())
+
+okIn701 :: B a => Y a
+okIn701 = wrap $ const () . b
+
+okIn702 :: B a => Y a
+okIn702 = wrap $ b
+
+okInBoth :: B a => Y a
+okInBoth = Y $ const () . b
+
+class Wrapper a where
+    type Wrapped a
+    wrap :: Wrapped a -> a
+instance Wrapper (Y a) where
+  type Wrapped (Y a) = a -> ()
+  wrap = Y
+
+fromTicket3018 :: Eq [a] => a -> ()
+fromTicket3018 x = let {g :: Int -> Int; g = [x]==[x] `seq` id} in ()
+
+main = undefined
+
index 6d2b6ba..b3b639f 100644 (file)
@@ -1,4 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies #-}
+
 module T9090 where
 
 import GHC.Exts (Constraint)
index b5dfca6..ca7680c 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE DataKinds #-}
index 05b4397..0466cba 100644 (file)
@@ -1,4 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE ConstraintKinds, DataKinds, GADTs, TypeFamilies, TypeOperators #-}
+
 module T9747 where
 import Data.List (intercalate)
 import Data.Proxy
index d84ea17..52a8296 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE NoMonomorphismRestriction, RankNTypes #-}
 {-# LANGUAGE FunctionalDependencies, MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}
index afb9902..97a54ec 100644 (file)
@@ -6,5 +6,9 @@ T3330c.hs:23:43:
       R :: (* -> *) -> *
     Expected type: Der ((->) x) (f1 x)
       Actual type: R f1
+    Relevant bindings include
+      x :: x (bound at T3330c.hs:23:29)
+      df :: f1 x (bound at T3330c.hs:23:25)
+      plug' :: R f -> Der f x -> x -> f x (bound at T3330c.hs:23:1)
     In the first argument of ‘plug’, namely ‘rf’
     In the first argument of ‘Inl’, namely ‘(plug rf df x)’
index 050479b..081e0c9 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts #-}
 
 -- This used to fail because of the silent-superclass
index 3521aea..5a14fc3 100644 (file)
@@ -1,5 +1,5 @@
 
-T7862.hs:22:10: Warning:
+T7862.hs:23:10: Warning:
     No explicit implementation for
       ‘+’, ‘*’, ‘abs’, ‘signum’, ‘fromInteger’, and (either ‘negate’
                                                             or
index 4229e9e..caf5c72 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 -- !!! hiding class members (but not class.)
 module M where
 
index 7cf7e0b..12962aa 100644 (file)
@@ -9,3 +9,12 @@ mod71.hs:4:9:
     In the first argument of ‘x’, namely ‘_’
     In the expression: x _ 1
     In an equation for ‘f’: f x = x _ 1
+
+mod71.hs:4:11:
+    No instance for (Num a) arising from the literal ‘1’
+    Possible fix:
+      add (Num a) to the context of
+        the inferred type of f :: (t1 -> a -> t) -> t
+    In the second argument of ‘x’, namely ‘1’
+    In the expression: x _ 1
+    In an equation for ‘f’: f x = x _ 1
index 2976694..6197dc4 100644 (file)
@@ -5,7 +5,7 @@ module Foo where
 
 import Control.Monad.Zip
 
-foo :: (MonadZip m, Monad m) => m ()
+foo :: MonadZip m => m ()
 foo = [ ()
       | () <- foo
       | () <- foo
index 5b069fe..8d9ea5e 100644 (file)
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
 -- !!! tests fixity reading and printing
 module ShouldCompile where
 
index 52a532f..e83e070 100644 (file)
@@ -29,7 +29,7 @@ test('HigherRank2', normal, compile, ['-ddump-types -fno-warn-partial-type-signa
 test('LocalDefinitionBug', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('Meltdown', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 # Bug
-test('MonoLocalBinds', expect_fail, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
+test('MonoLocalBinds', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('NamedTyVar', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('ParensAroundContext', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
 test('PatBind', normal, compile, ['-ddump-types -fno-warn-partial-type-signatures'])
index d267d39..24147a2 100644 (file)
@@ -1,4 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE PatternSynonyms #-}
+
 module ShouldCompile where
 
 pattern Single :: () => (Show a) => a -> [a]
index f41ed53..a0e3285 100644 (file)
@@ -6,3 +6,4 @@ data X :: (* -> *) -> * -> * where
 
 pattern C :: a -> X Maybe (Maybe a)
 pattern C x = Y (Just x)
+
index 91c0012..d5d5eed 100644 (file)
@@ -15,8 +15,8 @@ test('T9732', normal, compile, [''])
 test('T8584-1', normal, compile, [''])
 test('T8584-2', normal, compile, [''])
 test('T8584-3', normal, compile, [''])
-test('T8968-1', normal, compile, [''])
+test('T8968-1', expect_broken(9953), compile, [''])
 test('T8968-2', normal, compile, [''])
-test('T8968-3', normal, compile, [''])
+test('T8968-3', expect_broken(9953), compile, [''])
 test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0'])
 test('T9857', normal, compile, [''])
index e317274..699b070 100644 (file)
@@ -1,6 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-}
+
 -- Pattern synonyms
 
-{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-}
 module ShouldCompile where
 
 data T a where
index 39a51de..53a87b5 100644 (file)
@@ -1,5 +1,7 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE Rank2Types, TypeSynonymInstances, FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}
+
 module T3064 where
 import Control.Applicative
 
index b65e9cd..6bb7478 100644 (file)
@@ -134,15 +134,15 @@ data Operation cpu resultSize where
 
 type CDM cpu a = IO a
 
-($=) :: CPU cpu => Var cpu size -> Operation cpu size -> CDM cpu ()
+($=) :: Var cpu size -> Operation cpu size -> CDM cpu ()
 var $= op = undefined
 
-tempVar :: CPU cpu => CDM cpu (Var cpu size)
+tempVar :: CDM cpu (Var cpu size)
 tempVar = do
         cnt <- liftM fst undefined
         return $ Temp cnt
 
-op :: CPU cpu => Operation cpu size -> CDM cpu (Var cpu size)
+op :: Operation cpu size -> CDM cpu (Var cpu size)
 op operation = do
         v <- tempVar
         v $= operation
index aa64345..1e01aaa 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE PolyKinds                  #-}
 
 module PolyKinds08 where
index f42019c..cb6104f 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE PolyKinds, KindSignatures, FunctionalDependencies,  FlexibleInstances,
               UndecidableInstances, TypeOperators, DataKinds,  FlexibleContexts #-}
 
index 0068978..abdee4d 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE DataKinds, FunctionalDependencies, FlexibleInstances,
               UndecidableInstances, PolyKinds, KindSignatures,
               ConstraintKinds, FlexibleContexts, GADTs #-}
index 9c754bd..0b414a8 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, GADTs, MultiParamTypeClasses,
              FunctionalDependencies, FlexibleInstances, UndecidableInstances, ExistentialQuantification #-}
 
index 2364b0c..8f0dbd1 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE GADTs, ConstraintKinds, TypeFamilies, 
     DataKinds, ScopedTypeVariables, TypeOperators #-}
 
index 647dd93..79623e9 100644 (file)
@@ -18,7 +18,7 @@ instance IsString (DC String) where
 
 
 class Monoid acc => Build acc r where
-    type BuildR r :: *         -- Result type
+    type BuildR r :: *          -- Result type
     build :: (acc -> BuildR r) -> acc -> r
 
 instance Monoid dc => Build dc (DC dx) where
@@ -31,9 +31,25 @@ instance (Build dc r, a ~ dc) => Build dc (a->r) where
 
 
 -- The type is inferred
-tspan :: (Monoid d, Build (DC d) r, BuildR r ~ DC d) => r
+-- tspan :: (Monoid d, Build (DC d) r, BuildR r ~ DC d) => r
+tspan :: (Build (DC d) r, BuildR r ~ DC d) => r
 tspan = build (id :: DC d -> DC d) mempty
 
+{- Wanted:
+       Build acc0 r0
+       Monid acc0
+       acc0 ~ DC d0
+       DC d0 ~ BuildR r0
+==>
+       Build (DC d0) r0
+       Monoid (DC d0)  -->  Monoid d0
+       DC d- ~ BuildR r0
+
+In fact Monoid (DC d0) is a superclass of (Build (DC do) r0)
+But during inference we do not take upserclasses of wanteds
+-}
+
+
 foo = tspan "aa"
 
 foo1 = tspan (tspan "aa")
index d172270..00fabf8 100644 (file)
@@ -1,4 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE ConstraintKinds, MultiParamTypeClasses #-}
+
 module T8359 where
 
 class DifferentTypes a b
index 012d61f..0e1fdd5 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE RankNTypes, ConstraintKinds, KindSignatures, DataKinds, TypeFamilies #-}
 module T9569 where
 
index 9d865d0..59b8e60 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE DataKinds              #-}
index 7b4f905..6adc356 100644 (file)
@@ -1,71 +1,72 @@
-{-# LANGUAGE\r
-    ExplicitForAll\r
-  , GADTs\r
-  , RebindableSyntax #-}\r
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}\r
-module T5821a \r
-       ( Writer\r
-       , runWriter\r
-       , execWriter\r
-       , WriterT\r
-       , runWriterT\r
-       , execWriterT\r
-       , tell\r
-       ) where\r
-\r
-import Control.Category (Category (id), (>>>))\r
-\r
-import Prelude hiding (Monad (..), id)\r
-import qualified Prelude\r
-\r
-newtype Identity a = Identity { runIdentity :: a }\r
-\r
-class Monad m where\r
-  (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b\r
-  (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b\r
-  return :: a -> m ex ex a\r
-  fail :: String -> m e x a\r
-  \r
-  {-# INLINE (>>) #-}\r
-  m >> k = m >>= \ _ -> k\r
-  fail = error\r
-\r
-type Writer w = WriterT w Identity\r
-\r
-runWriter :: Writer w e x a -> (a, w e x)\r
-runWriter = runIdentity . runWriterT\r
-\r
-execWriter :: Writer w e x a -> w e x\r
-execWriter m = snd (runWriter m)\r
-\r
-newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) }\r
-\r
-execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x)\r
-execWriterT m = do\r
-  ~(_, w) <- runWriterT m\r
-  return w\r
-  where\r
-    (>>=) = (Prelude.>>=)\r
-    return = Prelude.return\r
-\r
-instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where\r
-  return a = WriterT $ return (a, id)\r
-    where\r
-      return = Prelude.return\r
-  m >>= k = WriterT $ do\r
-    ~(a, w) <- runWriterT m\r
-    ~(b, w') <- runWriterT (k a)\r
-    return (b, w >>> w')\r
-    where\r
-      (>>=) = (Prelude.>>=)\r
-      return = Prelude.return\r
-  fail msg = WriterT $ fail msg\r
-    where\r
-      fail = Prelude.fail\r
-\r
-tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x ()\r
-tell w = WriterT $ return ((), w)\r
-  where\r
-    return = Prelude.return\r
-\r
-\r
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE
+    ExplicitForAll
+  , GADTs
+  , RebindableSyntax #-}
+module T5821a 
+       ( Writer
+       , runWriter
+       , execWriter
+       , WriterT
+       , runWriterT
+       , execWriterT
+       , tell
+       ) where
+
+import Control.Category (Category (id), (>>>))
+
+import Prelude hiding (Monad (..), id)
+import qualified Prelude
+
+newtype Identity a = Identity { runIdentity :: a }
+
+class Monad m where
+  (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b
+  (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b
+  return :: a -> m ex ex a
+  fail :: String -> m e x a
+  
+  {-# INLINE (>>) #-}
+  m >> k = m >>= \ _ -> k
+  fail = error
+
+type Writer w = WriterT w Identity
+
+runWriter :: Writer w e x a -> (a, w e x)
+runWriter = runIdentity . runWriterT
+
+execWriter :: Writer w e x a -> w e x
+execWriter m = snd (runWriter m)
+
+newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) }
+
+execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x)
+execWriterT m = do
+  ~(_, w) <- runWriterT m
+  return w
+  where
+    (>>=) = (Prelude.>>=)
+    return = Prelude.return
+
+instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where
+  return a = WriterT $ return (a, id)
+    where
+      return = Prelude.return
+  m >>= k = WriterT $ do
+    ~(a, w) <- runWriterT m
+    ~(b, w') <- runWriterT (k a)
+    return (b, w >>> w')
+    where
+      (>>=) = (Prelude.>>=)
+      return = Prelude.return
+  fail msg = WriterT $ fail msg
+    where
+      fail = Prelude.fail
+
+tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x ()
+tell w = WriterT $ return ((), w)
+  where
+    return = Prelude.return
+
+
index 120a93a..cd3c95a 100644 (file)
@@ -34,8 +34,8 @@ instance Bind Maybe [] [] where
   Just x  >>= f = f x
   Nothing >>= f = []
 
-instance Functor a => Bind Identity a a        where m >>= f = f (runIdentity m)
-instance Functor a => Bind a Identity a        where m >>= f = fmap (runIdentity . f) m
+instance              Bind Identity a a   where m >>= f = f (runIdentity m)
+instance Functor a => Bind a Identity a   where m >>= f = fmap (runIdentity . f) m
 
 instance Prelude.Monad m => Bind m m m where (>>=) = (Prelude.>>=)
 
index decd2e8..c6efc4d 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 -- !!! Error messages with scoped type variables
index 50b1e35..9eeb0a2 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE ScopedTypeVariables, FlexibleInstances  #-}
 
 -- This test has a deep nest of join points, which led to 
index 3cb0647..43463a1 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 module T4398 where
index 2f1f567..e2411e1 100644 (file)
@@ -1,22 +1,22 @@
-\r
-T4398.hs:5:11: Warning:\r
-    Forall'd constraint ‘Ord a’ is not bound in RULE lhs\r
-      Orig bndrs: [a, $dOrd, x, y]\r
-      Orig lhs: let {\r
-                  $dEq :: Eq a\r
-                  [LclId, Str=DmdType]\r
-                  $dEq = GHC.Classes.$p1Ord @ a $dOrd } in\r
-                f @ a\r
-                  ((\ ($dOrd :: Ord a) ->\r
-                      let {\r
-                        $dEq :: Eq a\r
-                        [LclId, Str=DmdType]\r
-                        $dEq = GHC.Classes.$p1Ord @ a $dOrd } in\r
-                      let {\r
-                        $dEq :: Eq a\r
-                        [LclId, Str=DmdType]\r
-                        $dEq = GHC.Classes.$p1Ord @ a $dOrd } in\r
-                      x)\r
-                     $dOrd)\r
-                  y\r
-      optimised lhs: f @ a x y\r
+
+T4398.hs:6:11: Warning:
+    Forall'd constraint ‘Ord a’ is not bound in RULE lhs
+      Orig bndrs: [a, $dOrd, x, y]
+      Orig lhs: let {
+                  $dEq :: Eq a
+                  [LclId, Str=DmdType]
+                  $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+                f @ a
+                  ((\ ($dOrd :: Ord a) ->
+                      let {
+                        $dEq :: Eq a
+                        [LclId, Str=DmdType]
+                        $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+                      let {
+                        $dEq :: Eq a
+                        [LclId, Str=DmdType]
+                        $dEq = GHC.Classes.$p1Ord @ a $dOrd } in
+                      x)
+                     $dOrd)
+                  y
+      optimised lhs: f @ a x y
index cf65911..f681103 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE UnicodeSyntax #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE TypeOperators #-}
index eedd704..c9a3130 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 module T5342 (increaseAreas) where
 
 import Control.Monad
index f1ce209..bff4b49 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
index 2802476..75dde28 100644 (file)
@@ -1,3 +1,3 @@
 
-T5359b.hs:61:1: Warning:
+T5359b.hs:62:1: Warning:
     SPECIALISE pragma on INLINE function probably won't fire: ‘genum’
index 1ddfe94..d0f48bd 100644 (file)
@@ -1,5 +1,6 @@
-{-# LANGUAGE KindSignatures, GADTs, DataKinds, FlexibleInstances, FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# LANGUAGE KindSignatures, GADTs, DataKinds, FlexibleInstances, FlexibleContexts #-}
 
 module T8848 where
 
index 23ada00..4cb1385 100644 (file)
@@ -1,77 +1,77 @@
-Rule fired: Class op pure\r
-Rule fired: Class op <*>\r
-Rule fired: Class op <*>\r
-Rule fired: SPEC map2\r
-Rule fired: Class op fmap\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: Class op fmap\r
-Rule fired: Class op fmap\r
-Rule fired: SPEC $cfmap @ 'Z\r
-Rule fired: SPEC $c<$ @ 'Z\r
-Rule fired: SPEC $fFunctorShape @ 'Z\r
-Rule fired: Class op fmap\r
-Rule fired: Class op fmap\r
-Rule fired: SPEC $c<$ @ 'Z\r
-Rule fired: SPEC $fFunctorShape @ 'Z\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: SPEC $fFunctorShape @ 'Z\r
-Rule fired: SPEC $cp0Applicative @ 'Z\r
-Rule fired: SPEC $cpure @ 'Z\r
-Rule fired: SPEC $c<*> @ 'Z\r
-Rule fired: SPEC $c*> @ 'Z\r
-Rule fired: SPEC $c<* @ 'Z\r
-Rule fired: SPEC $fApplicativeShape @ 'Z\r
-Rule fired: SPEC $fApplicativeShape @ 'Z\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: SPEC $c<* @ 'Z\r
-Rule fired: SPEC $c*> @ 'Z\r
-Rule fired: SPEC $fApplicativeShape @ 'Z\r
-Rule fired: SPEC $fApplicativeShape @ 'Z\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z))\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op fmap\r
-Rule fired: Class op <*>\r
-Rule fired: SPEC $fApplicativeShape @ 'Z\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: Class op $p1Applicative\r
-Rule fired: Class op <$\r
-Rule fired: Class op <*>\r
-Rule fired: SPEC $fFunctorShape @ 'Z\r
-Rule fired: Class op fmap\r
-Rule fired: Class op fmap\r
+Rule fired: Class op pure
+Rule fired: Class op <*>
+Rule fired: Class op <*>
+Rule fired: SPEC map2
+Rule fired: Class op fmap
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape 'Z)
+Rule fired: Class op $p1Applicative
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: Class op fmap
+Rule fired: Class op fmap
+Rule fired: SPEC $cfmap @ 'Z
+Rule fired: SPEC $c<$ @ 'Z
+Rule fired: SPEC $fFunctorShape @ 'Z
+Rule fired: Class op fmap
+Rule fired: Class op fmap
+Rule fired: SPEC $c<$ @ 'Z
+Rule fired: SPEC $fFunctorShape @ 'Z
+Rule fired: Class op $p1Applicative
+Rule fired: SPEC $fFunctorShape @ 'Z
+Rule fired: SPEC $cp1Applicative @ 'Z
+Rule fired: SPEC $cpure @ 'Z
+Rule fired: SPEC $c<*> @ 'Z
+Rule fired: SPEC $c*> @ 'Z
+Rule fired: SPEC $c<* @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: SPEC $c<* @ 'Z
+Rule fired: SPEC $c*> @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: SPEC/T8848 liftA2 _ _ _ @ (Shape ('S 'Z))
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: SPEC $fApplicativeShape @ 'Z
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <$
+Rule fired: Class op <*>
+Rule fired: SPEC $fFunctorShape @ 'Z
+Rule fired: Class op fmap
+Rule fired: Class op fmap
index 81e757f..9df4c5b 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
 module T8848a where
 
 f :: Ord a => b -> a -&g