Warn about simplifiable class constraints
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 21 Apr 2016 12:06:54 +0000 (13:06 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 22 Apr 2016 10:32:31 +0000 (11:32 +0100)
Provoked by Trac #11948, this patch adds a new warning to GHC

  -Wsimplifiable-class-constraints

It warns if you write a class constraint in a type signature that
can be simplified by an existing instance declaration.  Almost always
this means you should simplify it right now; type inference is very
fragile without it, as #11948 shows.

I've put the warning as on-by-default, but I suppose that if there are
howls of protest we can move it out (as happened for -Wredundant-constraints.

It actually found an example of an over-complicated context in CmmNode.

Quite a few tests use these weird contexts to trigger something else,
so I had to suppress the warning in those.

The 'haskeline' library has a few occurrences of the warning (which
I think should be fixed), so I switched it off for that library in
warnings.mk.

The warning itself is done in TcValidity.check_class_pred.

HOWEVER, when type inference fails we get a type error; and the error
suppresses the (informative) warning.  So as things stand, the warning
only happens when it doesn't cause a problem.  Not sure what to do
about this, but this patch takes us forward, I think.

31 files changed:
compiler/basicTypes/BasicTypes.hs
compiler/cmm/CmmNode.hs
compiler/main/DynFlags.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcValidity.hs
compiler/types/InstEnv.hs
docs/users_guide/using-warnings.rst
mk/warnings.mk
testsuite/tests/dependent/should_compile/dynamic-paper.hs
testsuite/tests/ghci/scripts/ghci047.script
testsuite/tests/ghci/scripts/ghci047.stderr
testsuite/tests/indexed-types/should_compile/Gentle.hs
testsuite/tests/indexed-types/should_compile/NonLinearLHS.hs
testsuite/tests/indexed-types/should_compile/T11067.hs
testsuite/tests/indexed-types/should_compile/T5002.hs
testsuite/tests/partial-sigs/should_compile/SomethingShowable.stderr
testsuite/tests/polykinds/T6020a.hs
testsuite/tests/simplCore/should_compile/simpl014.hs
testsuite/tests/th/T3100.hs
testsuite/tests/typecheck/should_compile/GivenOverlapping.hs
testsuite/tests/typecheck/should_compile/T10195.hs
testsuite/tests/typecheck/should_compile/T3108.hs
testsuite/tests/typecheck/should_compile/T4361.hs
testsuite/tests/typecheck/should_compile/T6055.hs
testsuite/tests/typecheck/should_compile/T7541.hs
testsuite/tests/typecheck/should_compile/T7875.hs
testsuite/tests/typecheck/should_compile/tc229.hs
testsuite/tests/typecheck/should_fail/T11948.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T11948.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 54534d2..8cec412 100644 (file)
@@ -42,7 +42,7 @@ module BasicTypes(
         TopLevelFlag(..), isTopLevel, isNotTopLevel,
 
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
-        hasOverlappingFlag, hasOverlappableFlag,
+        hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag,
 
         Boxity(..), isBoxed,
 
@@ -492,6 +492,12 @@ setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
 setOverlapModeMaybe f Nothing  = f
 setOverlapModeMaybe f (Just m) = f { overlapMode = m }
 
+hasIncoherentFlag :: OverlapMode -> Bool
+hasIncoherentFlag mode =
+  case mode of
+    Incoherent   _ -> True
+    _              -> False
+
 hasOverlappableFlag :: OverlapMode -> Bool
 hasOverlappableFlag mode =
   case mode of
index 40bb5a0..c93639c 100644 (file)
@@ -335,7 +335,7 @@ instance UserOfRegs GlobalReg (CmmNode e x) where
                        (b -> GlobalReg -> b) -> b -> a -> b
           fold f z n = foldRegsUsed dflags f z n
 
-instance (Ord r, UserOfRegs r CmmExpr) => UserOfRegs r ForeignTarget where
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
   -- The (Ord r) in the context is necessary here
   -- See Note [Recursive superclasses] in TcInstDcls
   foldRegsUsed _      _ z (PrimTarget _)      = z
index e43869e..82cdf1b 100644 (file)
@@ -607,6 +607,7 @@ data WarningFlag =
    | Opt_WarnNonCanonicalMonoidInstances  -- since 8.0
    | Opt_WarnMissingPatternSynonymSignatures -- since 8.0
    | Opt_WarnUnrecognisedWarningFlags     -- since 8.0
+   | Opt_WarnSimplifiableClassConstraints -- Since 8.2
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -3289,6 +3290,7 @@ wWarningFlagsDeps = [
   flagSpec "wrong-do-bind"               Opt_WarnWrongDoBind,
   flagSpec "missing-pattern-synonym-signatures"
                                     Opt_WarnMissingPatternSynonymSignatures,
+  flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,
   flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
@@ -3887,7 +3889,8 @@ standardWarnings -- see Note [Documenting warning flags]
         Opt_WarnAlternativeLayoutRuleTransitional,
         Opt_WarnUnsupportedLlvmVersion,
         Opt_WarnTabs,
-        Opt_WarnUnrecognisedWarningFlags
+        Opt_WarnUnrecognisedWarningFlags,
+        Opt_WarnSimplifiableClassConstraints
       ]
 
 -- | Things you get with -W
index c7ec560..f451af9 100644 (file)
@@ -1822,7 +1822,7 @@ if we react R beta [a] with the top-level we get  (beta ~ a), which
 is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
 now solvable by the given Q [a].
 
-The solution is that:
+The partial solution is that:
   In matchClassInst (and thus in topReact), we return a matching
   instance only when there is no Given in the inerts which is
   unifiable to this particular dictionary.
@@ -1864,6 +1864,19 @@ Other notes:
 
   But for the Given Overlap check our goal is just related to completeness of
   constraint solving.
+
+* The solution is only a partial one.  Consider the above example with
+       g :: forall a. Q [a] => [a] -> Int
+       g x = let v = wob x
+             in v
+  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
+  general type for 'v'.  When generalising v's type we'll simplify its
+  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
+  will use the instance declaration after all. Trac #11948 was a case in point
+
+All of this is disgustingly delicate, so to discourage people from writing
+simplifiable class givens, we warn about signatures that contain them;#
+see TcValidity Note [Simplifiable given constraints].
 -}
 
 
index 0a6b499..40a5a6f 100644 (file)
@@ -527,7 +527,7 @@ data UserTypeCtxt
   | ClassSCCtxt Name    -- Superclasses of a class
   | SigmaCtxt           -- Theta part of a normal for-all type
                         --      f :: <S> => a -> a
-  | DataTyCtxt Name     -- Theta part of a data decl
+  | DataTyCtxt Name     -- The "stupid theta" part of a data decl
                         --      data <S> => T a = MkT a
 
 {-
index e710c6e..243d5d7 100644 (file)
@@ -40,7 +40,9 @@ import TyCon
 import HsSyn            -- HsType
 import TcRnMonad        -- TcType, amongst others
 import TcHsSyn     ( checkForRepresentationPolymorphism )
+import TcEnv       ( tcGetInstEnvs )
 import FunDeps
+import InstEnv     ( ClsInst, lookupInstEnv, isOverlappable )
 import FamInstEnv  ( isDominatedBy, injectiveBranches,
                      InjectivityCheckResult(..) )
 import FamInst     ( makeInjectivityErrors )
@@ -853,13 +855,15 @@ check_class_pred env dflags ctxt pred cls tys
 
   | otherwise
   = do { check_arity
-       ; checkTcM arg_tys_ok (env, predTyVarErr (tidyType env pred)) }
+       ; check_simplifiable_class_constraint
+       ; checkTcM arg_tys_ok (predTyVarErr env pred) }
   where
     check_arity = checkTc (classArity cls == length tys)
                           (tyConArityErr (classTyCon cls) tys)
+
+    -- Check the arguments of a class constraint
     flexible_contexts = xopt LangExt.FlexibleContexts     dflags
     undecidable_ok    = xopt LangExt.UndecidableInstances dflags
-
     arg_tys_ok = case ctxt of
         SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
         InstDeclCtxt -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
@@ -867,6 +871,40 @@ check_class_pred env dflags ctxt pred cls tys
                                 -- in checkInstTermination
         _            -> checkValidClsArgs flexible_contexts cls tys
 
+    -- See Note [Simplifiable given constraints]
+    check_simplifiable_class_constraint
+       | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"
+       = return ()               -- of a data type declaration
+       | otherwise
+       = do { instEnvs <- tcGetInstEnvs
+            ; let (matches, _, _) = lookupInstEnv False instEnvs cls tys
+                  bad_matches = [ inst | (inst,_) <- matches
+                                       , not (isOverlappable inst) ]
+            ; warnIf (Reason Opt_WarnSimplifiableClassConstraints)
+                     (not (null bad_matches))
+                     (simplifiable_constraint_warn bad_matches) }
+
+    simplifiable_constraint_warn :: [ClsInst] -> SDoc
+    simplifiable_constraint_warn (match : _)
+     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred)))
+                 2 (text "matches an instance declaration")
+            , ppr match
+            , hang (text "This makes type inference very fragile;")
+                 2 (text "try simplifying it using the instance") ]
+    simplifiable_constraint_warn [] = pprPanic "check_class_pred" (ppr pred)
+
+{- Note [Simplifiable given constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A type signature like
+   f :: Eq [(a,b)] => a -> b
+is very fragile, for reasons described at length in TcInteract
+
+Note [Instance and Given overlap].  So this warning discourages uses
+from writing simplifiable class constraints, at least unless the
+top-level instance is explicitly declared as OVERLAPPABLE.
+Trac #11948 provoked me to do this.
+-}
+
 -------------------------
 okIPCtxt :: UserTypeCtxt -> Bool
   -- See Note [Implicit parameters in instance decls]
@@ -893,11 +931,6 @@ okIPCtxt (SpecInstCtxt {}) = False
 okIPCtxt (RuleSigCtxt {})  = False
 okIPCtxt DefaultDeclCtxt   = False
 
-badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
-badIPPred env pred
-  = ( env
-    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )
-
 {-
 Note [Kind polymorphic type classes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -944,11 +977,17 @@ predSuperClassErr env pred
             <+> text "in a superclass context")
          2 (parens undecidableMsg) )
 
-predTyVarErr :: PredType -> SDoc   -- type is already tidied!
-predTyVarErr pred
-  = vcat [ hang (text "Non type-variable argument")
-              2 (text "in the constraint:" <+> ppr pred)
-         , parens (text "Use FlexibleContexts to permit this") ]
+predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+predTyVarErr env pred
+  = (env
+    , vcat [ hang (text "Non type-variable argument")
+                2 (text "in the constraint:" <+> ppr_tidy env pred)
+           , parens (text "Use FlexibleContexts to permit this") ])
+
+badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+badIPPred env pred
+  = ( env
+    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )
 
 constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
 constraintSynErr env kind
index 226fefc..6b57f5c 100644 (file)
@@ -22,7 +22,8 @@ module InstEnv (
         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts,
         memberInstEnv, instIsVisible,
         classInstances, instanceBindFun,
-        instanceCantMatch, roughMatchTcs
+        instanceCantMatch, roughMatchTcs,
+        isOverlappable, isOverlapping, isIncoherent
     ) where
 
 #include "HsVersions.h"
@@ -89,6 +90,11 @@ fuzzyClsInstCmp x y =
     cmp (Just _, Nothing) = GT
     cmp (Just x, Just y) = stableNameCmp x y
 
+isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool
+isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))
+isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i))
+isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))
+
 {-
 Note [Template tyvars are fresh]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -703,7 +709,7 @@ lookupInstEnv' ie vis_mods cls tys
     --------------
     find ms us [] = (ms, us)
     find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs
-                              , is_tys = tpl_tys, is_flag = oflag }) : rest)
+                              , is_tys = tpl_tys }) : rest)
       | not (instIsVisible vis_mods item)
       = find ms us rest  -- See Note [Instance lookup and orphan instances]
 
