diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 5519cc8bca4f44cfeef07f1fcc066c5ff621f119..0a64ffea6010aa10f4ca76253be6402580d06a44 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -14,6 +14,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, tcClassMinimalDef, HsSigFun, mkHsSigFun, tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr, + instDeclCtxt1, instDeclCtxt2, instDeclCtxt3, tcATDefault ) where @@ -461,9 +462,25 @@ warningMinimalDefIncomplete mindef , nest 2 (pprBooleanFormulaNice mindef) , text "but there is no default implementation." ] -tcATDefault :: Bool -- If a warning should be emitted when a default instance - -- definition is not provided by the user - -> SrcSpan +instDeclCtxt1 :: LHsSigType GhcRn -> SDoc +instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + +instDeclCtxt2 :: Type -> SDoc +instDeclCtxt2 dfun_ty + = instDeclCtxt3 cls tys + where + (_,_,cls,tys) = tcSplitDFunTy dfun_ty + +instDeclCtxt3 :: Class -> [Type] -> SDoc +instDeclCtxt3 cls cls_tys + = inst_decl_ctxt (ppr (mkClassPred cls cls_tys)) + +inst_decl_ctxt :: SDoc -> SDoc +inst_decl_ctxt doc = hang (text "In the instance declaration for") + 2 (quotes doc) + +tcATDefault :: SrcSpan -> TCvSubst -> NameSet -> ClassATItem @@ -471,7 +488,7 @@ tcATDefault :: Bool -- If a warning should be emitted when a default instance -- ^ Construct default instances for any associated types that -- aren't given a user definition -- Returns [] or singleton -tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) +tcATDefault loc inst_subst defined_ats (ATI fam_tc defs) -- User supplied instances ==> everything is OK | tyConName fam_tc `elemNameSet` defined_ats = return [] @@ -503,7 +520,7 @@ tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs) -- No defaults ==> generate a warning | otherwise -- defs = Nothing - = do { when emit_warn $ warnMissingAT (tyConName fam_tc) + = do { warnMissingAT (tyConName fam_tc) ; return [] } where subst_tv subst tc_tv diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 056bc9bfaf8b70437e30e258c1dc98084a23fd37..c46225684d36dfbca7abfb06bc7bf7857da5d13b 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -21,7 +21,7 @@ import FamInst import TcDerivInfer import TcDerivUtils import TcValidity( allDistinctTyVars ) -import TcClassDcl( tcATDefault, tcMkDeclCtxt ) +import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt ) import TcEnv import TcGenDeriv -- Deriv stuff import InstEnv @@ -1600,8 +1600,9 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon , ds_mechanism = mechanism, ds_tys = tys , ds_cls = clas, ds_loc = loc }) = do (meth_binds, deriv_stuff, unusedNames) - <- genDerivStuff mechanism loc clas rep_tycon tys tvs - let mk_inst_info theta = do + <- set_span_and_ctxt $ + genDerivStuff mechanism loc clas rep_tycon tys tvs + let mk_inst_info theta = set_span_and_ctxt $ do inst_spec <- newDerivClsInst theta spec doDerivInstErrorChecks2 clas inst_spec mechanism traceTc "newder" (ppr inst_spec) @@ -1624,6 +1625,9 @@ genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon | otherwise = [] + set_span_and_ctxt :: TcM a -> TcM a + set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys) + doDerivInstErrorChecks1 :: Class -> [Type] -> TyCon -> [Type] -> TyCon -> DerivContext -> Bool -> DerivSpecMechanism -> TcM () @@ -1665,10 +1669,8 @@ doDerivInstErrorChecks2 clas clas_inst mechanism DerivSpecStock{} -> False _ -> True - gen_inst_err = hang (text ("Generic instances can only be derived in " - ++ "Safe Haskell using the stock strategy.") $+$ - text "In the following instance:") - 2 (pprInstanceHdr clas_inst) + gen_inst_err = text "Generic instances can only be derived in" + <+> text "Safe Haskell using the stock strategy." genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class -> TyCon -> [Type] -> [TyVar] @@ -1694,7 +1696,7 @@ genDerivStuff mechanism loc clas tycon inst_tys tyvars -- unless -XDeriveAnyClass is enabled. ASSERT2( isValid (canDeriveAnyClass dflags) , ppr "genDerivStuff: bad derived class" <+> ppr clas ) - mapM (tcATDefault False loc mini_subst emptyNameSet) + mapM (tcATDefault loc mini_subst emptyNameSet) (classATItems clas) return ( emptyBag -- No method bindings are needed... , listToBag (map DerivFamInst (concat tyfam_insts)) @@ -1755,8 +1757,8 @@ is used: In the latter case, we must take care to check if C has any associated type families with default instances, because -XDeriveAnyClass will never provide an implementation for them. We "fill in" the default instances using the -tcATDefault function from TcClsDcl (which is also used in TcInstDcls to handle -the empty instance declaration case). +tcATDefault function from TcClassDcl (which is also used in TcInstDcls to +handle the empty instance declaration case). Note [Deriving strategies] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 58d45061f7bfb746bf584b7ac01f154cbf48d53e..36a4b41983093b1434aa73ea852f58450764d9cc 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -488,7 +488,7 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) `unionNameSet` mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) - ; tyfam_insts1 <- mapM (tcATDefault True loc mini_subst defined_ats) + ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats) (classATItems clas) -- Finally, construct the Core representation of the instance. diff --git a/testsuite/tests/deriving/should_compile/T14094.hs b/testsuite/tests/deriving/should_compile/T14094.hs new file mode 100644 index 0000000000000000000000000000000000000000..29fa693e97b83e36197bc5fadc022a3f73ce3c3a --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T14094.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} +module Bug where + +class C a where + type T a + data D a + m :: a + +instance C Int +deriving instance C Bool diff --git a/testsuite/tests/deriving/should_compile/T14094.stderr b/testsuite/tests/deriving/should_compile/T14094.stderr new file mode 100644 index 0000000000000000000000000000000000000000..b323a775f5e455abce2d4a21439ba8ef0726a396 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T14094.stderr @@ -0,0 +1,26 @@ + +T14094.hs:12:1: warning: [-Wmissing-methods (in -Wdefault)] + • No explicit associated type or default declaration for ‘T’ + • In the instance declaration for ‘C Int’ + +T14094.hs:12:1: warning: [-Wmissing-methods (in -Wdefault)] + • No explicit associated type or default declaration for ‘D’ + • In the instance declaration for ‘C Int’ + +T14094.hs:12:10: warning: [-Wmissing-methods (in -Wdefault)] + • No explicit implementation for + ‘m’ + • In the instance declaration for ‘C Int’ + +T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] + • No explicit associated type or default declaration for ‘T’ + • In the instance declaration for ‘C Bool’ + +T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] + • No explicit associated type or default declaration for ‘D’ + • In the instance declaration for ‘C Bool’ + +T14094.hs:13:1: warning: [-Wmissing-methods (in -Wdefault)] + • No explicit implementation for + ‘m’ + • In the instance declaration for ‘C Bool’ diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 5b69565c523e92eee65fc0b88397bf6a2c4375bf..65c6d7284e6bebebcd94db914c8db2660649ab5f 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -95,3 +95,4 @@ test('T13813', normal, compile, ['']) test('T13919', normal, compile, ['']) test('T13998', normal, compile, ['']) test('T14045b', normal, compile, ['']) +test('T14094', normal, compile, ['']) diff --git a/testsuite/tests/deriving/should_fail/T10598_fail3.stderr b/testsuite/tests/deriving/should_fail/T10598_fail3.stderr index a987a4993d5d38901be3ece2bc282d1a5241f476..c3f4e123b7b65af90aa0c2ed331bb8b33c8069d4 100644 --- a/testsuite/tests/deriving/should_fail/T10598_fail3.stderr +++ b/testsuite/tests/deriving/should_fail/T10598_fail3.stderr @@ -1,5 +1,4 @@ -T10598_fail3.hs:1:1: error: - Generic instances can only be derived in Safe Haskell using the stock strategy. - In the following instance: - instance [safe] Generic T +T10598_fail3.hs:8:36: error: + • Generic instances can only be derived in Safe Haskell using the stock strategy. + • In the instance declaration for ‘Generic T’ diff --git a/testsuite/tests/deriving/should_fail/T8165_fail2.stderr b/testsuite/tests/deriving/should_fail/T8165_fail2.stderr index 4c925f52a3d291d2343da8241e703661c57029ee..5e19173a3319b36c562449259de9b72ce8cf6f87 100644 --- a/testsuite/tests/deriving/should_fail/T8165_fail2.stderr +++ b/testsuite/tests/deriving/should_fail/T8165_fail2.stderr @@ -1,5 +1,6 @@ T8165_fail2.hs:9:12: error: - The type family application ‘T Loop’ - is no smaller than the instance head - (Use UndecidableInstances to permit this) + • The type family application ‘T Loop’ + is no smaller than the instance head + (Use UndecidableInstances to permit this) + • In the instance declaration for ‘C Loop’