diff options
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Instance.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T18036.hs | 13 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T18036a.hs | 15 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/T18036a.stderr | 6 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_compile/all.T | 2 |
5 files changed, 46 insertions, 3 deletions
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 83a449461b..0b9e313ce5 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1719,19 +1719,26 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind | Just hs_sig_ty <- hs_sig_fn sel_name -- There is a signature in the instance -- See Note [Instance method signatures] - = do { let ctxt = FunSigCtxt sel_name True - ; (sig_ty, hs_wrap) + = do { (sig_ty, hs_wrap) <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $ do { inst_sigs <- xoptM LangExt.InstanceSigs ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty) ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty ; let local_meth_ty = idType local_meth_id + ctxt = FunSigCtxt sel_name False + -- False <=> do not report redundant constraints when + -- checking instance-sig <= class-meth-sig + -- The instance-sig is the focus here; the class-meth-sig + -- is fixed (#18036) ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $ tcSubType_NC ctxt sig_ty local_meth_ty ; return (sig_ty, hs_wrap) } ; inner_meth_name <- newName (nameOccName sel_name) - ; let inner_meth_id = mkLocalId inner_meth_name sig_ty + ; let ctxt = FunSigCtxt sel_name True + -- True <=> check for redundant constraints in the + -- user-specified instance signature + inner_meth_id = mkLocalId inner_meth_name sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id , sig_ctxt = ctxt , sig_loc = getLoc (hsSigType hs_sig_ty) } diff --git a/testsuite/tests/typecheck/should_compile/T18036.hs b/testsuite/tests/typecheck/should_compile/T18036.hs new file mode 100644 index 0000000000..9acb9f481b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T18036.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -Wredundant-constraints #-} + +module T18036 where + +class Fold f where + fold :: Monoid m => f m -> m + +newtype Identity a = Identity a + +instance Fold Identity where + fold :: Identity a -> a + fold (Identity a) = a diff --git a/testsuite/tests/typecheck/should_compile/T18036a.hs b/testsuite/tests/typecheck/should_compile/T18036a.hs new file mode 100644 index 0000000000..e5c2596de2 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T18036a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -Wredundant-constraints #-} + +module T18036 where + +class Fold f where + fold :: Monoid m => f m -> m + +newtype Identity a = Identity a + +-- Here we /should/ warn about redundant constraints in the +-- instance signature, since we can remove them +instance Fold Identity where + fold :: Monoid a => Identity a -> a + fold (Identity a) = a diff --git a/testsuite/tests/typecheck/should_compile/T18036a.stderr b/testsuite/tests/typecheck/should_compile/T18036a.stderr new file mode 100644 index 0000000000..b379bd95a5 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T18036a.stderr @@ -0,0 +1,6 @@ + +T18036a.hs:14:13: warning: [-Wredundant-constraints] + • Redundant constraint: Monoid a + • In the type signature for: + fold :: forall a. Monoid a => Identity a -> a + In the instance declaration for ‘Fold Identity’ diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 04a45f6008..a7825b9f54 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -703,3 +703,5 @@ test('T17024', normal, compile, ['']) test('T17021a', normal, compile, ['']) test('T18005', normal, compile, ['']) test('T18023', normal, compile, ['']) +test('T18036', normal, compile, ['']) +test('T18036a', normal, compile, ['']) |