diff options
| -rw-r--r-- | compiler/GHC/Rename/Bind.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Env.hs | 17 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Types/Error.hs | 20 | ||||
| -rw-r--r-- | compiler/GHC/Types/Error/Codes.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Types/Hint.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Types/Hint/Ppr.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/AssocTyDef01.stderr | 10 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/AssocTyDef07.stderr | 10 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/AssocTyDef08.stderr | 10 | ||||
| -rw-r--r-- | testsuite/tests/typecheck/should_fail/AssocTyDef09.stderr | 10 |
12 files changed, 102 insertions, 18 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 7f3edf841c..8f650fccfd 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -936,7 +936,7 @@ rnMethodBindLHS :: Bool -> Name -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest = setSrcSpanA loc $ do - do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name + do { sel_name <- wrapLocMA (lookupInstDeclBndr cls "method") name -- We use the selector name as the binder ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } ; return (L loc bind' `consBag` rest ) } diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 3d3ded48f0..c79dfb38c1 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -350,7 +350,7 @@ lookupExactOcc_either name } ----------------------------------------------- -lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name +lookupInstDeclBndr :: Name -> String -> RdrName -> RnM Name -- This is called on the method name on the left-hand side of an -- instance declaration binding. eg. instance Functor T where -- fmap = ... @@ -378,11 +378,20 @@ lookupInstDeclBndr cls what rdr -- when it's used cls doc rdr ; case mb_name of - Left err -> do { addErr (mkTcRnNotInScope rdr err) + Left err -> + -- If `what` is an associated type, we ignore the `err` value and create + -- our own error specifically dealing with associated types + case what of + "associated type" -> do { srcSpan <- getSrcSpanM + ; code <- liftIO $ getSrcCodeString srcSpan + ; addErr (mkTcRnNotInScope rdr (UnknownAssociatedType cls rdr code)) + ; return (mkUnboundNameRdr rdr) } + + _ -> do { addErr (mkTcRnNotInScope rdr err) ; return (mkUnboundNameRdr rdr) } Right nm -> return nm } where - doc = what <+> text "of class" <+> quotes (ppr cls) + doc = text what <+> text "of class" <+> quotes (ppr cls) ----------------------------------------------- lookupFamInstName :: Maybe Name -> LocatedN RdrName @@ -390,7 +399,7 @@ lookupFamInstName :: Maybe Name -> LocatedN RdrName -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnMethodBind - = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr + = wrapLocMA (lookupInstDeclBndr cls "associated type") tc_rdr lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRnConstr tc_rdr diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 8dae970dee..4ace7d3398 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -3074,7 +3074,20 @@ pprScopeError rdr_name scope_err = hang (text "No top-level binding for") 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") UnknownSubordinate doc -> - quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc + quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc + UnknownAssociatedType _ _ code -> + case code of + Just c -> + text "The line:" + $+$ nest 2 (pprCode $ text c) + $+$ text "defines a default equation for type" <+> sname + <+> text "but" <+> sname <+> text "itself has not been declared." + Nothing -> + text "A default equation for" <+> sname <+> text "was found, but" <+> sname + <+> text "has not been declared." + where + sname = quotes (ppr rdr_name) + where what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) @@ -3087,6 +3100,9 @@ scopeErrorHints scope_err = MissingBinding _ hints -> hints NoTopLevelBinding -> noHints UnknownSubordinate {} -> noHints + UnknownAssociatedType name rdr code -> + [SuggestDeclareAssociatedType name rdr decl] + where decl = head . split '=' <$> code {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 854ebd3bf6..0ce9831dfb 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -3248,6 +3248,13 @@ data NotInScopeError -- or, a class doesn't have an associated type with this name, -- or, a record doesn't have a record field with this name. | UnknownSubordinate SDoc + + -- | A class doesn't have an associated type with this name. + | UnknownAssociatedType + { typeclassName :: Name -- ^ The name of the typeclass with the missing type decl + , associatedTypeName :: RdrName -- ^ The name of the undeclared associated type + , srcCode :: Maybe String -- ^ The source code that caused the error. Derived from SrcSpan + } deriving Generic -- | Create a @"not in scope"@ error message for the given 'RdrName'. diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 3c8ff8b4bb..d2deb57d63 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -56,6 +56,7 @@ module GHC.Types.Error , pprMessageBag , mkLocMessage , mkLocMessageWarningGroups + , getSrcCodeString , getCaretDiagnostic -- * Queries , isIntrinsicErrorMessage @@ -526,10 +527,14 @@ getMessageClassColour (MCDiagnostic SevWarning _reason _code) = Col.sWarning getMessageClassColour MCFatal = Col.sFatal getMessageClassColour _ = const mempty -getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic msg_class (RealSrcSpan span _) = - caretDiagnostic <$> getSrcLine (srcSpanFile span) row +-- | Get the snippet of code referenced by `SrcSpan` +-- +-- We need this so that we can include the source code within our error message. +-- E.g: https://gitlab.haskell.org/ghc/ghc/-/issues/21100 +getSrcCodeString :: SrcSpan -> IO (Maybe String) +getSrcCodeString (UnhelpfulSpan _) = pure Nothing +getSrcCodeString (RealSrcSpan span _) = + getSrcLine (srcSpanFile span) row where getSrcLine fn i = getLine i (unpackFS fn) @@ -549,11 +554,18 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = _ -> Nothing _ -> pure Nothing + row = srcSpanStartLine span + -- allow user to visibly see that their code is incorrectly encoded -- (StringBuffer.nextChar uses \0 to represent undecodable characters) fix '\0' = '\xfffd' fix c = c +getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc +getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty +getCaretDiagnostic msg_class srcSpan@(RealSrcSpan span _) = + caretDiagnostic <$> getSrcCodeString srcSpan + where row = srcSpanStartLine span rowStr = show row multiline = row /= srcSpanEndLine span diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 00346aa722..b039193224 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -502,6 +502,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "MissingBinding" = 44432 GhcDiagnosticCode "NoTopLevelBinding" = 10173 GhcDiagnosticCode "UnknownSubordinate" = 54721 + GhcDiagnosticCode "UnknownAssociatedType" = 87875 -- Diagnostic codes for deriving GhcDiagnosticCode "DerivErrNotWellKinded" = 62016 diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index 31f8d4422b..8ae2733baa 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -417,6 +417,13 @@ data GhcHint Test cases: none -} | SuggestSpecialiseVisibilityHints Name + {-| Suggest to declare the associated type + -} + | SuggestDeclareAssociatedType + { typeclassName :: Name -- ^ The name of the typeclass with the missing type decl + , associatedTypeName :: RdrName -- ^ The name of the undeclared associated type + , typeDecl :: Maybe String -- ^ The code suggestion of how to declare the associated type + } -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index 53890e8daf..25b6476aab 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -206,6 +206,14 @@ instance Outputable GhcHint where <+> quotes (ppr name) <+> text "has an INLINABLE pragma" where mod = nameModule name + SuggestDeclareAssociatedType name rdrName (Just decl) + -> text "Declare" <+> quotes (ppr rdrName) <+> text "by adding:" + $+$ nest 2 (pprCode $ text decl) + $+$ text "to the class" <+> quotes (ppr name) + SuggestDeclareAssociatedType name rdrName Nothing + -> text "Declare the associated type" <+> quotes (ppr rdrName) + <+> text "for class" <+> quotes (ppr name) + <+> text "in addition to the default equation" perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef01.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef01.stderr index 546803fcde..0aa62b1e37 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef01.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef01.stderr @@ -1,3 +1,9 @@ -AssocTyDef01.hs:9:10: error: [GHC-54721] - ‘OtherType’ is not a (visible) associated type of class ‘Cls’ +AssocTyDef01.hs:9:10: [GHC-87875] + The line: + type OtherType a = Int + defines a default equation for type ‘OtherType’ but ‘OtherType’ itself has not been declared. + Suggested fix: + Declare ‘OtherType’ by adding: + type OtherType a + to the class ‘Cls’
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef07.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef07.stderr index 30595d68aa..3dba70418f 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef07.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef07.stderr @@ -1,3 +1,9 @@ -AssocTyDef07.hs:5:10: error: [GHC-54721] - ‘Typ’ is not a (visible) associated type of class ‘Cls’ +AssocTyDef07.hs:5:10: [GHC-87875] + The line: + type Typ a = Int + defines a default equation for type ‘Typ’ but ‘Typ’ itself has not been declared. + Suggested fix: + Declare ‘Typ’ by adding: + type Typ a + to the class ‘Cls’
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef08.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef08.stderr index 1d2494243e..e51fae1abd 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef08.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef08.stderr @@ -1,3 +1,9 @@ -AssocTyDef08.hs:4:10: error: [GHC-54721] - ‘Typ’ is not a (visible) associated type of class ‘Cls’ +AssocTyDef08.hs:4:10: [GHC-87875] + The line: + type Typ a = Int + defines a default equation for type ‘Typ’ but ‘Typ’ itself has not been declared. + Suggested fix: + Declare ‘Typ’ by adding: + type Typ a + to the class ‘Cls’
\ No newline at end of file diff --git a/testsuite/tests/typecheck/should_fail/AssocTyDef09.stderr b/testsuite/tests/typecheck/should_fail/AssocTyDef09.stderr index 4bcf093a88..c8b84a6dbd 100644 --- a/testsuite/tests/typecheck/should_fail/AssocTyDef09.stderr +++ b/testsuite/tests/typecheck/should_fail/AssocTyDef09.stderr @@ -1,3 +1,9 @@ -AssocTyDef09.hs:8:10: error: [GHC-54721] - ‘OtherType’ is not a (visible) associated type of class ‘Cls’ +AssocTyDef09.hs:8:10: [GHC-87875] + The line: + type OtherType a = Int + defines a default equation for type ‘OtherType’ but ‘OtherType’ itself has not been declared. + Suggested fix: + Declare ‘OtherType’ by adding: + type OtherType a + to the class ‘Cls’
\ No newline at end of file |