@@ -716,7 +722,7 @@ lookupInstEnv' ie vis_mods cls tys
 
         -- Does not match, so next check whether the things unify
         -- See Note [Overlapping instances] and Note [Incoherent instances]
-      | Incoherent _ <- overlapMode oflag
+      | isIncoherent item
       = find ms us rest
 
       | otherwise
@@ -768,8 +774,8 @@ lookupInstEnv check_overlap_safe
 
     -- If the selected match is incoherent, discard all unifiers
     final_unifs = case final_matches of
-                    (m:_) | is_incoherent m -> []
-                    _ -> all_unifs
+                    (m:_) | isIncoherent (fst m) -> []
+                    _                            -> all_unifs
 
     -- NOTE [Safe Haskell isSafeOverlap]
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -801,8 +807,6 @@ lookupInstEnv check_overlap_safe
                     lb = isInternalName nb
                 in (la && lb) || (nameModule na == nameModule nb)
 
-            isOverlappable i = hasOverlappableFlag $ overlapMode $ is_flag i
-
     -- We consider the most specific instance unsafe when it both:
     --   (1) Comes from a module compiled as `Safe`
     --   (2) Is an orphan instance, OR, an instance for a MPTC
@@ -810,31 +814,25 @@ lookupInstEnv check_overlap_safe
         (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1)
 
 ---------------
