diff options
Diffstat (limited to 'compiler/GHC/Tc')
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 74 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 108 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Match.hs | 22 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Pat.hs | 47 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Sig.hs | 37 |
5 files changed, 217 insertions, 71 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index b8ed303dd7..3dc1ea685b 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -895,6 +895,48 @@ instance Diagnostic TcRnMessage where ClassPE -> same_rec_group_msg TyConPE -> same_rec_group_msg same_rec_group_msg = text "it is defined and used in the same recursive group" + TcRnMatchesHaveDiffNumArgs argsContext match1 bad_matches + -> mkSimpleDecorated $ + (vcat [ pprArgsContext argsContext <+> + text "have different numbers of arguments" + , nest 2 (ppr (getLocA match1)) + , nest 2 (ppr (getLocA (NE.head bad_matches)))]) + where + pprArgsContext = \case + EquationArgs name -> (text "Equations for" <+>) . quotes $ ppr name + PatternArgs matchCtx -> pprMatchContextNouns matchCtx + TcRnCannotBindScopedTyVarInPatSig sig_tvs + -> mkSimpleDecorated $ + hang (text "You cannot bind scoped type variable" + <> plural (NE.toList sig_tvs) + <+> pprQuotedList (map fst $ NE.toList sig_tvs)) + 2 (text "in a pattern binding signature") + TcRnCannotBindTyVarsInPatBind _offenders + -> mkSimpleDecorated $ + text "Binding type variables is not allowed in pattern bindings" + TcRnTooManyTyArgsInConPattern con_like expected_number actual_number + -> mkSimpleDecorated $ + text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ + text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number + TcRnMultipleInlinePragmas poly_id fst_inl_prag inl_prags + -> mkSimpleDecorated $ + hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) + 2 (vcat (text "Ignoring all but the first" + : map pp_inl (fst_inl_prag : NE.toList inl_prags))) + where + pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) + TcRnUnexpectedPragmas poly_id bad_sigs + -> mkSimpleDecorated $ + hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) + 2 (vcat (map (ppr . getLoc) $ NE.toList bad_sigs)) + TcRnNonOverloadedSpecialisePragma fun_name + -> mkSimpleDecorated $ + text "SPECIALISE pragma for non-overloaded function" + <+> quotes (ppr fun_name) + TcRnSpecialiseNotVisible name + -> mkSimpleDecorated $ + text "You cannot SPECIALISE" <+> quotes (ppr name) + <+> text "because its definition is not visible in this module" diagnosticReason = \case TcRnUnknownMessage m @@ -1185,6 +1227,22 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnUnpromotableThing{} -> ErrorWithoutFlag + TcRnMatchesHaveDiffNumArgs{} + -> ErrorWithoutFlag + TcRnCannotBindScopedTyVarInPatSig{} + -> ErrorWithoutFlag + TcRnCannotBindTyVarsInPatBind{} + -> ErrorWithoutFlag + TcRnTooManyTyArgsInConPattern{} + -> ErrorWithoutFlag + TcRnMultipleInlinePragmas{} + -> WarningWithoutFlag + TcRnUnexpectedPragmas{} + -> WarningWithoutFlag + TcRnNonOverloadedSpecialisePragma{} + -> WarningWithoutFlag + TcRnSpecialiseNotVisible{} + -> WarningWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -1477,6 +1535,22 @@ instance Diagnostic TcRnMessage where -> noHints TcRnUnpromotableThing{} -> noHints + TcRnMatchesHaveDiffNumArgs{} + -> noHints + TcRnCannotBindScopedTyVarInPatSig{} + -> noHints + TcRnCannotBindTyVarsInPatBind{} + -> noHints + TcRnTooManyTyArgsInConPattern{} + -> noHints + TcRnMultipleInlinePragmas{} + -> noHints + TcRnUnexpectedPragmas{} + -> noHints + TcRnNonOverloadedSpecialisePragma{} + -> noHints + TcRnSpecialiseNotVisible name + -> [SuggestSpecialiseVisibilityHints name] -- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z", diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index e1679d82d0..ad5f3db81b 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -64,6 +64,7 @@ module GHC.Tc.Errors.Types ( , UnsupportedCallConvention(..) , ExpectedBackends , ArgOrResult(..) + , MatchArgsContext(..) ) where import GHC.Prelude @@ -2008,6 +2009,106 @@ data TcRnMessage where -} TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage + {- TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches + that have different numbers of arguments + + Example(s): + foo x = True + foo x y = False + + Test cases: rename/should_fail/rnfail045 + typecheck/should_fail/T20768_fail + -} + TcRnMatchesHaveDiffNumArgs + :: !MatchArgsContext + -> !(LocatedA (Match GhcRn body)) + -> !(NE.NonEmpty (LocatedA (Match GhcRn body))) -- ^ bad matches + -> TcRnMessage + + {- TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type + variables cannot be used in pattern bindings. + + Example(s): + let (x :: a) = 5 + + Test cases: typecheck/should_compile/tc141 + -} + TcRnCannotBindScopedTyVarInPatSig :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {- TcRnCannotBindTyVarsInPatBind is an error for when type + variables are introduced in a pattern binding + + Example(s): + Just @a x = Just True + + Test cases: typecheck/should_fail/TyAppPat_PatternBinding + typecheck/should_fail/TyAppPat_PatternBindingExistential + -} + TcRnCannotBindTyVarsInPatBind :: !(NE.NonEmpty (Name, TcTyVar)) -> TcRnMessage + + {- TcRnTooManyTyArgsInConPattern is an error occurring when a constructor pattern + has more than the expected number of type arguments + + Example(s): + f (Just @Int @Bool x) = x + + Test cases: typecheck/should_fail/TyAppPat_TooMany + typecheck/should_fail/T20443b + -} + TcRnTooManyTyArgsInConPattern + :: !ConLike + -> !Int -- ^ Expected number of args + -> !Int -- ^ Actual number of args + -> TcRnMessage + + {- TcRnMultipleInlinePragmas is a warning signifying that multiple inline pragmas + reference the same definition. + + Example(s): + {-# INLINE foo #-} + {-# INLINE foo #-} + foo :: Bool -> Bool + foo = id + + Test cases: none + -} + TcRnMultipleInlinePragmas + :: !Id -- ^ Target of the pragmas + -> !(LocatedA InlinePragma) -- ^ The first pragma + -> !(NE.NonEmpty (LocatedA InlinePragma)) -- ^ Other pragmas + -> TcRnMessage + + {- TcRnUnexpectedPragmas is a warning that occurrs when unexpected pragmas appear + in the source. + + Example(s): + + Test cases: none + -} + TcRnUnexpectedPragmas :: !Id -> !(NE.NonEmpty (LSig GhcRn)) -> TcRnMessage + + {- TcRnNonOverloadedSpecialisePragma is a warning for a specialise pragma being + placed on a definition that is not overloaded. + + Example(s): + {-# SPECIALISE foo :: Bool -> Bool #-} + foo :: Bool -> Bool + foo = id + + Test cases: simplCore/should_compile/T8537 + typecheck/should_compile/T10504 + -} + TcRnNonOverloadedSpecialisePragma :: !(LIdP GhcRn) -> TcRnMessage + + {- TcRnSpecialiseNotVisible is a warning that occurrs when the subject of a + SPECIALISE pragma has a definition that is not visible from the current module. + + Example(s): none + + Test cases: none + -} + TcRnSpecialiseNotVisible :: !Name -> TcRnMessage + -- | Specifies which back ends can handle a requested foreign import or export type ExpectedBackends = [Backend] @@ -3050,3 +3151,10 @@ data HsDocContext | SpliceTypeCtx (LHsType GhcPs) | ClassInstanceCtx | GenericCtx SDoc + +-- | Context for a mismatch in the number of arguments +data MatchArgsContext + = EquationArgs + !Name -- ^ Name of the function + | PatternArgs + !(HsMatchContext GhcTc) -- ^ Pattern match specifics diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 9646cfeace..e1a0c2401b 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -71,7 +71,6 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Driver.Session ( getDynFlags ) -import GHC.Types.Error import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name import GHC.Types.Id @@ -79,6 +78,7 @@ import GHC.Types.SrcLoc import Control.Monad import Control.Arrow ( second ) +import qualified Data.List.NonEmpty as NE {- ************************************************************************ @@ -1143,32 +1143,28 @@ number of args are used in each equation. checkArgCounts :: AnnoBody body => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () -checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr +checkArgCounts = check_match_pats . EquationArgs -- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same -- number of patterns are used in each alternative checkPatCounts :: AnnoBody body => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () -checkPatCounts = check_match_pats . pprMatchContextNouns +checkPatCounts = check_match_pats . PatternArgs check_match_pats :: AnnoBody body - => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn)) + => MatchArgsContext -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () check_match_pats _ (MG { mg_alts = L _ [] }) = return () -check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) }) - | null bad_matches - = return () +check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) }) + | Just bad_matches <- mb_bad_matches + = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext match1 bad_matches | otherwise - = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $ - (vcat [ err_msg <+> - text "have different numbers of arguments" - , nest 2 (ppr (getLocA match1)) - , nest 2 (ppr (getLocA (head bad_matches)))]) + = return () where n_args1 = args_in_match match1 - bad_matches = [m | m <- matches, args_in_match m /= n_args1] + mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1] args_in_match :: (LocatedA (Match GhcRn body1) -> Int) args_in_match (L _ (Match { m_pats = pats })) = length pats diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index cd429f0cc5..62deebfe78 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -71,6 +71,7 @@ import GHC.Utils.Panic.Plain import qualified GHC.LanguageExtensions as LangExt import Control.Arrow ( second ) import Control.Monad +import qualified Data.List.NonEmpty as NE import GHC.Data.List.SetOps ( getNth ) {- @@ -743,26 +744,29 @@ tcPatSig in_pat_bind sig res_ty -- and not already in scope. These are the ones -- that should be brought into scope - ; if null sig_tvs then do { + ; case NE.nonEmpty sig_tvs of + Nothing -> do { -- Just do the subsumption check and return wrap <- addErrCtxtM (mk_msg sig_ty) $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty ; return (sig_ty, [], sig_wcs, wrap) - } else do + } + Just sig_tvs_ne -> do -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables -- It is more convenient to make the test here -- than in the renamer - { when in_pat_bind (addErr (patBindSigErr sig_tvs)) + when in_pat_bind + (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) - -- Now do a subsumption check of the pattern signature against res_ty - ; wrap <- addErrCtxtM (mk_msg sig_ty) $ - tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty + -- Now do a subsumption check of the pattern signature against res_ty + wrap <- addErrCtxtM (mk_msg sig_ty) $ + tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty - -- Phew! - ; return (sig_ty, sig_tvs, sig_wcs, wrap) - } } + -- Phew! + return (sig_ty, sig_tvs, sig_wcs, wrap) + } where mk_msg sig_ty tidy_env = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty @@ -774,13 +778,6 @@ tcPatSig in_pat_bind sig res_ty 2 (ppr res_ty)) ] ; return (tidy_env, msg) } -patBindSigErr :: [(Name,TcTyVar)] -> TcRnMessage -patBindSigErr sig_tvs - = TcRnUnknownMessage $ mkPlainError noHints $ - hang (text "You cannot bind scoped type variable" <> plural sig_tvs - <+> pprQuotedList (map fst sig_tvs)) - 2 (text "in a pattern binding signature") - {- ********************************************************************* * * @@ -1253,7 +1250,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of ; let con_spec_binders = filter ((== SpecifiedSpec) . binderArgFlag) $ conLikeUserTyVarBinders con_like ; checkTc (type_args `leLength` con_spec_binders) - (conTyArgArityErr con_like (length con_spec_binders) (length type_args)) + (TcRnTooManyTyArgsInConPattern con_like (length con_spec_binders) (length type_args)) ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys ; (type_args', (arg_pats', res)) @@ -1332,9 +1329,10 @@ tcConTyArg penv rn_ty thing_inside -- the kinds of later patterns. In any case, it all gets checked -- by the calls to unifyType in tcConArgs, which will also unify -- kinds. - ; when (not (null sig_ibs) && inPatBind penv) $ - addErr (TcRnUnknownMessage $ mkPlainError noHints $ - text "Binding type variables is not allowed in pattern bindings") + ; case NE.nonEmpty sig_ibs of + Just sig_ibs_ne | inPatBind penv -> + addErr (TcRnCannotBindTyVarsInPatBind sig_ibs_ne) + _ -> pure () ; result <- tcExtendNameTyVarEnv sig_wcs $ tcExtendNameTyVarEnv sig_ibs $ thing_inside @@ -1362,15 +1360,6 @@ addDataConStupidTheta data_con inst_tys -- because the constructor might have existentials inst_theta = substTheta tenv stupid_theta -conTyArgArityErr :: ConLike - -> Int -- expected # of arguments - -> Int -- actual # of arguments - -> TcRnMessage -conTyArgArityErr con_like expected_number actual_number - = TcRnUnknownMessage $ mkPlainError noHints $ - text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$ - text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number - {- Note [Arrows and patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 16a46f4454..66c7c80ced 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -68,9 +68,10 @@ import GHC.Utils.Misc as Utils ( singleton ) import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Data.Maybe( orElse ) +import GHC.Data.Maybe( orElse, whenIsJust ) import Data.Maybe( mapMaybe ) +import qualified Data.List.NonEmpty as NE import Control.Monad( unless ) @@ -631,15 +632,9 @@ addInlinePrags poly_id prags_for_me warn_multiple_inlines inl2 inls | otherwise = setSrcSpanA loc $ - let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints $ - (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id) - 2 (vcat (text "Ignoring all but the first" - : map pp_inl (inl1:inl2:inls)))) + let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls) in addDiagnosticTc dia - pp_inl (L loc prag) = ppr prag <+> parens (ppr loc) - {- Note [Pattern synonym inline arity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -776,7 +771,7 @@ tcSpecPrags :: Id -> [LSig GhcRn] -- Reason: required by tcSubExp tcSpecPrags poly_id prag_sigs = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs) - ; unless (null bad_sigs) warn_discarded_sigs + ; whenIsJust (NE.nonEmpty bad_sigs) warn_discarded_sigs ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } where @@ -784,11 +779,8 @@ tcSpecPrags poly_id prag_sigs bad_sigs = filter is_bad_sig prag_sigs is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s) - warn_discarded_sigs - = let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints $ - (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id) - 2 (vcat (map (ppr . getLoc) bad_sigs))) + warn_discarded_sigs bad_sigs_ne + = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne in addDiagnosticTc dia -------------- @@ -803,9 +795,7 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) -- what the user wrote (#8537) = addErrCtxt (spec_ctxt prag) $ do { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $ - TcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints - (text "SPECIALISE pragma for non-overloaded function" - <+> quotes (ppr fun_name)) + TcRnNonOverloadedSpecialisePragma fun_name -- Note [SPECIALISE pragmas] ; spec_prags <- mapM tc_one hs_tys ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags))) @@ -867,21 +857,10 @@ tcImpSpec (name, prag) ; if hasSomeUnfolding (realIdUnfolding id) -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag - else do { let dia = TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag noHints (impSpecErr name) + else do { let dia = TcRnSpecialiseNotVisible name ; addDiagnosticTc dia ; return [] } } -impSpecErr :: Name -> SDoc -impSpecErr name - = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition is not visible in this module" - , text "Hint: make sure" <+> ppr mod <+> text "is compiled with -O" - , text " and that" <+> quotes (ppr name) - <+> text "has an INLINABLE pragma" ]) - where - mod = nameModule name - {- Note [SPECIALISE pragmas for imported Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ An imported Id may or may not have an unfolding. If not, we obviously |