-is_incoherent :: InstMatch -> Bool
-is_incoherent (inst, _) = case overlapMode (is_flag inst) of
-                            Incoherent _ -> True
-                            _            -> False
-
----------------
 insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
 -- ^ Add a new solution, knocking out strictly less specific ones
 -- See Note [Rules for instance lookup]
 insert_overlapping new_item [] = [new_item]
-insert_overlapping new_item (old_item : old_items)
+insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items)
   | new_beats_old        -- New strictly overrides old
   , not old_beats_new
-  , new_item `can_override` old_item
+  , new_inst `can_override` old_inst
   = insert_overlapping new_item old_items
 
   | old_beats_new        -- Old strictly overrides new
   , not new_beats_old
-  , old_item `can_override` new_item
+  , old_inst `can_override` new_inst
   = old_item : old_items
 
   -- Discard incoherent instances; see Note [Incoherent instances]
-  | is_incoherent old_item       -- Old is incoherent; discard it
+  | isIncoherent old_inst      -- Old is incoherent; discard it
   = insert_overlapping new_item old_items
-  | is_incoherent new_item       -- New is incoherent; discard it
+  | isIncoherent new_inst      -- New is incoherent; discard it
   = old_item : old_items
 
   -- Equal or incomparable, and neither is incoherent; keep both
@@ -842,17 +840,16 @@ insert_overlapping new_item (old_item : old_items)
   = old_item : insert_overlapping new_item old_items
   where
 
-    new_beats_old = new_item `more_specific_than` old_item
-    old_beats_new = old_item `more_specific_than` new_item
+    new_beats_old = new_inst `more_specific_than` old_inst
+    old_beats_new = old_inst `more_specific_than` new_inst
 
     -- `instB` can be instantiated to match `instA`
     -- or the two are equal
-    (instA,_) `more_specific_than` (instB,_)
+    instA `more_specific_than` instB
       = isJust (tcMatchTys (is_tys instB) (is_tys instA))
 
-    (instA, _) `can_override` (instB, _)
-       =  hasOverlappingFlag  (overlapMode (is_flag instA))
-       || hasOverlappableFlag (overlapMode (is_flag instB))
+    instA `can_override` instB
+       = isOverlapping instA || isOverlappable instB
        -- Overlap permitted if either the more specific instance
        -- is marked as overlapping, or the more general one is
        -- marked as overlappable.
index 16c6585..72e7748 100644 (file)
@@ -713,6 +713,28 @@ of ``-W(no-)*``.
     second pattern overlaps it. More often than not, redundant patterns
     is a programmer mistake/error, so this option is enabled by default.
 
+.. ghc-flag:: -Wsimplifiable-class-constraints
+
+    :since: 8.2
+
+    .. index::
+       single: simplifiable class constraints, warning
+
+    Warn about class constraints in a type signature that can be simplified
+    using a top-level instance declaration.  For example: ::
+
+       f :: Eq [a] => a -> a
+
+    Here the ``Eq [a]`` in the signature overlaps with the top-level
+    instance for ``Eq [a]``.  GHC goes to some efforts to use the former,
+    but if it should use the latter, it would then have an
+    insoluble ``Eq a`` constraint.  Best avoided by instead writing: ::
+
+       f :: Eq a => a -> a
+
+    This option is on by default. As usual you can suppress it on a
+    per-module basis with :ghc-flag:`-Wno-simplifiable-class-constraints`.
+
 .. ghc-flag:: -Wtabs
 
     .. index::
index c9b2925..b1e4bbd 100644 (file)
@@ -71,6 +71,7 @@ endif
 libraries/haskeline_dist-install_EXTRA_HC_OPTS += -Wno-deprecations
 libraries/haskeline_dist-install_EXTRA_HC_OPTS += -Wno-unused-imports
 libraries/haskeline_dist-install_EXTRA_HC_OPTS += -Wno-redundant-constraints
+libraries/haskeline_dist-install_EXTRA_HC_OPTS += -Wno-simplifiable-class-constraints
 
 
 # temporarily turn off unused-imports warnings for pretty
index fd63871..8381552 100644 (file)
@@ -8,7 +8,10 @@ Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -}
              ScopedTypeVariables, GADTs, FlexibleInstances,
              UndecidableInstances, RebindableSyntax,
              DataKinds, MagicHash, AutoDeriveTypeable, TypeInType  #-}
-{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-missing-methods -Wno-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
+  -- Because we define a local Typeable class and have
+  --   instance Data.Typeable.Typeable a => Typeable a
 
 module Dynamic where
 
index d1ceefd..b30245b 100644 (file)
@@ -1,5 +1,6 @@
 --Testing GADTs, type families as well as a ton of crazy type stuff
-:set -fno-warn-redundant-constraints
+:set -Wno-redundant-constraints
+:set -Wno-simplifiable-class-constraints
 :set -XGADTs
 :set -XTypeFamilies
 :set -XFunctionalDependencies
@@ -33,6 +34,7 @@ type instance Or HFalse HTrue  = HTrue
 type instance Or HFalse HFalse = HFalse
 
 let f :: (Or a c ~ HTrue, TypeEq t A a, TypeEq t C c) => ABorC t -> Int ;    f x = 1
+-- Weird test case: (TypeEq t C c) and (TypeEq t C c) are both simplifiable
 f $ Foo 1
 f $ Bar True
 f $ Baz 'a'
index badfc1e..8613080 100644 (file)
@@ -1,11 +1,11 @@
 
-<interactive>:38:1: error:
+<interactive>:40:1: error:
     • Couldn't match type ‘HFalse’ with ‘HTrue’
         arising from a use of ‘f’
     • In the expression: f $ Baz 'a'
       In an equation for ‘it’: it = f $ Baz 'a'
 
-<interactive>:39:1: error:
+<interactive>:41:1: error:
     • Couldn't match type ‘HFalse’ with ‘HTrue’
         arising from a use of ‘f’
     • In the expression: f $ Quz
index 5406493..f6038bf 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
              FlexibleInstances,
              UndecidableInstances #-}
@@ -17,6 +17,7 @@ instance (Show a, Wuggle b) => Concrete a b where
        bar = error "urk"
 
 wib :: Concrete a b => a -> String
+-- Weird test case: (Concrete a b) is simplifiable
 wib x = bar x
 
 -- Uncommenting this solves the problem:
index d500b32..59a7ace 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE TypeFamilies, EmptyDataDecls, FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
@@ -12,7 +12,7 @@ foo :: E [Int] (E Int Int) -> Int
 foo = sum . concat
 
 data family F a b
-data instance F a a = MkF [a] 
+data instance F a a = MkF [a]
 
 goo :: F Int Int -> F Bool Bool
 goo (MkF xs) = MkF $ map odd xs
@@ -33,7 +33,9 @@ instance (result ~ True) => Proxy True result
 instance (result ~ False) => Proxy notTrue result
 
 testTrue :: EqTyP Int Int r => r
+-- Weird test case: (EqTyP Int Int) is simplifiable
 testTrue = undefined
 
 testFalse :: EqTyP Int Bool r => r
-testFalse = undefined
\ No newline at end of file
+-- Weird test case: (EqTyP Int Bool) is simplifiable
+testFalse = undefined
index 0074fae..d3db19b 100644 (file)
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ConstraintKinds #-}
@@ -25,6 +26,8 @@ instance ForallF Monoid t => Monoid1 t
 
 class ForallF Monoid1 t => Monoid2 t
 instance ForallF Monoid1 t => Monoid2 t
+-- In both declarations (Forall Monoid1 t) expands to
+-- (Monoid1 (t (SkolemF Monoid1 t))), which is simplifiable
 
 -- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error
 class (f a ~ g a) => H f g a
@@ -33,3 +36,5 @@ instance (f a ~ g a) => H f g a
 -- This one gives a superclass cycle error.
 class Forall (H f g) => H1 f g
 instance Forall (H f g) => H1 f g
+-- In both declarations (Forall (H f g)) expands to
+-- H f g (Skolem (H f g)), which is simplifiable
index 390c6ae..f681fc6 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
 
 class A a
@@ -8,12 +8,15 @@ instance A a => B a where b = undefined
 newtype Y a = Y (a -> ())
 
 okIn701 :: B a => Y a
+-- Weird test case: (B a) is simplifiable
 okIn701 = wrap $ const () . b
 
 okIn702 :: B a => Y a
+-- Weird test case: (B a) is simplifiable
 okIn702 = wrap $ b
 
 okInBoth :: B a => Y a
+-- Weird test case: (B a) is simplifiable
 okInBoth = Y $ const () . b
 
 class Wrapper a where
@@ -24,6 +27,7 @@ instance Wrapper (Y a) where
   wrap = Y
 
 fromTicket3018 :: Eq [a] => a -> ()
+-- Weird test case: (Eq [a]) is simplifiable
 fromTicket3018 x = let {g :: Int -> Int; g = [x]==[x] `seq` id} in ()
 
 main = undefined
index b0957a0..5f761f7 100644 (file)
@@ -4,5 +4,9 @@ TYPE CONSTRUCTORS
 COERCION AXIOMS
 Dependent modules: []
 Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
-                     integer-gmp-1.0.0.0]
+                     integer-gmp-1.0.0.1]
 
+SomethingShowable.hs:5:1: warning: [-Wsimplifiable-class-constraints (in -Wdefault)]
+    The constraint ‘Show Bool’ matches an instance declaration
+    This makes type inference very fragile;
+      try simplifying it using the instance
index abdee4d..8c54166 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE DataKinds, FunctionalDependencies, FlexibleInstances,
               UndecidableInstances, PolyKinds, KindSignatures,
               ConstraintKinds, FlexibleContexts, GADTs #-}
@@ -10,8 +10,10 @@ instance a ~ b => Id a b
 
 class Test (x :: a) (y :: a)
 instance (Id x y, Id y z) => Test x z
+-- Weird test case: (Id x y) and (Id y z) are both simplifiable
 
 test :: Test True True => ()
+-- Weird test case: (Test True True) is simplifiable
 test = ()
 
 
index fe603dd..a8bb18f 100644 (file)
@@ -1,17 +1,18 @@
-{-# LANGUAGE RankNTypes, GADTs, FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# OPTIONS_GHC -O2 #-}
+{-# LANGUAGE RankNTypes, GADTs, FlexibleContexts #-}
 
--- This one make SpecConstr generate bogus code (hence -O2), 
+-- This one make SpecConstr generate bogus code (hence -O2),
 -- with a lint error, in GHC 6.4.1
 -- C.f. http://ghc.haskell.org/trac/ghc/ticket/737
 
 module ShouldCompile where
 
  data IHandler st where
-     IHandler :: forall st ev res. 
-                Serialize (TxContext ev) => String -> IO ev 
+     IHandler :: forall st ev res.
+                Serialize (TxContext ev) => String -> IO ev
                 -> (res -> IO ()) -> Ev st ev res -> IHandler st
+     -- Weird test case: (Serialize (TxContext ev)) is simplifiable
 
  data Ev st ev res  = Ev
  data TxContext evt = TxContext
index 9e529f1..40adf6a 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE RankNTypes, FlexibleContexts, ImplicitParams, TemplateHaskell #-}
 
 -- This test makes sure TH understands types where
@@ -12,6 +12,7 @@ module T3100 where
 import Language.Haskell.TH
 
 flop :: Ord Int => Int -> Int
+-- Weird test case: (Ord Int) is simplifiable and redundant
 flop x = x
 
 $(do { t <- reify 'flop; return [] })
index 68d0dd4..8ef6bb8 100644 (file)
@@ -1,21 +1,22 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}
 
-class C a where 
+class C a where
 
-class D a where 
- dop :: a -> a    
+class D a where
+ dop :: a -> a
 
-instance C a => D [a] where 
+instance C a => D [a] where
  dop = undefined
 
-class J a b | a -> b 
- where j :: a -> b -> () 
+class J a b | a -> b
+ where j :: a -> b -> ()
 
-instance J Bool Int where 
+instance J Bool Int where
  j = undefined
-   
+
 foo :: D [Int] => ()
+-- Weird test case: (D [Int]) is simplifiable
 foo = j True (head (dop [undefined]))
 
 main = return ()
index 7ec4e9e..b1e1809 100644 (file)
@@ -1,7 +1,7 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GADTs,
              ConstraintKinds, DataKinds, KindSignatures,
              FlexibleInstances #-}
-{-# OPTIONS -fno-warn-redundant-constraints #-}
 
 module T10195 where
 
@@ -16,6 +16,7 @@ class Bar m m'
 instance (BarFamily m m' ~ 'True) => Bar m m'
 
 magic :: (Bar m m') => c m zp -> Foo m zp (c m' zq)
+-- Wierd test case: (Bar m m') is simplifiable
 magic = undefined
 
 getDict :: a -> Dict (Num a)
@@ -25,6 +26,7 @@ fromScalar = undefined
 
 foo :: (Bar m m')
   => c m zp -> Foo m zp (c m' zq) -> Foo m zp (c m' zq)
+-- Wierd test case: (Bar m m') is simplifiable
 foo b (Foo sc) =
   let scinv = fromScalar sc
   in case getDict scinv of
index f2ac8d5..be1dc54 100644 (file)
@@ -1,5 +1,5 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
-{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses, 
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
+{-# LANGUAGE UndecidableInstances, MultiParamTypeClasses,
              FunctionalDependencies, FlexibleInstances #-}
 
 module T3108 where
@@ -29,6 +29,7 @@ class C1 x
 instance {-# OVERLAPPING #-} (C1 x, C1 y) => C1 (x,y)
 instance {-# OVERLAPPING #-} C1 Bool
 instance {-# OVERLAPPABLE #-} (C2 x y, C1 (y,Bool)) => C1 x
+-- Wierd test case: (C1 (y,Bool)) is simplifiable
 
 class C2 x y | x -> y
 instance C2 Int Int
index ee5a9cc..32c8cf7 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 -- This test comes from Sergei Mechveliani's DoCon system
@@ -24,7 +24,7 @@ moduloBasisx p = let x :: ()
 
   -- This is very delicate!  The contraint (LinSolvRing (Pol a))
   -- arises in the RHS of x, and we must be careful *not* to simplify
-  -- it with the instance declaration "XXXX", else we get the 
+  -- it with the instance declaration "XXXX", else we get the
   -- unsatisfiable constraint (EuclideanRing a). In effect, the
   -- given constraint in the type sig for moduleBasisx overlaps
   -- with the top level declaration.
index f5fc354..289c664 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -24,7 +24,7 @@ instance Succ y z => Add' D1 y z
 
 class (Add' x y z) => Add x y z | x y -> z
 instance (Add' D1 y z) => Add D1 y z
-
+-- Weird test case: (Add' D1 y z) is simplifiable
 
 class IsSized a s | a -> s where
 
index 6292858..6da3337 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE FlexibleContexts, Rank2Types #-}
 
 module Test where
@@ -6,4 +6,5 @@ module Test where
 type Constrained x y r = (Eq x, Eq y) => x -> y -> r
 
 f :: Constrained String String ()
+-- Weird test case: (Eq String, Eq String) is simplifiable
 f = undefined
index 471a2e2..fdfdc72 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 {-# LANGUAGE
      FlexibleContexts
    , FlexibleInstances
@@ -23,6 +23,7 @@ data K x a = K x
 instance Het (A a) (A [a]) where het = het1
 
 het1 :: (GHet (K a) (K b)) => m (f c) -> a -> m b
+-- Weird test case: (GHet (K a) (K b)) is simplifiable
 het1 = undefined
 
 
@@ -30,4 +31,4 @@ het1 = undefined
      (GHet (K (A a)) (K (A [a])))
 
 -- Fundeps give ([A a] ~ A [a])
--}
\ No newline at end of file
+-}
index 12b4a98..cf6c985 100644 (file)
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
 
 -- trac #1406: Constraint doesn't reduce in the presence of quantified
 --             type variables
@@ -13,6 +13,7 @@ data S a
 
 class HPrefix l
 instance (NSub (S Z) ndiff, HDrop ndiff l l) => HPrefix l
+-- Weird test case: (NSub (S Z) ndiff) is simplifiable
 
 class NSub n1 n3 | n1 -> n3
 instance NSub Z Z
@@ -22,6 +23,7 @@ class HDrop n l1 l2 | n l1 -> l2
 instance HDrop Z l l
 
 t_hPrefix :: HPrefix l => l -> ()
+-- Weird test case: (HPrefix l) is simplifiable
 t_hPrefix = undefined
 
 -- In ghc 6.6.1 this works...
diff --git a/testsuite/tests/typecheck/should_fail/T11948.hs b/testsuite/tests/typecheck/should_fail/T11948.hs
new file mode 100644 (file)
index 0000000..2b737be
--- /dev/null
@@ -0,0 +1,22 @@
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, NoMonoLocalBinds #-}
+-- The NoMonoLocalBinds is crucial to making inference fail
+-- See Trac #11948 comment:2
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+
+module T11948 where
+
+type family F b
+
+newtype Foo r = Foo r
+
+type instance F (Foo r) = Foo (F r)
+
+class Bar a b where
+  bar :: a -> b
+
+instance (Bar a b) => Bar (Foo a) (Foo b)
+
+bug :: forall zq. (Bar (Foo (F zq)) (Foo zq))
+               => Foo (F zq) -> Foo zq
+bug sk = let x = bar sk :: Foo zq
+         in x
diff --git a/testsuite/tests/typecheck/should_fail/T11948.stderr b/testsuite/tests/typecheck/should_fail/T11948.stderr
new file mode 100644 (file)
index 0000000..4e683f8
--- /dev/null
@@ -0,0 +1,10 @@
+
+T11948.hs:21:18: error:
+    • Could not deduce (Bar (F zq) zq) arising from a use of ‘bar’
+      from the context: Bar (Foo (F zq)) (Foo zq)
+        bound by the type signature for:
+                   bug :: Bar (Foo (F zq)) (Foo zq) => Foo (F zq) -> Foo zq
+        at T11948.hs:(19,1)-(20,38)
+    • In the expression: bar sk :: Foo zq
+      In an equation for ‘x’: x = bar sk :: Foo zq
+      In the expression: let x = bar sk :: Foo zq in x
index 3903f4b..3310ec9 100644 (file)
@@ -415,3 +415,4 @@ test('T11724', normal, compile_fail, [''])
 test('BadUnboxedTuple', normal, compile_fail, [''])
 test('T11698', normal, compile_fail, [''])
 test('T11947a', normal, compile_fail, [''])
+test('T11948', normal, compile_fail, [''])