diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2022-01-17 10:45:35 +0100 |
|---|---|---|
| committer | sheaf <sam.derbyshire@gmail.com> | 2022-01-17 14:52:50 +0000 |
| commit | f161e890dfd41fd9735f4e259fffe2ce6d00ec1a (patch) | |
| tree | e6c54b25f3cbb87458dea92c04e23993997e3746 /compiler/GHC | |
| parent | a13aff98cfccddee285b6550dd08c6ec1a3c4e17 (diff) | |
| download | haskell-f161e890dfd41fd9735f4e259fffe2ce6d00ec1a.tar.gz | |
Use diagnostic infrastructure in GHC.Tc.Errors
Diffstat (limited to 'compiler/GHC')
29 files changed, 3074 insertions, 2040 deletions
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 138a24ccd5..fe9f74eb73 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -14,10 +14,11 @@ import GHC.Parser.Errors.Basic import GHC.Parser.Errors.Types import GHC.Parser.Types import GHC.Types.Basic +import GHC.Types.Hint import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc -import GHC.Types.Name.Reader (opIsAt, starInfo, rdrNameOcc, mkUnqual) +import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -272,10 +273,9 @@ instance Diagnostic PsMessage where (ppr v) PsErrTupleSectionInPat -> mkSimpleDecorated $ text "Tuple section in pattern context" - PsErrOpFewArgs (StarIsType star_is_type) op + PsErrOpFewArgs _ op -> mkSimpleDecorated $ text "Operator applied to too few arguments:" <+> ppr op - $$ starInfo star_is_type op PsErrVarForTyCon name -> mkSimpleDecorated $ text "Expecting a type constructor but found a variable," @@ -610,7 +610,7 @@ instance Diagnostic PsMessage where PsWarnHaddockInvalidPos -> noHints PsWarnHaddockIgnoreMulti -> noHints PsWarnStarBinder -> [SuggestQualifyStarOperator] - PsWarnStarIsType -> [SuggestUseTypeFromDataKind] + PsWarnStarIsType -> [SuggestUseTypeFromDataKind Nothing] PsWarnUnrecognisedPragma -> noHints PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName , suggestExtension LangExt.ImportQualifiedPost] @@ -668,7 +668,8 @@ instance Diagnostic PsMessage where PsErrUnsupportedBoxedSumPat{} -> noHints PsErrUnexpectedQualifiedConstructor{} -> noHints PsErrTupleSectionInPat{} -> noHints - PsErrOpFewArgs{} -> noHints + PsErrOpFewArgs star_is_type op + -> noStarIsTypeHints star_is_type op PsErrVarForTyCon{} -> noHints PsErrMalformedEntityString -> noHints PsErrDotsInRecordUpdate -> noHints diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index d39048c441..d50b21d7ad 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -12,6 +12,7 @@ import GHC.Hs import GHC.Parser.Types import GHC.Parser.Errors.Basic import GHC.Types.Error +import GHC.Types.Hint import GHC.Types.Name.Occurrence (OccName) import GHC.Types.Name.Reader import GHC.Unit.Module.Name @@ -452,8 +453,6 @@ data PsMessage | PsErrInvalidCApiImport -newtype StarIsType = StarIsType Bool - -- | Extra details about a parse error, which helps -- us in determining which should be the hints to -- suggest. diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index aab72310ac..83b55f5632 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -126,6 +126,7 @@ import GHC.Unit.Module (ModuleName) import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Fixity +import GHC.Types.Hint import GHC.Types.SourceText import GHC.Parser.Types import GHC.Parser.Lexer @@ -2788,8 +2789,9 @@ warnStarIsType span = addPsMessage span PsWarnStarIsType failOpFewArgs :: MonadP m => LocatedN RdrName -> m a failOpFewArgs (L loc op) = do { star_is_type <- getBit StarIsTypeBit + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ - (PsErrOpFewArgs (StarIsType star_is_type) op) } + (PsErrOpFewArgs is_star_type op) } ----------------------------------------------------------------------------- -- Misc utils diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index b666defcb3..a3c126222f 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -73,6 +73,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail +import GHC.Types.Hint import GHC.Types.Error import GHC.Unit.Module import GHC.Unit.Module.ModIface @@ -97,10 +98,9 @@ import GHC.Rename.Unbound import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either ( partitionEithers ) -import Data.List ( find, sortBy ) +import Data.List ( find ) import qualified Data.List.NonEmpty as NE import Control.Arrow ( first ) -import Data.Function import GHC.Types.FieldLabel import GHC.Data.Bag import GHC.Types.PkgQual @@ -300,7 +300,7 @@ lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything) -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either SDoc Name) +lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name) lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of @@ -341,28 +341,12 @@ lookupExactOcc_either name ; th_topnames <- readTcRef th_topnames_var ; if name `elemNameSet` th_topnames then return (Right name) - else return (Left (exactNameErr name)) + else return (Left (NoExactName name)) } } - gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] - } - -sameNameErr :: [GlobalRdrElt] -> SDoc -sameNameErr [] = panic "addSameNameErr: empty list" -sameNameErr gres@(_ : _) - = hang (text "Same exact name in multiple name-spaces:") - 2 (vcat (map pp_one sorted_names) $$ th_hint) - where - sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) - pp_one name - = hang (pprNameSpace (occNameSpace (getOccName name)) - <+> quotes (ppr name) <> comma) - 2 (text "declared at:" <+> ppr (nameSrcLoc name)) - - th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," - , text "perhaps via newName, in different name-spaces." - , text "If that's it, then -ddump-splices might be useful" ] + gres -> return (Left (SameName gres)) -- Ugh! See Note [Template Haskell ambiguity] + } ----------------------------------------------- lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name @@ -393,7 +377,7 @@ lookupInstDeclBndr cls what rdr -- when it's used cls doc rdr ; case mb_name of - Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> do { addErr (mkTcRnNotInScope rdr err) ; return (mkUnboundNameRdr rdr) } Right nm -> return nm } where @@ -441,7 +425,7 @@ lookupExactOrOrig rdr_name res k ; case men of FoundExactOrOrig n -> return (res n) ExactOrOrigError e -> - do { addErr (TcRnUnknownMessage $ mkPlainError noHints e) + do { addErr (mkTcRnNotInScope rdr_name e) ; return (res (mkUnboundNameRdr rdr_name)) } NotExactOrOrig -> k } @@ -457,9 +441,9 @@ lookupExactOrOrig_maybe rdr_name res k NotExactOrOrig -> k } data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError SDoc -- ^ The RdrName was an Exact - -- or Orig, but there was an - -- error looking up the Name + | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact + -- or Orig, but there was an + -- error looking up the Name | NotExactOrOrig -- ^ The RdrName is neither an Exact nor -- Orig @@ -848,7 +832,7 @@ lookupSubBndrOcc :: Bool -> Name -- Parent -> SDoc -> RdrName - -> RnM (Either SDoc Name) + -> RnM (Either NotInScopeError Name) -- Find all the things the rdr-name maps to -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do @@ -857,12 +841,12 @@ lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do -- This happens for built-in classes, see mod052 for example lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name case res of - NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) + NameNotFound -> return (Left (UnknownSubordinate doc)) FoundChild _p child -> return (Right (greNameMangledName child)) IncorrectParent {} -- See [Mismatched class methods and associated type families] -- in TcInstDecls. - -> return $ Left (unknownSubordinateErr doc rdr_name) + -> return $ Left (UnknownSubordinate doc) {- Note [Family instance binders] @@ -1087,17 +1071,14 @@ lookup_demoted rdr_name -- Maybe it's the name of a *data* constructor = do { data_kinds <- xoptM LangExt.DataKinds ; star_is_type <- xoptM LangExt.StarIsType - ; let star_info = starInfo star_is_type rdr_name + ; let is_star_type = if star_is_type then StarIsType else StarIsNotType + star_is_type_hints = noStarIsTypeHints is_star_type rdr_name ; if data_kinds then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr ; case mb_demoted_name of - Nothing -> unboundNameX looking_for rdr_name star_info + Nothing -> unboundNameX looking_for rdr_name star_is_type_hints Just demoted_name -> - do { let msg = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnUntickedPromotedConstructors) - noHints - (untickedPromConstrWarn demoted_name) - ; addDiagnostic msg + do { addDiagnostic $ TcRnUntickedPromotedConstructor demoted_name ; return demoted_name } } else do { -- We need to check if a data constructor of this name is -- in scope to give good error messages. However, we do @@ -1105,8 +1086,11 @@ lookup_demoted rdr_name -- constructor happens to be out of scope! See #13947. mb_demoted_name <- discardErrs $ lookupOccRn_maybe demoted_rdr - ; let suggestion | isJust mb_demoted_name = suggest_dk - | otherwise = star_info + ; let suggestion | isJust mb_demoted_name + , let additional = text "to refer to the data constructor of that name?" + = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds] + | otherwise + = star_is_type_hints ; unboundNameX looking_for rdr_name suggestion } } | otherwise @@ -1114,14 +1098,6 @@ lookup_demoted rdr_name where looking_for = LF WL_Constructor WL_Anywhere - suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" - untickedPromConstrWarn name = - text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot - $$ - hsep [ text "Use" - , quotes (char '\'' <> ppr name) - , text "instead of" - , quotes (ppr name) <> dot ] -- If the given RdrName can be promoted to the type level and its promoted variant is in scope, -- lookup_promoted returns the corresponding type-level Name. @@ -1822,7 +1798,7 @@ lookupSigCtxtOccRnN ctxt what = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> do { addErr (mkTcRnNotInScope rdr_name err) ; return (mkUnboundNameRdr rdr_name) } Right name -> return name } @@ -1835,13 +1811,13 @@ lookupSigCtxtOccRn ctxt what = wrapLocMA $ \ rdr_name -> do { mb_name <- lookupBindGroupOcc ctxt what rdr_name ; case mb_name of - Left err -> do { addErr (TcRnUnknownMessage $ mkPlainError noHints err) + Left err -> do { addErr (mkTcRnNotInScope rdr_name err) ; return (mkUnboundNameRdr rdr_name) } Right name -> return name } lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either SDoc Name) + -> RdrName -> RnM (Either NotInScopeError Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- @@ -1903,31 +1879,23 @@ lookupBindGroupOcc ctxt what rdr_name | otherwise -> bale_out_with local_msg Nothing -> bale_out_with candidates_msg } - bale_out_with msg - = return (Left (sep [ text "The" <+> what - <+> text "for" <+> quotes (ppr rdr_name) - , nest 2 $ text "lacks an accompanying binding"] - $$ nest 2 msg)) + bale_out_with hints = return (Left $ MissingBinding what hints) - local_msg = parens $ text "The" <+> what <+> text "must be given where" - <+> quotes (ppr rdr_name) <+> text "is declared" + local_msg = [SuggestMoveToDeclarationSite what rdr_name] -- Identify all similar names and produce a message listing them - candidates :: [Name] -> SDoc + candidates :: [Name] -> [GhcHint] candidates names_in_scope - = case similar_names of - [] -> Outputable.empty - [n] -> text "Perhaps you meant" <+> pp_item n - _ -> sep [ text "Perhaps you meant one of these:" - , nest 2 (pprWithCommas pp_item similar_names) ] + | (nm : nms) <- map SimilarName similar_names + = [SuggestSimilarNames rdr_name (nm NE.:| nms)] + | otherwise + = [] where similar_names = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) names_in_scope - pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) - --------------- lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] @@ -1939,7 +1907,7 @@ lookupLocalTcNames ctxt what rdr_name = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) ; let (errs, names) = partitionEithers mb_gres ; when (null names) $ - addErr (TcRnUnknownMessage $ mkPlainError noHints (head errs)) -- Bleat about one only + addErr (head errs) -- Bleat about one only ; return names } where lookup rdr = do { this_mod <- getModule @@ -1950,10 +1918,11 @@ lookupLocalTcNames ctxt what rdr_name guard_builtin_syntax this_mod rdr (Right name) | Just _ <- isBuiltInOcc_maybe (occName rdr) , this_mod /= nameModule name - = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr]) + = Left $ TcRnIllegalBuiltinSyntax what rdr | otherwise = Right (rdr, name) - guard_builtin_syntax _ _ (Left err) = Left err + guard_builtin_syntax _ _ (Left err) + = Left $ mkTcRnNotInScope rdr_name err dataTcOccs :: RdrName -> [RdrName] -- Return both the given name and the same name promoted to the TcClsName diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 6740e02430..145e6f08ec 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -51,12 +51,12 @@ import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext , mapFvRn, pprHsDocContext, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN - , checkShadowedRdrNames - , warnForallIdentifier ) + , checkShadowedRdrNames, warnForallIdentifier ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn , lookupTyFixityRn ) import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr ( pprScopeError ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names @@ -752,10 +752,11 @@ rnHsTyKi env (XHsType ty) check_in_scope :: RdrName -> RnM () check_in_scope rdr_name = do mb_name <- lookupLocalOccRn_maybe rdr_name + -- TODO: refactor this to avoid TcRnUnknownMessage when (isNothing mb_name) $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $ withHsDocContext (rtke_ctxt env) $ - notInScopeErr WL_LocalOnly rdr_name + pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name) rnHsTyKi env ty@(HsExplicitListTy _ ip tys) = do { data_kinds <- xoptM LangExt.DataKinds diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index d2f5463d58..5884747609 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -31,10 +31,9 @@ import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns - , warnForallIdentifier , newLocalBndrsRn , withHsDocContext, noNestedForallsContextsErr - , addNoNestedForallsContextsErr, checkInferredVars ) + , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types @@ -68,6 +67,7 @@ import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) import GHC.Types.Unique.Set import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt +import GHC.Tc.Errors.Ppr (pprScopeError) import Control.Monad import Control.Arrow ( first ) @@ -1353,9 +1353,12 @@ badRuleLhsErr name lhs bad_e $$ text "LHS must be of form (f e1 .. en) where f is not forall'd" where - err = case bad_e of - HsUnboundVar _ uv -> notInScopeErr WL_Global (mkRdrUnqual uv) - _ -> text "Illegal expression:" <+> ppr bad_e + err = + case bad_e of + HsUnboundVar _ uv -> + let rdr = mkRdrUnqual uv + in pprScopeError rdr $ notInScopeErr WL_Global (mkRdrUnqual uv) + _ -> text "Illegal expression:" <+> ppr bad_e {- ************************************************************** * * diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 79eeaa3477..2062b2e23a 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -53,10 +53,10 @@ import GHC.Tc.Utils.Zonk ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames - , warnUnusedMatches, warnForallIdentifier + , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames - , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit ) + , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier ) import GHC.Rename.HsType import GHC.Builtin.Names import GHC.Types.Avail ( greNameMangledName ) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 6139ee8a8e..5774698375 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + {- This module contains helper functions for reporting and creating @@ -18,7 +20,6 @@ module GHC.Rename.Unbound , unboundNameX , notInScopeErr , nameSpacesRelated - , exactNameErr ) where @@ -30,7 +31,6 @@ import GHC.Driver.Ppr import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique) -import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc import GHC.Data.Maybe @@ -38,7 +38,10 @@ import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt -import GHC.Types.Error +import GHC.Types.Hint + ( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames) + , LanguageExtensionHint (SuggestSingleExtension) + , ImportSuggestion(..), SimilarName(..), HowInScope(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name import GHC.Types.Name.Reader @@ -48,9 +51,12 @@ import GHC.Unit.Module import GHC.Unit.Module.Imported import GHC.Unit.Home.ModInfo +import GHC.Data.Bag +import GHC.Utils.Outputable (empty) + import Data.List (sortBy, partition, nub) +import Data.List.NonEmpty ( pattern (:|), NonEmpty ) import Data.Function ( on ) -import GHC.Data.Bag {- ************************************************************************ @@ -96,113 +102,89 @@ reportUnboundName :: RdrName -> RnM Name reportUnboundName = reportUnboundName' WL_Anything unboundName :: LookingFor -> RdrName -> RnM Name -unboundName lf rdr = unboundNameX lf rdr Outputable.empty +unboundName lf rdr = unboundNameX lf rdr [] -unboundNameX :: LookingFor -> RdrName -> SDoc -> RnM Name -unboundNameX looking_for rdr_name extra +unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name +unboundNameX looking_for rdr_name hints = do { dflags <- getDynFlags ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags - err = notInScopeErr (lf_where looking_for) rdr_name $$ extra + err = notInScopeErr (lf_where looking_for) rdr_name ; if not show_helpful_errors - then addErr (TcRnUnknownMessage $ mkPlainError noHints err) + then addErr $ TcRnNotInScope err rdr_name [] hints else do { local_env <- getLocalRdrEnv ; global_env <- getGlobalRdrEnv ; impInfo <- getImports ; currmod <- getModule ; hpt <- getHpt - ; let suggestions = unknownNameSuggestions_ looking_for - dflags hpt currmod global_env local_env impInfo - rdr_name - ; addErr (TcRnUnknownMessage $ mkPlainError noHints (err $$ suggestions)) } + ; let (imp_errs, suggs) = + unknownNameSuggestions_ looking_for + dflags hpt currmod global_env local_env impInfo + rdr_name + ; addErr $ + TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) } ; return (mkUnboundNameRdr rdr_name) } -notInScopeErr :: WhereLooking -> RdrName -> SDoc -notInScopeErr where_look rdr_name - | Just name <- isExact_maybe rdr_name = exactNameErr name - | WL_LocalTop <- where_look = hang (text "No top-level binding for") - 2 (what <+> quotes (ppr rdr_name) <+> text "in this module") - | otherwise = hang (text "Not in scope:") - 2 (what <+> quotes (ppr rdr_name)) - where - what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - -type HowInScope = Either SrcSpan ImpDeclSpec - -- Left loc => locally bound at loc - -- Right ispec => imported as specified by ispec +notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError +notInScopeErr where_look rdr_name + | Just name <- isExact_maybe rdr_name + = NoExactName name + | WL_LocalTop <- where_look + = NoTopLevelBinding + | otherwise + = NotInScope -- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable unknownNameSuggestions :: WhatLooking -> DynFlags -> HomePackageTable -> Module -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc + -> RdrName -> ([ImportError], [GhcHint]) unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere) unknownNameSuggestions_ :: LookingFor -> DynFlags -> HomePackageTable -> Module -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails - -> RdrName -> SDoc + -> RdrName -> ([ImportError], [GhcHint]) unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env - imports tried_rdr_name = - similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name $$ - importSuggestions looking_for global_env hpt - curr_mod imports tried_rdr_name $$ - extensionSuggestions tried_rdr_name $$ - fieldSelectorSuggestions global_env tried_rdr_name + imports tried_rdr_name = (imp_errs, suggs) + where + suggs = mconcat + [ if_ne (SuggestSimilarNames tried_rdr_name) $ + similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name + , map ImportSuggestion imp_suggs + , extensionSuggestions tried_rdr_name + , fieldSelectorSuggestions global_env tried_rdr_name ] + (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name + + if_ne :: (NonEmpty a -> b) -> [a] -> [b] + if_ne _ [] = [] + if_ne f (a : as) = [f (a :| as)] -- | When the name is in scope as field whose selector has been suppressed by -- NoFieldSelectors, display a helpful message explaining this. -fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc +fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint] fieldSelectorSuggestions global_env tried_rdr_name - | null gres = Outputable.empty - | otherwise = text "NB:" - <+> quotes (ppr tried_rdr_name) - <+> text "is a field selector" <+> whose - $$ text "that has been suppressed by NoFieldSelectors" + | null gres = [] + | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents] where gres = filter isNoFieldSelectorGRE $ lookupGRE_RdrName' tried_rdr_name global_env parents = [ parent | ParentIs parent <- map gre_par gres ] - -- parents may be empty if this is a pattern synonym field without a selector - whose | null parents = empty - | otherwise = text "belonging to the type" <> plural parents - <+> pprQuotedList parents - similarNameSuggestions :: LookingFor -> DynFlags -> GlobalRdrEnv -> LocalRdrEnv - -> RdrName -> SDoc + -> RdrName -> [SimilarName] similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env local_env tried_rdr_name - = case suggest of - [] -> Outputable.empty - [p] -> perhaps <+> pp_item p - ps -> sep [ perhaps <+> text "one of these:" - , nest 2 (pprWithCommas pp_item ps) ] + = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities where - all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities :: [(String, SimilarName)] all_possibilities = case what_look of WL_None -> [] - _ -> [ (showPpr dflags r, (r, Left loc)) + _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc)) | (r,loc) <- local_possibilities local_env ] ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] - suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities - perhaps = text "Perhaps you meant" - - pp_item :: (RdrName, HowInScope) -> SDoc - pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined - where loc' = case loc of - UnhelpfulSpan l -> parens (ppr l) - RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) - pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported - parens (text "imported from" <+> ppr (is_mod is)) - - pp_ns :: RdrName -> SDoc - pp_ns rdr | ns /= tried_ns = pprNameSpace ns - | otherwise = Outputable.empty - where ns = rdrNameSpace rdr - tried_occ = rdrNameOcc tried_rdr_name tried_is_sym = isSymOcc tried_occ tried_ns = occNameSpace tried_occ @@ -228,9 +210,9 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env , let occ = nameOccName name , correct_name_space occ] - global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)] global_possibilities global_env - | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how) | gre <- globalRdrEnvElts global_env , isGreOk looking_for gre , let occ = greOccName gre @@ -238,14 +220,14 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env , (mod, how) <- qualsInScope gre , let rdr_qual = mkRdrQual mod occ ] - | otherwise = [ (rdr_unqual, pair) + | otherwise = [ (rdr_unqual, sim) | gre <- globalRdrEnvElts global_env , isGreOk looking_for gre , let occ = greOccName gre rdr_unqual = mkRdrUnqual occ , correct_name_space occ - , pair <- case (unquals_in_scope gre, quals_only gre) of - (how:_, _) -> [ (rdr_unqual, how) ] + , sim <- case (unquals_in_scope gre, quals_only gre) of + (how:_, _) -> [ SimilarRdrName rdr_unqual how ] ([], pr:_) -> [ pr ] -- See Note [Only-quals] ([], []) -> [] ] @@ -262,98 +244,43 @@ similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env -------------------- unquals_in_scope :: GlobalRdrElt -> [HowInScope] unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is }) - | lcl = [ Left (greDefinitionSrcSpan gre) ] - | otherwise = [ Right ispec + | lcl = [ LocallyBoundAt (greDefinitionSrcSpan gre) ] + | otherwise = [ ImportedBy ispec | i <- bagToList is, let ispec = is_decl i , not (is_qual ispec) ] -------------------- - quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] + quals_only :: GlobalRdrElt -> [SimilarName] -- Ones for which *only* the qualified version is in scope quals_only (gre@GRE { gre_imp = is }) - = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec) + = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec)) | i <- bagToList is, let ispec = is_decl i, is_qual ispec ] --- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. + +-- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope. importSuggestions :: LookingFor -> GlobalRdrEnv -> HomePackageTable -> Module - -> ImportAvails -> RdrName -> SDoc + -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion]) importSuggestions looking_for global_env hpt currMod imports rdr_name - | WL_LocalOnly <- lf_where looking_for = Outputable.empty - | WL_LocalTop <- lf_where looking_for = Outputable.empty - | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty + | WL_LocalOnly <- lf_where looking_for = ([], []) + | WL_LocalTop <- lf_where looking_for = ([], []) + | not (isQual rdr_name || isUnqual rdr_name) = ([], []) | null interesting_imports , Just name <- mod_name , show_not_imported_line name - = hsep - [ text "No module named" - , quotes (ppr name) - , text "is imported." - ] + = ([MissingModule name], []) | is_qualified , null helpful_imports - , [(mod,_)] <- interesting_imports - = hsep - [ text "Module" - , quotes (ppr mod) - , text "does not export" - , quotes (ppr occ_name) <> dot - ] - | is_qualified - , null helpful_imports - , not (null interesting_imports) - , mods <- map fst interesting_imports - = hsep - [ text "Neither" - , quotedListWithNor (map ppr mods) - , text "exports" - , quotes (ppr occ_name) <> dot - ] - | [(mod,imv)] <- helpful_imports_non_hiding - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to the import list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_non_hiding) - = fsep - [ text "Perhaps you want to add" - , quotes (ppr occ_name) - , text "to one of these import lists:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_non_hiding - ]) - | [(mod,imv)] <- helpful_imports_hiding - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the explicit hiding list" - , text "in the import of" - , quotes (ppr mod) - , parens (ppr (imv_span imv)) <> dot - ] - | not (null helpful_imports_hiding) - = fsep - [ text "Perhaps you want to remove" - , quotes (ppr occ_name) - , text "from the hiding clauses" - , text "in one of these imports:" - ] - $$ - nest 2 (vcat - [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) - | (mod,imv) <- helpful_imports_hiding - ]) + , (mod : mods) <- map fst interesting_imports + = ([ModulesDoNotExport (mod :| mods) occ_name], []) + | mod : mods <- helpful_imports_non_hiding + = ([], [CouldImportFrom (mod :| mods) occ_name]) + | mod : mods <- helpful_imports_hiding + = ([], [CouldUnhideFrom (mod :| mods) occ_name]) | otherwise - = Outputable.empty + = ([], []) where is_qualified = isQual rdr_name (mod_name, occ_name) = case rdr_name of @@ -409,20 +336,21 @@ importSuggestions looking_for global_env hpt currMod imports rdr_name , (mod, _) <- qualsInScope gre ] -extensionSuggestions :: RdrName -> SDoc +extensionSuggestions :: RdrName -> [GhcHint] extensionSuggestions rdrName | rdrName == mkUnqual varName (fsLit "mdo") || rdrName == mkUnqual varName (fsLit "rec") - = text "Perhaps you meant to use RecursiveDo" - | otherwise = Outputable.empty + = [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo] + | otherwise + = [] qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is } | lcl = case greDefinitionModule gre of Nothing -> [] - Just m -> [(moduleName m, Left (greDefinitionSrcSpan gre))] - | otherwise = [ (is_as ispec, Right ispec) + Just m -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))] + | otherwise = [ (is_as ispec, ImportedBy ispec) | i <- bagToList is, let ispec = is_decl i ] isGreOk :: LookingFor -> GlobalRdrElt -> Bool @@ -510,10 +438,3 @@ there are 2 cases, where we hide the last "no module is imported" line: and we have to check the current module in the last added entry of the HomePackageTable. (See test T15611b) -} - -exactNameErr :: Name -> SDoc -exactNameErr name = - hang (text "The exact Name" <+> quotes (ppr name) <+> text "is not in scope") - 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " - , text "perhaps via newName, but did not bind it" - , text "If that's it, then -ddump-splices might be useful" ]) diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 4041b0b6c8..0c2d426450 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -18,7 +18,7 @@ module GHC.Rename.Utils ( warnForallIdentifier, checkUnusedRecordWildcard, mkFieldEnv, - unknownSubordinateErr, badQualBndrErr, typeAppErr, + badQualBndrErr, typeAppErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, genHsIntegralLit, genHsTyLit, HsDocContext(..), pprHsDocContext, @@ -595,12 +595,6 @@ addNameClashErrRn rdr_name gres num_non_flds = length non_flds -unknownSubordinateErr :: SDoc -> RdrName -> SDoc -unknownSubordinateErr doc op -- Doc is "method of class" or - -- "field of constructor" - = quotes (ppr op) <+> text "is not a (visible)" <+> doc - - dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () dupNamesErr get_loc names = addErrAt big_loc $ TcRnUnknownMessage $ mkPlainError noHints $ diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 0d84dddb1e..b08fd6b3a8 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -20,6 +21,8 @@ import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Driver.Config.Diagnostic +import GHC.Rename.Unbound + import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Errors.Types @@ -33,7 +36,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.EvTerm import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate -import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) +import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit ) import GHC.Types.Name import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual @@ -43,30 +46,22 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Env -import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Types.Basic import GHC.Types.Error -import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) -import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) +--import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module -import GHC.Hs.Binds ( PatSynBind(..) ) -import GHC.Builtin.Names ( typeableClassName, pretendNameIsInScope ) import qualified GHC.LanguageExtensions as LangExt import GHC.Core.Predicate import GHC.Core.Type import GHC.Core.Coercion -import GHC.Core.TyCo.Rep -import GHC.Core.TyCo.Ppr ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon - , pprWithTYPE ) -import GHC.Core.Unify ( tcMatchTys ) +import GHC.Core.TyCo.Ppr ( pprTyVars + ) import GHC.Core.InstEnv import GHC.Core.TyCon -import GHC.Core.Class import GHC.Core.DataCon -import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) import GHC.Utils.Misc @@ -76,8 +71,6 @@ import GHC.Utils.Panic.Plain import GHC.Utils.FV ( fvVarList, unionFV ) import GHC.Data.Bag -import GHC.Data.FastString -import GHC.Utils.Trace (pprTraceUserWarning) import GHC.Data.List.SetOps ( equivClasses, nubOrdBy ) import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict @@ -86,12 +79,9 @@ import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) import Data.Functor ( (<&>) ) import Data.Function ( on ) -import Data.List ( groupBy, partition, mapAccumL - , sortBy, tails, unfoldr ) -import Data.Ord ( comparing ) --- import Data.Semigroup ( Semigroup ) -import qualified Data.Semigroup as Semigroup - +import Data.List ( partition, mapAccumL ) +import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import qualified Data.List.NonEmpty as NE ( map, reverse ) {- ************************************************************************ @@ -265,102 +255,15 @@ report_unsolved type_errors expr_holes -- Internal functions -------------------------------------------- --- | An error Report collects messages categorised by their importance. --- See Note [Error report] for details. -data Report - = Report { report_important :: [SDoc] - , report_relevant_bindings :: [SDoc] - , report_valid_hole_fits :: [SDoc] - } - -instance Outputable Report where -- Debugging only - ppr (Report { report_important = imp - , report_relevant_bindings = rel - , report_valid_hole_fits = val }) - = vcat [ text "important:" <+> vcat imp - , text "relevant:" <+> vcat rel - , text "valid:" <+> vcat val ] - -{- Note [Error report] -~~~~~~~~~~~~~~~~~~~~~~ -The idea is that error msgs are divided into three parts: the main msg, the -context block ("In the second argument of ..."), and the relevant bindings -block, which are displayed in that order, with a mark to divide them. The -the main msg ('report_important') varies depending on the error -in question, but context and relevant bindings are always the same, which -should simplify visual parsing. - -The context is added when the Report is passed off to 'mkErrorReport'. -Unfortunately, unlike the context, the relevant bindings are added in -multiple places so they have to be in the Report. --} +-- | Make a report from a single 'TcReportMsg'. +important :: ReportErrCtxt -> TcReportMsg -> SolverReport +important ctxt doc = mempty { sr_important_msgs = [ReportWithCtxt ctxt doc] } + +mk_relevant_bindings :: RelevantBindings -> SolverReport +mk_relevant_bindings binds = mempty { sr_supplementary = [SupplementaryBindings binds] } -instance Semigroup Report where - Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2) - -instance Monoid Report where - mempty = Report [] [] [] - mappend = (Semigroup.<>) - --- | Put a doc into the important msgs block. -important :: SDoc -> Report -important doc = mempty { report_important = [doc] } - --- | Put a doc into the relevant bindings block. -mk_relevant_bindings :: SDoc -> Report -mk_relevant_bindings doc = mempty { report_relevant_bindings = [doc] } - --- | Put a doc into the valid hole fits block. -valid_hole_fits :: SDoc -> Report -valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] } - -data ReportErrCtxt - = CEC { cec_encl :: [Implication] -- Enclosing implications - -- (innermost first) - -- ic_skols and givens are tidied, rest are not - , cec_tidy :: TidyEnv - - , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) - -- into warnings, and emit evidence bindings - -- into 'cec_binds' for unsolved constraints - - , cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime - - -- cec_expr_holes is a union of: - -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' - -- cec_out_of_scope_holes - a set of variables which are - -- out of scope: 'x', 'y', 'bar' - , cec_expr_holes :: DiagnosticReason -- Holes in expressions. - , cec_type_holes :: DiagnosticReason -- Holes in types. - , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. - - , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints - , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms - - , cec_suppress :: Bool -- True <=> More important errors have occurred, - -- so create bindings if need be, but - -- don't issue any more errors/warnings - -- See Note [Suppressing error messages] - } - -instance Outputable ReportErrCtxt where - ppr (CEC { cec_binds = bvar - , cec_defer_type_errors = dte - , cec_expr_holes = eh - , cec_type_holes = th - , cec_out_of_scope_holes = osh - , cec_warn_redundant = wr - , cec_expand_syns = es - , cec_suppress = sup }) - = text "CEC" <+> braces (vcat - [ text "cec_binds" <+> equals <+> ppr bvar - , text "cec_defer_type_errors" <+> equals <+> ppr dte - , text "cec_expr_holes" <+> equals <+> ppr eh - , text "cec_type_holes" <+> equals <+> ppr th - , text "cec_out_of_scope_holes" <+> equals <+> ppr osh - , text "cec_warn_redundant" <+> equals <+> ppr wr - , text "cec_expand_syns" <+> equals <+> ppr es - , text "cec_suppress" <+> equals <+> ppr sup ]) +mk_report_hints :: [GhcHint] -> SolverReport +mk_report_hints hints = mempty { sr_hints = hints } -- | Returns True <=> the ReportErrCtxt indicates that something is deferred deferringAnyBindings :: ReportErrCtxt -> Bool @@ -479,23 +382,28 @@ warnRedundantConstraints ctxt env info ev_vars | null redundant_evs = return () - | SigSkol user_ctxt _ _ <- info + | SigSkol user_ctxt _ _ <- info = setLclEnv env $ -- We want to add "In the type signature for f" -- to the error context, which is a bit tiresome setSrcSpan (redundantConstraintsSpan user_ctxt) $ - addErrCtxt (text "In" <+> ppr info) $ - do { env <- getLclEnv - ; msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) - ; reportDiagnostic msg } + report_redundant_msg True | otherwise -- But for InstSkol there already *is* a surrounding -- "In the instance declaration for Eq [a]" context -- and we don't want to say it twice. Seems a bit ad-hoc - = do { msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc) - ; reportDiagnostic msg } + = report_redundant_msg False where - doc = text "Redundant constraint" <> plural redundant_evs <> colon - <+> pprEvVarTheta redundant_evs + report_redundant_msg :: Bool -- ^ whether to add "In ..." to the diagnostic + -> TcRn () + report_redundant_msg show_info + = do { lcl_env <- getLclEnv + ; msg <- + mkErrorReport + lcl_env + (TcRnRedundantConstraints redundant_evs (info, show_info)) + (Just ctxt) + [] + ; reportDiagnostic msg } redundant_evs = filterOut is_type_error $ @@ -511,14 +419,14 @@ warnRedundantConstraints ctxt env info ev_vars reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM () reportBadTelescope ctxt env (ForAllSkol telescope) skols - = do { msg <- mkErrorReport ErrorWithoutFlag ctxt env (important doc) + = do { msg <- mkErrorReport + env + (TcRnSolverReport [report] ErrorWithoutFlag noHints) + (Just ctxt) + [] ; reportDiagnostic msg } where - doc = hang (text "These kind and type variables:" <+> telescope $$ - text "are out of dependency order. Perhaps try this ordering:") - 2 (pprTyVars sorted_tvs) - - sorted_tvs = scopedSort skols + report = ReportWithCtxt ctxt $ BadTelescope telescope skols reportBadTelescope _ _ skol_info skols = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols) @@ -810,21 +718,20 @@ machinery, in cases where it is definitely going to be a no-op. mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { let err = mkUserTypeError ct + = mapM_ $ \ct -> do { let err = important ctxt $ mkUserTypeError ct ; maybeReportError ctxt ct err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: Ct -> Report -mkUserTypeError ct = important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) +mkUserTypeError :: Ct -> TcReportMsg +mkUserTypeError ct = + case getUserTypeErrorMsg ct of + Just msg -> UserTypeError msg + Nothing -> pprPanic "mkUserTypeError" (ppr ct) mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt cts - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + = do { (ctxt, relevant_binds, ct) <- relevantBindings True ctxt ct ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) @@ -832,17 +739,12 @@ mkGivenErrorReporter ctxt cts -- with one from the immediately-enclosing implication. -- See Note [Inaccessible code] - inaccessible_msg = hang (text "Inaccessible code in") - 2 (ppr (ic_info implic)) - report = important inaccessible_msg `mappend` - mk_relevant_bindings binds_msg - - ; report <- mkEqErr_help ctxt report ct' ty1 ty2 - ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt - (ctLocEnv (ctLoc ct')) report - - ; traceTc "mkGivenErrorReporter" (ppr ct) - ; reportDiagnostic err } + ; (eq_err_msgs, _hints) <- mkEqErr_help ctxt ct' ty1 ty2 + -- The hints wouldn't help in this situation, so we discard them. + ; let supplementary = [ SupplementaryBindings relevant_binds ] + msg = TcRnInaccessibleCode implic (NE.reverse . NE.map (ReportWithCtxt ctxt) $ eq_err_msgs) + ; msg <- mkErrorReport (ctLocEnv (ctLoc ct')) msg (Just ctxt) supplementary + ; reportDiagnostic msg } where (ct : _ ) = cts -- Never empty (ty1, ty2) = getEqPredTys (ctPred ct) @@ -889,7 +791,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -898,7 +800,7 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -917,7 +819,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter reportGroup mk_err ctxt cts | ct1 : _ <- cts = do { err <- mk_err ctxt cts @@ -937,7 +839,7 @@ reportGroup mk_err ctxt cts -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM SolverReport) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) @@ -950,16 +852,17 @@ nonDeferrableOrigin (UsageEnvironmentOf {}) = True nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True nonDeferrableOrigin _ = False -maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () -maybeReportError ctxt ct report +maybeReportError :: ReportErrCtxt -> Ct -> SolverReport -> TcM () +maybeReportError ctxt ct (SolverReport { sr_important_msgs = important, sr_supplementary = supp, sr_hints = hints }) = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic do let reason | nonDeferrableOrigin (ctOrigin ct) = ErrorWithoutFlag | otherwise = cec_defer_type_errors ctxt -- See Note [No deferring for multiplicity errors] - msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report + diag = TcRnSolverReport important reason hints + msg <- mkErrorReport (ctLocEnv (ctLoc ct)) diag (Just ctxt) supp reportDiagnostic msg -addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () +addDeferredBinding :: ReportErrCtxt -> SolverReport -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -981,9 +884,11 @@ addDeferredBinding ctxt err ct = return () mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term - -> Report -> TcM EvTerm -mkErrorTerm ctxt ct_loc ty report - = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report + -> SolverReport -> TcM EvTerm +mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msgs = important, sr_supplementary = supp }) + = do { msg <- mkErrorReport + (ctLocEnv ct_loc) + (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" ; dflags <- getDynFlags ; let err_msg = pprLocMsgEnvelope msg @@ -1029,75 +934,79 @@ tryReporter ctxt (str, keep_me, suppress_after, reporter) cts where (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts -pprArising :: CtOrigin -> SDoc --- Used for the main, top-level error message --- We've done special processing for TypeEq, KindEq, givens -pprArising (TypeEqOrigin {}) = empty -pprArising (KindEqOrigin {}) = empty -pprArising orig | isGivenOrigin orig = empty - | otherwise = pprCtOrigin orig - --- Add the "arising from..." part to a message about bunch of dicts -addArising :: CtOrigin -> SDoc -> SDoc -addArising orig msg = hang msg 2 (pprArising orig) - -pprWithArising :: [Ct] -> (CtLoc, SDoc) --- Print something like --- (Eq a) arising from a use of x at y --- (Show a) arising from a use of p at q --- Also return a location for the error message --- Works for Wanted/Derived only -pprWithArising [] - = panic "pprWithArising" -pprWithArising (ct:cts) - | null cts - = (loc, addArising (ctLocOrigin loc) - (pprTheta [ctPred ct])) - | otherwise - = (loc, vcat (map ppr_one (ct:cts))) - where - loc = ctLoc ct - ppr_one ct' = hang (parens (pprType (ctPred ct'))) - 2 (pprCtLoc (ctLoc ct')) - -mkErrorReport :: DiagnosticReason - -> ReportErrCtxt - -> TcLclEnv - -> Report +-- | Wrap an input 'TcRnMessage' with additional contextual information, +-- such as relevant bindings or valid hole fits. +mkErrorReport :: TcLclEnv + -> TcRnMessage + -- ^ The main payload of the message. + -> Maybe ReportErrCtxt + -- ^ The context to add, after the main diagnostic + -- but before the supplementary information. + -- Nothing <=> don't add any context. + -> [SolverReportSupplementary] + -- ^ Supplementary information, to be added at the end of the message. -> TcM (MsgEnvelope TcRnMessage) -mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) - = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; unit_state <- hsc_units <$> getTopEnv ; - ; let err_info = ErrInfo context (vcat $ relevant_bindings ++ valid_subs) - ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) +mkErrorReport tcl_env msg mb_ctxt supplementary + = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt + ; unit_state <- hsc_units <$> getTopEnv + ; hfdc <- getHoleFitDispConfig + ; let + err_info = + ErrInfo + (fromMaybe empty mb_context) + (vcat $ map (pprSolverReportSupplementary hfdc) supplementary) ; mkTcRnMessage (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) - } - --- This version does not include the context -mkErrorReportNC :: DiagnosticReason - -> TcLclEnv - -> Report - -> TcM (MsgEnvelope TcRnMessage) -mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) - = do { unit_state <- hsc_units <$> getTopEnv ; - ; let err_info = ErrInfo O.empty (vcat $ relevant_bindings ++ valid_subs) - ; let msg = TcRnUnknownMessage $ mkPlainDiagnostic rea noHints (vcat important) - ; mkTcRnMessage - (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing) - (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) - } - -type UserGiven = Implication + (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) } + +-- | Pretty-print supplementary information, to add to an error report. +pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprSolverReportSupplementary hfdc = \case + SupplementaryBindings binds -> pprRelevantBindings binds + SupplementaryHoleFits fits -> pprValidHoleFits hfdc fits + SupplementaryCts cts -> pprConstraintsInclude cts + +-- | Display a collection of valid hole fits. +pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs)) + = fits_msg $$ refs_msg -getUserGivens :: ReportErrCtxt -> [UserGiven] --- One item for each enclosing implication -getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics - -getUserGivensFromImplics :: [Implication] -> [UserGiven] -getUserGivensFromImplics implics - = reverse (filterOut (null . ic_given) implics) + where + fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc + fits_msg = ppUnless (null fits) $ + hang (text "Valid hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) fits) + $$ ppWhen discarded_fits fits_discard_msg + refs_msg = ppUnless (null refs) $ + hang (text "Valid refinement hole fits include") 2 $ + vcat (map (pprHoleFit hfdc) refs) + $$ ppWhen discarded_refs refs_discard_msg + fits_discard_msg = + text "(Some hole fits suppressed;" <+> + text "use -fmax-valid-hole-fits=N" <+> + text "or -fno-max-valid-hole-fits)" + refs_discard_msg = + text "(Some refinement hole fits suppressed;" <+> + text "use -fmax-refinement-hole-fits=N" <+> + text "or -fno-max-refinement-hole-fits)" + +-- | Add a "Constraints include..." message. +-- +-- See Note [Constraints include ...] +pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'. +pprConstraintsInclude cts + = ppUnless (null cts) $ + hang (text "Constraints include") + 2 (vcat $ map pprConstraint cts) + where + pprConstraint (constraint, loc) = + ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) {- Note [Always warn with -fdefer-type-errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1201,14 +1110,14 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) + ; let msg = important ctxt $ + CouldNotDeduce (getUserGivens ctxt) (ct1 :| others) Nothing ; return $ msg `mappend` mk_relevant_bindings binds_msg } where - (ct1:_) = cts + ct1:others = cts {- Note [Constructing Hole Errors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1247,122 +1156,63 @@ See also 'reportUnsolved'. ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors]. mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage) -mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ - , hole_ty = hole_ty - , hole_loc = ct_loc }) +mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc }) | isOutOfScopeHole hole = do { dflags <- getDynFlags ; rdr_env <- getGlobalRdrEnv ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt - ; let err = important out_of_scope_msg `mappend` - (mk_relevant_bindings $ - unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) - - ; maybeAddDeferredBindings ctxt hole err - ; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err - -- Use NC variant: the context is generally not helpful here + ; let (imp_errs, hints) + = unknownNameSuggestions WL_Anything + dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ) + errs = [ReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)] + report = SolverReport errs [] hints + + ; maybeAddDeferredBindings ctxt hole report + ; mkErrorReport lcl_env (TcRnSolverReport errs (cec_out_of_scope_holes ctxt) hints) Nothing [] + -- Pass the value 'Nothing' for the context, as it's generally not helpful + -- to include the context here. } where - herald | isDataOcc occ = text "Data constructor not in scope:" - | otherwise = text "Variable not in scope:" - - out_of_scope_msg -- Print v :: ty only if the type has structure - | boring_type = hang herald 2 (ppr occ) - | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) - - lcl_env = ctLocEnv ct_loc - boring_type = isTyVarTy hole_ty + lcl_env = ctLocEnv ct_loc -- general case: not an out-of-scope error -mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ - , hole_ty = hole_ty - , hole_sort = sort - , hole_loc = ct_loc }) - = do { binds_msg +mkHoleError lcl_name_cache tidy_simples ctxt + hole@(Hole { hole_ty = hole_ty + , hole_sort = sort + , hole_loc = ct_loc }) + = do { rel_binds <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) -- The 'False' means "don't filter the bindings"; see Trac #8191 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints - ; let constraints_msg + ; let relevant_cts | ExprHole _ <- sort, show_hole_constraints - = givenConstraintsMsg ctxt + = givenConstraints ctxt | otherwise - = empty + = [] ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits - ; (ctxt, sub_msg) <- if show_valid_hole_fits - then validHoleFits ctxt tidy_simples hole - else return (ctxt, empty) + ; (ctxt, hole_fits) <- if show_valid_hole_fits + then validHoleFits ctxt tidy_simples hole + else return (ctxt, noValidHoleFits) - ; let err = important hole_msg `mappend` - mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg + ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt + | otherwise = cec_type_holes ctxt + errs = [ReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort] + supp = [ SupplementaryBindings rel_binds + , SupplementaryCts relevant_cts + , SupplementaryHoleFits hole_fits ] - ; maybeAddDeferredBindings ctxt hole err + ; maybeAddDeferredBindings ctxt hole (SolverReport errs supp []) - ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt - | otherwise = cec_type_holes ctxt - ; mkErrorReport holes ctxt lcl_env err + ; mkErrorReport lcl_env (TcRnSolverReport errs reason noHints) (Just ctxt) supp } where - lcl_env = ctLocEnv ct_loc - hole_kind = tcTypeKind hole_ty - tyvars = tyCoVarsOfTypeList hole_ty - - hole_msg = case sort of - ExprHole _ -> vcat [ hang (text "Found hole:") - 2 (pp_occ_with_type occ hole_ty) - , tyvars_msg, expr_hole_hint ] - TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ)) - 2 (text "standing for" <+> quotes pp_hole_type_with_kind) - , tyvars_msg, type_hole_hint ] - ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for") - 2 (quotes $ pprType hole_ty) -- always kind constraint - , tyvars_msg, type_hole_hint ] - - pp_hole_type_with_kind - | isLiftedTypeKind hole_kind - || isCoVarType hole_ty -- Don't print the kind of unlifted - -- equalities (#15039) - = pprType hole_ty - | otherwise - = pprType hole_ty <+> dcolon <+> pprKind hole_kind - - tyvars_msg = ppUnless (null tyvars) $ - text "Where:" <+> (vcat (map loc_msg other_tvs) - $$ pprSkols ctxt skol_tvs) - where - (skol_tvs, other_tvs) = partition is_skol tyvars - is_skol tv = isTcTyVar tv && isSkolemTyVar tv - -- Coercion variables can be free in the - -- hole, via kind casts - - type_hole_hint - | ErrorWithoutFlag <- cec_type_holes ctxt - = text "To use the inferred type, enable PartialTypeSignatures" - | otherwise - = empty - - expr_hole_hint -- Give hint for, say, f x = _x - | lengthFS (occNameFS occ) > 1 -- Don't give this hint for plain "_" - = text "Or perhaps" <+> quotes (ppr occ) - <+> text "is mis-spelled, or not in scope" - | otherwise - = empty - - loc_msg tv - | isTyVar tv - = case tcTyVarDetails tv of - MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" - _ -> empty -- Skolems dealt with already - | otherwise -- A coercion variable can be free in the hole type - = ppWhenOption sdocPrintExplicitCoercions $ - quotes (ppr tv) <+> text "is a coercion variable" - + lcl_env = ctLocEnv ct_loc {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1379,7 +1229,7 @@ so that the correct 'Severity' can be computed out of that later on. -- See Note [Adding deferred bindings]. maybeAddDeferredBindings :: ReportErrCtxt -> Hole - -> Report + -> SolverReport -> TcM () maybeAddDeferredBindings ctxt hole report = do case hole_sort hole of @@ -1394,57 +1244,38 @@ maybeAddDeferredBindings ctxt hole report = do writeMutVar ref err_tm _ -> pure () -pp_occ_with_type :: OccName -> Type -> SDoc -pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) - -- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module -- imports -validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the - -- implications and the tidy environment - -> [Ct] -- Unsolved simple constraints - -> Hole -- The hole - -> TcM (ReportErrCtxt, SDoc) -- We return the new context - -- with a possibly updated - -- tidy environment, and - -- the message. +validHoleFits :: ReportErrCtxt -- ^ The context we're in, i.e. the + -- implications and the tidy environment + -> [Ct] -- ^ Unsolved simple constraints + -> Hole -- ^ The hole + -> TcM (ReportErrCtxt, ValidHoleFits) + -- ^ We return the new context + -- with a possibly updated + -- tidy environment, and + -- the valid hole fits. validHoleFits ctxt@(CEC {cec_encl = implics , cec_tidy = lcl_env}) simps hole - = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps hole - ; return (ctxt {cec_tidy = tidy_env}, msg) } + = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics simps hole + ; return (ctxt {cec_tidy = tidy_env}, fits) } -- See Note [Constraints include ...] -givenConstraintsMsg :: ReportErrCtxt -> SDoc -givenConstraintsMsg ctxt = - let constraints :: [(Type, RealSrcSpan)] - constraints = - do { implic@Implic{ ic_given = given } <- cec_encl ctxt - ; constraint <- given - ; return (varType constraint, tcl_loc (ic_env implic)) } - - pprConstraint (constraint, loc) = - ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc)) - - in ppUnless (null constraints) $ - hang (text "Constraints include") - 2 (vcat $ map pprConstraint constraints) +givenConstraints :: ReportErrCtxt -> [(Type, RealSrcSpan)] +givenConstraints ctxt + = do { implic@Implic{ ic_given = given } <- cec_encl ctxt + ; constraint <- given + ; return (varType constraint, tcl_loc (ic_env implic)) } ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report + +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 - ; let orig = ctOrigin ct1 - preds = map ctPred cts - givens = getUserGivens ctxt - msg | null givens - = important $ addArising orig $ - sep [ text "Unbound implicit parameter" <> plural cts - , nest 2 (pprParendTheta preds) ] - | otherwise - = couldNotDeduce givens (preds, orig) - + ; let msg = important ctxt $ UnboundImplicitParams (ct1 :| others) ; return $ msg `mappend` mk_relevant_bindings binds_msg } where - (ct1:_) = cts + ct1:others = cts ---------------- @@ -1452,7 +1283,7 @@ mkIPErr ctxt cts -- Wanted constraints arising from representation-polymorphism checks. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin. -mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkFRRErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkFRRErr ctxt cts = do { -- Zonking/tidying. ; origs <- @@ -1460,36 +1291,18 @@ mkFRRErr ctxt cts zonkTidyOrigins (cec_tidy ctxt) (map ctOrigin cts) <&> -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type. - (nubOrdBy (nonDetCmpType `on` frr_type) . snd) - + (nubOrdBy (nonDetCmpType `on` (snd . frr_orig_and_type)) . snd) -- Obtain all the errors we want to report (constraints with FixedRuntimeRep origin), -- with the corresponding types: -- ty1 :: TYPE rep1, ty2 :: TYPE rep2, ... - ; let tys = map frr_type origs - kis = map typeKind tys - - -- Assemble the error message: pair up each origin with the corresponding type, e.g. - -- • FixedRuntimeRep origin msg 1 ... - -- a :: TYPE r1 - -- • FixedRuntimeRep origin msg 2 ... - -- b :: TYPE r2 - - combine_origin_ty_ki :: CtOrigin -> Type -> Kind -> SDoc - combine_origin_ty_ki orig ty ki = - -- Add bullet points if there is more than one error. - (if length tys > 1 then (bullet <+>) else id) $ - vcat [pprArising orig <> colon - ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE ki] - - msg :: SDoc - msg = vcat $ zipWith3 combine_origin_ty_ki origs tys kis - - ; return $ important msg } + ; let origs_and_tys = map frr_orig_and_type origs + + ; return $ important ctxt $ FixedRuntimeRepError origs_and_tys } where - frr_type :: CtOrigin -> Type - frr_type (FixedRuntimeRepOrigin ty _) = ty - frr_type orig + frr_orig_and_type :: CtOrigin -> (FRROrigin, Type) + frr_orig_and_type (FixedRuntimeRepOrigin ty frr_orig) = (frr_orig, ty) + frr_orig_and_type orig = pprPanic "mkFRRErr: not a FixedRuntimeRep origin" (text "origin =" <+> ppr orig) @@ -1552,61 +1365,59 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM SolverReport mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct ; rdr_env <- getGlobalRdrEnv ; fam_envs <- tcGetFamInstEnvs - ; let coercible_msg = case ctEqRel ct of - NomEq -> empty - ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 + ; let mb_coercible_msg = case ctEqRel ct of + NomEq -> Nothing + ReprEq -> ReportCoercibleMsg <$> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) - ; let report = mconcat [ important coercible_msg - , mk_relevant_bindings binds_msg] - ; mkEqErr_help ctxt report ct ty1 ty2 } + ; (last_msg :| prev_msgs, hints) <- mkEqErr_help ctxt ct ty1 ty2 + ; let + report = foldMap (important ctxt) (reverse prev_msgs) + `mappend` (important ctxt $ mkTcReportWithInfo last_msg $ maybeToList mb_coercible_msg) + `mappend` (mk_relevant_bindings binds_msg) + `mappend` (mk_report_hints hints) + ; return report } where (ty1, ty2) = getEqPredTys (ctPred ct) -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint -- is left over. mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs - -> TcType -> TcType -> SDoc + -> TcType -> TcType -> Maybe CoercibleMsg mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | Just (tc, tys) <- tcSplitTyConApp_maybe ty1 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys , Just msg <- coercible_msg_for_tycon rep_tc - = msg + = Just msg | Just (tc, tys) <- splitTyConApp_maybe ty2 , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys , Just msg <- coercible_msg_for_tycon rep_tc - = msg + = Just msg | Just (s1, _) <- tcSplitAppTy_maybe ty1 , Just (s2, _) <- tcSplitAppTy_maybe ty2 , s1 `eqType` s2 , has_unknown_roles s1 - = hang (text "NB: We cannot know what roles the parameters to" <+> - quotes (ppr s1) <+> text "have;") - 2 (text "we must assume that the role is nominal") + = Just $ UnknownRoles s1 | otherwise - = empty + = Nothing where coercible_msg_for_tycon tc | isAbstractTyCon tc - = Just $ hsep [ text "NB: The type constructor" - , quotes (pprSourceTyCon tc) - , text "is abstract" ] + = Just $ TyConIsAbstract tc | isNewTyCon tc , [data_con] <- tyConDataCons tc , let dc_name = dataConName data_con , isNothing (lookupGRE_Name rdr_env dc_name) - = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name)) - 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) - , text "is not in scope" ]) + = Just $ OutOfScopeNewtypeConstructor tc data_con | otherwise = Nothing has_unknown_roles ty @@ -1619,83 +1430,78 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | otherwise = False -mkEqErr_help :: ReportErrCtxt -> Report +-- | Accumulated messages in reverse order. +type AccReportMsgs = NonEmpty TcReportMsg + +mkEqErr_help :: ReportErrCtxt -> Ct - -> TcType -> TcType -> TcM Report -mkEqErr_help ctxt report ct ty1 ty2 + -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) +mkEqErr_help ctxt ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr ctxt report ct tv1 ty2 + = mkTyVarEqErr ctxt ct tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr ctxt report ct tv2 ty1 + = mkTyVarEqErr ctxt ct tv2 ty1 | otherwise - = return $ reportEqErr ctxt report ct ty1 ty2 + = return (reportEqErr ctxt ct ty1 ty2 :| [], []) -reportEqErr :: ReportErrCtxt -> Report +reportEqErr :: ReportErrCtxt -> Ct - -> TcType -> TcType -> Report -reportEqErr ctxt report ct ty1 ty2 - = mconcat [misMatch, report, eqInfo] + -> TcType -> TcType -> TcReportMsg +reportEqErr ctxt ct ty1 ty2 + = mkTcReportWithInfo mismatch eqInfos where - misMatch = misMatchOrCND False ctxt ct ty1 ty2 - eqInfo = mkEqInfoMsg ct ty1 ty2 + mismatch = misMatchOrCND False ctxt ct ty1 ty2 + eqInfos = eqInfoMsgs ct ty1 ty2 -mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM Report +mkTyVarEqErr :: ReportErrCtxt -> Ct + -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint]) -- tv1 and ty2 are already tidied -mkTyVarEqErr ctxt report ct tv1 ty2 +mkTyVarEqErr ctxt ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) ; dflags <- getDynFlags - ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } + ; return $ mkTyVarEqErr' dflags ctxt ct tv1 ty2 } -mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> Report -mkTyVarEqErr' dflags ctxt report ct tv1 ty2 +mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Ct + -> TcTyVar -> TcType -> (AccReportMsgs, [GhcHint]) +mkTyVarEqErr' dflags ctxt ct tv1 ty2 -- impredicativity is a simple error to understand; try it first | check_eq_result `cterHasProblem` cteImpredicative - = let msg = vcat [ (if isSkolemTyVar tv1 - then text "Cannot equate type variable" - else text "Cannot instantiate unification variable") - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] - in - -- Unlike the other reports, this discards the old 'report_important' + , let + poly_msg = CannotUnifyWithPolytype ct tv1 ty2 + tyvar_eq_info = extraTyVarEqInfo tv1 ty2 + poly_msg_with_info + | isSkolemTyVar tv1 + = mkTcReportWithInfo poly_msg tyvar_eq_info + | otherwise + = poly_msg + = -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. - mconcat [ headline_msg - , important msg - , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty - , report ] + (poly_msg_with_info <| headline_msg :| [], []) | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) - = mconcat [ headline_msg - , extraTyVarEqInfo ctxt tv1 ty2 - , suggestAddSig ctxt ty1 ty2 - , report - ] + = (mkTcReportWithInfo headline_msg tv_extra :| [], add_sig) | cterHasOccursCheck check_eq_result -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it - = let extra2 = mkEqInfoMsg ct ty1 ty2 + = let extras2 = eqInfoMsgs ct ty1 ty2 interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ filter isTyVar $ fvVarList $ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = mk_relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - in - mconcat [headline_msg, extra2, extra3, report] + extras3 = case interesting_tyvars of + [] -> [] + (tv : tvs) -> [OccursCheckInterestingTyVars (tv :| tvs)] + + in (mkTcReportWithInfo headline_msg (extras2 ++ extras3) :| [], []) -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1704,35 +1510,14 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols - = mconcat [ misMatchMsg ctxt ct ty1 ty2 - , extraTyVarEqInfo ctxt tv1 ty2 - , report - ] + = (mkTcReportWithInfo mismatch_msg tv_extra :| [], []) -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_skols = skols, ic_info = skol_info } <- implic + , Implic { ic_skols = skols } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) - = let msg = misMatchMsg ctxt ct ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - in - mconcat [msg, tv_extra, report] + = (SkolemEscape ct implic esc_skols :| [mismatch_msg], []) -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1740,29 +1525,23 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 -- meta tyvar or a TyVarTv, else it'd have been unified -- See Note [Error messages for untouchables] | (implic:_) <- cec_encl ctxt -- Get the innermost context - , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic + , Implic { ic_tclvl = lvl } <- implic = assertPpr (not (isTouchableMetaTyVar lvl tv1)) (ppr tv1 $$ ppr lvl) $ -- See Note [Error messages for untouchables] - let msg = misMatchMsg ctxt ct ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = extraTyVarEqInfo ctxt tv1 ty2 - add_sig = suggestAddSig ctxt ty1 ty2 + let tclvl_extra = UntouchableVariable tv1 implic in - mconcat [msg, tclvl_extra, tv_extra, add_sig, report] + (mkTcReportWithInfo tclvl_extra tv_extra :| [mismatch_msg], add_sig) | otherwise - = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 + = (reportEqErr ctxt ct (mkTyVarTy tv1) ty2 :| [], []) -- This *can* happen (#6123) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. where headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 + mismatch_msg = mkMismatchMsg ct ty1 ty2 + tv_extra = extraTyVarEqInfo tv1 ty2 + add_sig = maybeToList $ suggestAddSig ctxt ty1 ty2 ty1 = mkTyVarTy tv1 @@ -1774,42 +1553,37 @@ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 -- variable is on the right, so we don't get useful info for the CIrredCan, -- and have to compute the result of checkTyVarEq here. - insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs - what = text $ levelString $ - ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel - -levelString :: TypeOrKind -> String -levelString TypeLevel = "type" -levelString KindLevel = "kind" - -mkEqInfoMsg :: Ct -> TcType -> TcType -> Report +eqInfoMsgs :: Ct -> TcType -> TcType -> [TcReportInfo] -- Report (a) ambiguity if either side is a type function application -- e.g. F a0 ~ Int -- (b) warning about injectivity if both sides are the same -- type function application F a ~ F b -- See Note [Non-injective type functions] -mkEqInfoMsg ct ty1 ty2 - = important (tyfun_msg $$ ambig_msg) +eqInfoMsgs ct ty1 ty2 + = catMaybes [tyfun_msg, ambig_msg] where mb_fun1 = isTyFun_maybe ty1 mb_fun2 = isTyFun_maybe ty2 + (ambig_kvs, ambig_tvs) = getAmbigTkvs ct ambig_msg | isJust mb_fun1 || isJust mb_fun2 - = snd (mkAmbigMsg False ct) - | otherwise = empty + , not (null ambig_kvs && null ambig_tvs) + = Just $ Ambiguity False (ambig_kvs, ambig_tvs) + | otherwise + = Nothing tyfun_msg | Just tc1 <- mb_fun1 , Just tc2 <- mb_fun2 , tc1 == tc2 , not (isInjectiveTyCon tc1 Nominal) - = text "NB:" <+> quotes (ppr tc1) - <+> text "is a non-injective type family" - | otherwise = empty + = Just $ NonInjectiveTyFam tc1 + | otherwise + = Nothing misMatchOrCND :: Bool -> ReportErrCtxt -> Ct - -> TcType -> TcType -> Report + -> TcType -> TcType -> TcReportMsg -- If oriented then ty1 is actual, ty2 is expected misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 | insoluble_occurs_check -- See Note [Insoluble occurs check] @@ -1818,56 +1592,26 @@ misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2 || null givens = -- If the equality is unconditionally insoluble -- or there is no context, don't report the context - misMatchMsg ctxt ct ty1 ty2 + mkMismatchMsg ct ty1 ty2 | otherwise - = mconcat [ couldNotDeduce givens ([eq_pred], orig) - , important $ mk_supplementary_ea_msg ctxt level ty1 ty2 orig ] + = CouldNotDeduce givens (ct :| []) (Just $ CND_Extra level ty1 ty2) + where ev = ctEvidence ct - eq_pred = ctEvPred ev - orig = ctEvOrigin ev level = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel givens = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ] -- Keep only UserGivens that have some equalities. -- See Note [Suppress redundant givens during error reporting] -couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> Report -couldNotDeduce givens (wanteds, orig) - = important $ - vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds) - , vcat (pp_givens givens)] - -pp_givens :: [UserGiven] -> [SDoc] -pp_givens givens - = case givens of - [] -> [] - (g:gs) -> ppr_given (text "from the context:") g - : map (ppr_given (text "or from:")) gs - where - ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) - = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) - -- See Note [Suppress redundant givens during error reporting] - -- for why we use mkMinimalBySCs above. - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> ppr (tcl_loc (ic_env implic)) ]) - -- These are for the "blocked" equalities, as described in TcCanonical -- Note [Equalities with incompatible kinds], wrinkle (2). There should -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report -mkBlockedEqErr _ (ct:_) = return $ important msg - where - msg = vcat [ hang (text "Cannot use equality for substitution:") - 2 (ppr (ctPred ct)) - , text "Doing so would be ill-kinded." ] - -- This is a terrible message. Perhaps worse, if the user - -- has -fprint-explicit-kinds on, they will see that the two - -- sides have the same kind, as there is an invisible cast. - -- I really don't know how to do better. -mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM SolverReport +mkBlockedEqErr ctxt (ct:_) = return $ important ctxt (BlockedEquality ct) +mkBlockedEqErr _ [] = panic "mkBlockedEqErr no constraints" {- Note [Suppress redundant givens during error reporting] @@ -1909,37 +1653,31 @@ addition to superclasses (see Note [Remove redundant provided dicts] in GHC.Tc.TyCl.PatSyn). -} -extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> Report +extraTyVarEqInfo :: TcTyVar -> TcType -> [TcReportInfo] -- Add on extra info about skolem constants -- NB: The types themselves are already tidied -extraTyVarEqInfo ctxt tv1 ty2 - = important (extraTyVarInfo ctxt tv1 $$ ty_extra ty2) +extraTyVarEqInfo tv1 ty2 + = extraTyVarInfo tv1 : ty_extra ty2 where ty_extra ty = case tcGetCastedTyVar_maybe ty of - Just (tv, _) -> extraTyVarInfo ctxt tv - Nothing -> empty - -extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc -extraTyVarInfo ctxt tv - = assertPpr (isTyVar tv) (ppr tv) $ - case tcTyVarDetails tv of - SkolemTv {} -> pprSkols ctxt [tv] - RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" - MetaTv {} -> empty - -suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report + Just (tv, _) -> [extraTyVarInfo tv] + Nothing -> [] + +extraTyVarInfo :: TcTyVar -> TcReportInfo +extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $ TyVarInfo tv + +suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Maybe GhcHint -- See Note [Suggest adding a type signature] suggestAddSig ctxt ty1 _ty2 - | null inferred_bndrs -- No let-bound inferred binders in context - = mempty - | [bndr] <- inferred_bndrs - = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr) + | bndr : bndrs <- inferred_bndrs + = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs) | otherwise - = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) + = Nothing where - inferred_bndrs = case tcGetTyVar_maybe ty1 of - Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv - _ -> [] + inferred_bndrs = + case tcGetTyVar_maybe ty1 of + Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv + _ -> [] -- 'find' returns the binders of an InferSkol for 'tv', -- provided there is an intervening implication with @@ -1954,224 +1692,35 @@ suggestAddSig ctxt ty1 _ty2 = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv -------------------- -misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report --- Types are already tidy --- If oriented then ty1 is actual, ty2 is expected -misMatchMsg ctxt ct ty1 ty2 - = important $ - addArising orig $ - pprWithExplicitKindsWhenMismatch ty1 ty2 orig $ - sep [ case orig of - TypeEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig - KindEqOrigin {} -> tk_eq_msg ctxt ct ty1 ty2 orig - _ -> headline_eq_msg False ct ty1 ty2 - , sameOccExtra ty2 ty1 ] - where - orig = ctOrigin ct - -headline_eq_msg :: Bool -> Ct -> Type -> Type -> SDoc --- Generates the main "Could't match 't1' against 't2' --- headline message -headline_eq_msg add_ea ct ty1 ty2 - - | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || - (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || - (isLiftedLevity ty1 && isUnliftedLevity ty2) || - (isLiftedLevity ty2 && isUnliftedLevity ty1) - = text "Couldn't match a lifted type with an unlifted type" - - | isAtomicTy ty1 || isAtomicTy ty2 - = -- Print with quotes - sep [ text herald1 <+> quotes (ppr ty1) - , nest padding $ - text herald2 <+> quotes (ppr ty2) ] - - | otherwise - = -- Print with vertical layout - vcat [ text herald1 <> colon <+> ppr ty1 - , nest padding $ - text herald2 <> colon <+> ppr ty2 ] - where - herald1 = conc [ "Couldn't match" - , if is_repr then "representation of" else "" - , if add_ea then "expected" else "" - , what ] - herald2 = conc [ "with" - , if is_repr then "that of" else "" - , if add_ea then ("actual " ++ what) else "" ] - - padding = length herald1 - length herald2 - - is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } - - what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) - - conc :: [String] -> String - conc = foldr1 add_space - - add_space :: String -> String -> String - add_space s1 s2 | null s1 = s2 - | null s2 = s1 - | otherwise = s1 ++ (' ' : s2) - - -tk_eq_msg :: ReportErrCtxt - -> Ct -> Type -> Type -> CtOrigin -> SDoc -tk_eq_msg ctxt ct ty1 ty2 orig@(TypeEqOrigin { uo_actual = act - , uo_expected = exp - , uo_thing = mb_thing }) - -- We can use the TypeEqOrigin to - -- improve the error message quite a lot - - | isUnliftedTypeKind act, isLiftedTypeKind exp - = sep [ text "Expecting a lifted type, but" - , thing_msg mb_thing (text "an") (text "unlifted") ] - - | isLiftedTypeKind act, isUnliftedTypeKind exp - = sep [ text "Expecting an unlifted type, but" - , thing_msg mb_thing (text "a") (text "lifted") ] - - | tcIsLiftedTypeKind exp - = maybe_num_args_msg $$ - sep [ text "Expected a type, but" - , case mb_thing of - Nothing -> text "found something with kind" - Just thing -> quotes thing <+> text "has kind" - , quotes (pprWithTYPE act) ] - - | Just nargs_msg <- num_args_msg - = nargs_msg $$ - mk_ea_msg ctxt (Just ct) level orig - - | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ - ea_looks_same ty1 ty2 exp act - = mk_ea_msg ctxt (Just ct) level orig - | otherwise -- The mismatched types are /inside/ exp and act - = vcat [ headline_eq_msg False ct ty1 ty2 - , mk_ea_msg ctxt Nothing level orig ] - - where - ct_loc = ctLoc ct - level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel - - thing_msg (Just thing) _ levity = quotes thing <+> text "is" <+> levity - thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" - - num_args_msg = case level of - KindLevel - | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) - -- if one is a meta-tyvar, then it's possible that the user - -- has asked for something impredicative, and we couldn't unify. - -- Don't bother with counting arguments. - -> let n_act = count_args act - n_exp = count_args exp in - case n_act - n_exp of - n | n > 0 -- we don't know how many args there are, so don't - -- recommend removing args that aren't - , Just thing <- mb_thing - -> Just $ text "Expecting" <+> speakN (abs n) <+> - more <+> quotes thing - where - more - | n == 1 = text "more argument to" - | otherwise = text "more arguments to" -- n > 1 - _ -> Nothing - - _ -> Nothing - - maybe_num_args_msg = num_args_msg `orElse` empty - - count_args ty = count isVisibleBinder $ fst $ splitPiTys ty - -tk_eq_msg ctxt ct ty1 ty2 - (KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k) - = vcat [ headline_eq_msg False ct ty1 ty2 - , supplementary_msg ] - where - sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel - sub_whats = text (levelString sub_t_or_k) <> char 's' - -- "types" or "kinds" - - supplementary_msg - = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> - if printExplicitCoercions - || not (cty1 `pickyEqType` cty2) - then vcat [ hang (text "When matching" <+> sub_whats) - 2 (vcat [ ppr cty1 <+> dcolon <+> - ppr (tcTypeKind cty1) - , ppr cty2 <+> dcolon <+> - ppr (tcTypeKind cty2) ]) - , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ] - else text "When matching the kind of" <+> quotes (ppr cty1) - -tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg" - -ea_looks_same :: Type -> Type -> Type -> Type -> Bool --- True if the faulting types (ty1, ty2) look the same as --- the expected/actual types (exp, act). --- If so, we don't want to redundantly report the latter -ea_looks_same ty1 ty2 exp act - = (act `looks_same` ty1 && exp `looks_same` ty2) || - (exp `looks_same` ty1 && act `looks_same` ty2) +mkMismatchMsg :: Ct -> Type -> Type -> TcReportMsg +mkMismatchMsg ct ty1 ty2 = + case ctOrigin ct of + TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } -> + mkTcReportWithInfo + (TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_ct = ct + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_actual = uo_actual + , teq_mismatch_expected = uo_expected + , teq_mismatch_what = mb_thing}) + extras + KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k -> + mkTcReportWithInfo (Mismatch False ct ty1 ty2) + (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k : extras) + _ -> + mkTcReportWithInfo + (Mismatch False ct ty1 ty2) + extras where - looks_same t1 t2 = t1 `pickyEqType` t2 - || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind - -- pickyEqType is sensitive to synonyms, so only replies True - -- when the types really look the same. However, - -- (TYPE 'LiftedRep) and Type both print the same way. - -mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind - -> Type -> Type -> CtOrigin -> SDoc -mk_supplementary_ea_msg ctxt level ty1 ty2 orig - | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig - , not (ea_looks_same ty1 ty2 exp act) - = mk_ea_msg ctxt Nothing level orig - | otherwise - = empty - -mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> SDoc --- Constructs a "Couldn't match" message --- The (Maybe Ct) says whether this is the main top-level message (Just) --- or a supplementary message (Nothing) -mk_ea_msg ctxt at_top level - (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) - | Just thing <- mb_thing - , KindLevel <- level - = hang (text "Expected" <+> kind_desc <> comma) - 2 (text "but" <+> quotes thing <+> text "has kind" <+> - quotes (ppr act)) - - | otherwise - = vcat [ case at_top of - Just ct -> headline_eq_msg True ct exp act - Nothing -> supplementary_ea_msg - , ppWhen expand_syns expandedTys ] - - where - supplementary_ea_msg = vcat [ text "Expected:" <+> ppr exp - , text " Actual:" <+> ppr act ] - - kind_desc | tcIsConstraintKind exp = text "a constraint" - | Just arg <- kindRep_maybe exp -- TYPE t0 - , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case - True -> text "kind" <+> quotes (ppr exp) - False -> text "a type" - | otherwise = text "kind" <+> quotes (ppr exp) - - expand_syns = cec_expand_syns ctxt - - expandedTys = ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat - [ text "Type synonyms expanded:" - , text "Expected type:" <+> ppr expTy1 - , text " Actual type:" <+> ppr expTy2 ] - - (expTy1, expTy2) = expandSynonymsToMatch exp act - -mk_ea_msg _ _ _ _ = empty + orig = ctOrigin ct + extras = sameOccExtras ty2 ty1 + ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig --- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a --- type mismatch occurs to due invisible kind arguments. +-- | Whether to prints explicit kinds (with @-fprint-explicit-kinds@) +-- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments. -- -- This function first checks to see if the 'CtOrigin' argument is a -- 'TypeEqOrigin', and if so, uses the expected/actual types from that to @@ -2180,18 +1729,16 @@ mk_ea_msg _ _ _ _ = empty -- mismatch occurred in an invisible argument position or not). If the -- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types -- themselves. -pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin - -> SDoc -> SDoc -pprWithExplicitKindsWhenMismatch ty1 ty2 ct - = pprWithExplicitKindsWhen show_kinds +shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool +shouldPprWithExplicitKinds ty1 ty2 ct + = tcEqTypeVis act_ty exp_ty + -- True when the visible bit of the types look the same, + -- so we want to show the kinds in the displayed type. where (act_ty, exp_ty) = case ct of TypeEqOrigin { uo_actual = act , uo_expected = exp } -> (act, exp) _ -> (ty1, ty2) - show_kinds = tcEqTypeVis act_ty exp_ty - -- True when the visible bit of the types look the same, - -- so we want to show the kinds in the displayed type {- Note [Insoluble occurs check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2209,165 +1756,11 @@ This is done in misMatchOrCND (via the insoluble_occurs_check arg) (NB: there are potentially-soluble ones, like (a ~ F a b), and we don't want to be as draconian with them.) - -Note [Expanding type synonyms to make types similar] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In type error messages, if -fprint-expanded-types is used, we want to expand -type synonyms to make expected and found types as similar as possible, but we -shouldn't expand types too much to make type messages even more verbose and -harder to understand. The whole point here is to make the difference in expected -and found types clearer. - -`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms -only as much as necessary. Given two types t1 and t2: - - * If they're already same, it just returns the types. - - * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are - type constructors), it expands C1 and C2 if they're different type synonyms. - Then it recursively does the same thing on expanded types. If C1 and C2 are - same, then it applies the same procedure to arguments of C1 and arguments of - C2 to make them as similar as possible. - - Most important thing here is to keep number of synonym expansions at - minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, - Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and - `T (T3, T3, Bool)`. - - * Otherwise types don't have same shapes and so the difference is clearly - visible. It doesn't do any expansions and show these types. - -Note that we only expand top-layer type synonyms. Only when top-layer -constructors are the same we start expanding inner type synonyms. - -Suppose top-layer type synonyms of t1 and t2 can expand N and M times, -respectively. If their type-synonym-expanded forms will meet at some point (i.e. -will have same shapes according to `sameShapes` function), it's possible to find -where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) -comparisons. We first collect all the top-layer expansions of t1 and t2 in two -lists, then drop the prefix of the longer list so that they have same lengths. -Then we search through both lists in parallel, and return the first pair of -types that have same shapes. Inner types of these two types with same shapes -are then expanded using the same algorithm. - -In case they don't meet, we return the last pair of types in the lists, which -has top-layer type synonyms completely expanded. (in this case the inner types -are not expanded at all, as the current form already shows the type error) -} --- | Expand type synonyms in given types only enough to make them as similar as --- possible. Returned types are the same in terms of used type synonyms. --- --- To expand all synonyms, see 'Type.expandTypeSynonyms'. --- --- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for --- some examples of how this should work. -expandSynonymsToMatch :: Type -> Type -> (Type, Type) -expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) - where - (ty1_ret, ty2_ret) = go ty1 ty2 - - -- | Returns (type synonym expanded version of first type, - -- type synonym expanded version of second type) - go :: Type -> Type -> (Type, Type) - go t1 t2 - | t1 `pickyEqType` t2 = - -- Types are same, nothing to do - (t1, t2) - - go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 - , tys1 `equalLength` tys2 = - -- Type constructors are same. They may be synonyms, but we don't - -- expand further. The lengths of tys1 and tys2 must be equal; - -- for example, with type S a = a, we don't want - -- to zip (S Monad Int) and (S Bool). - let (tys1', tys2') = - unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) - in (TyConApp tc1 tys1', TyConApp tc2 tys2') - - go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - - go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = - let (t1_1', t2_1') = go t1_1 t2_1 - (t1_2', t2_2') = go t1_2 t2_2 - in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } - , ty2 { ft_arg = t2_1', ft_res = t2_2' }) - - go (ForAllTy b1 t1) (ForAllTy b2 t2) = - -- NOTE: We may have a bug here, but we just can't reproduce it easily. - -- See D1016 comments for details and our attempts at producing a test - -- case. Short version: We probably need RnEnv2 to really get this right. - let (t1', t2') = go t1 t2 - in (ForAllTy b1 t1', ForAllTy b2 t2') - - go (CastTy ty1 _) ty2 = go ty1 ty2 - go ty1 (CastTy ty2 _) = go ty1 ty2 - - go t1 t2 = - -- See Note [Expanding type synonyms to make types similar] for how this - -- works - let - t1_exp_tys = t1 : tyExpansions t1 - t2_exp_tys = t2 : tyExpansions t2 - t1_exps = length t1_exp_tys - t2_exps = length t2_exp_tys - dif = abs (t1_exps - t2_exps) - in - followExpansions $ - zipEqual "expandSynonymsToMatch.go" - (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) - (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) - - -- | Expand the top layer type synonyms repeatedly, collect expansions in a - -- list. The list does not include the original type. - -- - -- Example, if you have: - -- - -- type T10 = T9 - -- type T9 = T8 - -- ... - -- type T0 = Int - -- - -- `tyExpansions T10` returns [T9, T8, T7, ... Int] - -- - -- This only expands the top layer, so if you have: - -- - -- type M a = Maybe a - -- - -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) - tyExpansions :: Type -> [Type] - tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) - - -- | Drop the type pairs until types in a pair look alike (i.e. the outer - -- constructors are the same). - followExpansions :: [(Type, Type)] -> (Type, Type) - followExpansions [] = pprPanic "followExpansions" empty - followExpansions [(t1, t2)] - | sameShapes t1 t2 = go t1 t2 -- expand subtrees - | otherwise = (t1, t2) -- the difference is already visible - followExpansions ((t1, t2) : tss) - -- Traverse subtrees when the outer shapes are the same - | sameShapes t1 t2 = go t1 t2 - -- Otherwise follow the expansions until they look alike - | otherwise = followExpansions tss - - sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (FunTy {}) (FunTy {}) = True - sameShapes (ForAllTy {}) (ForAllTy {}) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False - -sameOccExtra :: TcType -> TcType -> SDoc +sameOccExtras :: TcType -> TcType -> [TcReportInfo] -- See Note [Disambiguating (X ~ X) errors] -sameOccExtra ty1 ty2 +sameOccExtras ty1 ty2 | Just (tc1, _) <- tcSplitTyConApp_maybe ty1 , Just (tc2, _) <- tcSplitTyConApp_maybe ty2 , let n1 = tyConName tc1 @@ -2376,23 +1769,9 @@ sameOccExtra ty1 ty2 same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2) , n1 /= n2 -- Different Names , same_occ -- but same OccName - = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + = [SameOcc same_pkg n1 n2] | otherwise - = empty - where - ppr_from same_pkg nm - | isGoodSrcSpan loc - = hang (quotes (ppr nm) <+> text "is defined at") - 2 (ppr loc) - | otherwise -- Imported things have an UnhelpfulSrcSpan - = hang (quotes (ppr nm)) - 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) - , ppUnless (same_pkg || pkg == mainUnit) $ - nest 4 $ text "in package" <+> quotes (ppr pkg) ]) - where - pkg = moduleUnit mod - mod = nameModule nm - loc = nameSrcSpan nm + = [] {- Note [Suggest adding a type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2461,7 +1840,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM Report +mkDictErr :: HasDebugCallStack => ReportErrCtxt -> [Ct] -> TcM SolverReport mkDictErr ctxt cts = assert (not (null cts)) $ do { inst_envs <- tcGetInstEnvs @@ -2475,7 +1854,7 @@ mkDictErr ctxt cts -- have the same source-location origin, to try avoid a cascade -- of error from one location ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; return $ important err } + ; return $ important ctxt err } where no_givens = null (getUserGivens ctxt) @@ -2507,30 +1886,27 @@ mkDictErr ctxt cts -- matching and unifying instances, and say "The choice depends on the instantion of ..., -- and the result of evaluating ...". mk_dict_err :: HasCallStack => ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM SDoc + -> TcM TcReportMsg -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) -mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) +mk_dict_err ctxt (ct, (matches, unifiers, unsafe_overlapped)) | null matches -- No matches but perhaps several unifiers - = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct + = do { (_, rel_binds, ct) <- relevantBindings True ctxt ct ; candidate_insts <- get_candidate_instances - ; field_suggestions <- record_field_suggestions - ; return (cannot_resolve_msg ct candidate_insts binds_msg field_suggestions) } + ; (imp_errs, field_suggestions) <- record_field_suggestions + ; return (cannot_resolve_msg ct candidate_insts rel_binds imp_errs field_suggestions) } | null unsafe_overlapped -- Some matches => overlap errors - = return overlap_msg + = return $ overlap_msg | otherwise - = return safe_haskell_msg + = return $ safe_haskell_msg where orig = ctOrigin ct pred = ctPred ct (clas, tys) = getClassPredTys pred ispecs = [ispec | (ispec, _) <- matches] unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped] - useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) - -- useful_givens are the enclosing implications with non-empty givens, - -- modulo the horrid discardProvCtxtGivens get_candidate_instances :: TcM [ClsInst] -- See Note [Report candidate instances] @@ -2553,18 +1929,18 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over | otherwise = False -- See Note [Out-of-scope fields with -XOverloadedRecordDot] - record_field_suggestions :: TcM SDoc - record_field_suggestions = flip (maybe $ return empty) record_field $ \name -> + record_field_suggestions :: TcM ([ImportError], [GhcHint]) + record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name -> do { glb_env <- getGlobalRdrEnv ; lcl_env <- getLocalRdrEnv ; if occ_name_in_scope glb_env lcl_env name - then return empty - else do { dflags <- getDynFlags - ; imp_info <- getImports - ; curr_mod <- getModule - ; hpt <- getHpt - ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod - glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } + then return ([], noHints) + else do { dflags <- getDynFlags + ; imp_info <- getImports + ; curr_mod <- getModule + ; hpt <- getHpt + ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod + glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } } occ_name_in_scope glb_env lcl_env occ_name = not $ null (lookupGlobalRdrEnv glb_env occ_name) && @@ -2574,232 +1950,22 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over HasFieldOrigin name -> Just (mkVarOccFS name) _ -> Nothing - cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc -> SDoc - cannot_resolve_msg ct candidate_insts binds_msg field_suggestions - = vcat [ no_inst_msg - , nest 2 extra_note - , vcat (pp_givens useful_givens) - , mb_patsyn_prov `orElse` empty - , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens)) - (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ]) - - , ppWhen (isNothing mb_patsyn_prov) $ - -- Don't suggest fixes for the provided context of a pattern - -- synonym; the right fix is to bind more in the pattern - show_fixes (ctxtFixes has_ambig_tvs pred implics - ++ drv_fixes) - , ppWhen (not (null candidate_insts)) - (hang (text "There are instances for similar types:") - 2 (vcat (map ppr candidate_insts))) - -- See Note [Report candidate instances] - , field_suggestions ] - where - orig = ctOrigin ct - -- See Note [Highlighting ambiguous type variables] - lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs) - && not (null unifiers) && null useful_givens - - (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct - ambig_tvs = uncurry (++) (getAmbigTkvs ct) - - no_inst_msg - | lead_with_ambig - = ambig_msg <+> pprArising orig - $$ text "prevents the constraint" <+> quotes (pprParendType pred) - <+> text "from being solved." - - | null useful_givens - = addArising orig $ text "No instance for" - <+> pprParendType pred - - | otherwise - = addArising orig $ text "Could not deduce" - <+> pprParendType pred - - potential_msg - = ppWhen (not (null unifiers) && want_potential orig) $ - potential_hdr $$ - potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) - - potential_hdr - = ppWhen lead_with_ambig $ - text "Probable fix: use a type annotation to specify what" - <+> pprQuotedList ambig_tvs <+> text "should be." - - mb_patsyn_prov :: Maybe SDoc - mb_patsyn_prov - | not lead_with_ambig - , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig - = Just (vcat [ text "In other words, a successful match on the pattern" - , nest 2 $ ppr pat - , text "does not provide the constraint" <+> pprParendType pred ]) - | otherwise = Nothing - - -- Report "potential instances" only when the constraint arises - -- directly from the user's use of an overloaded function - want_potential (TypeEqOrigin {}) = False - want_potential _ = True - - extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) - = text "(maybe you haven't applied a function to enough arguments?)" - | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) - , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) - , Just (tc,_) <- tcSplitTyConApp_maybe ty - , not (isTypeFamilyTyCon tc) - = hang (text "GHC can't yet do polykinded") - 2 (text "Typeable" <+> - parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) - | otherwise - = empty - - drv_fixes = case orig of - DerivClauseOrigin -> [drv_fix False] - StandAloneDerivOrigin -> [drv_fix True] - DerivOriginDC _ _ standalone -> [drv_fix standalone] - DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] - _ -> [] - - drv_fix standalone_wildcard - | standalone_wildcard - = text "fill in the wildcard constraint yourself" - | otherwise - = hang (text "use a standalone 'deriving instance' declaration,") - 2 (text "so you can specify the instance context yourself") + cannot_resolve_msg :: Ct -> [ClsInst] -> RelevantBindings -> [ImportError] -> [GhcHint] -> TcReportMsg + cannot_resolve_msg ct candidate_insts binds imp_errs field_suggestions + = CannotResolveInstance ct unifiers candidate_insts imp_errs field_suggestions binds + -- Overlap errors. + overlap_msg, safe_haskell_msg :: TcReportMsg -- Normal overlap error overlap_msg - = assert (not (null matches)) $ - vcat [ addArising orig (text "Overlapping instances for" - <+> pprType (mkClassPred clas tys)) - - , ppUnless (null matching_givens) $ - sep [text "Matching givens (or their superclasses):" - , nest 2 (vcat matching_givens)] - - , potentialInstancesErrMsg - (PotentialInstances { matches = map fst matches, unifiers }) - - , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ - -- Intuitively, some given matched the wanted in their - -- flattened or rewritten (from given equalities) form - -- but the matcher can't figure that out because the - -- constraints are non-flat and non-rewritten so we - -- simply report back the whole given - -- context. Accelerate Smart.hs showed this problem. - sep [ text "There exists a (perhaps superclass) match:" - , nest 2 (vcat (pp_givens useful_givens))] - - , ppWhen (isSingleton matches) $ - parens (vcat [ ppUnless (null tyCoVars) $ - text "The choice depends on the instantiation of" <+> - quotes (pprWithCommas ppr tyCoVars) - , ppUnless (null famTyCons) $ - if (null tyCoVars) - then - text "The choice depends on the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - else - text "and the result of evaluating" <+> - quotes (pprWithCommas ppr famTyCons) - , ppWhen (null (matching_givens)) $ - vcat [ text "To pick the first instance above, use IncoherentInstances" - , text "when compiling the other instance declarations"] - ])] - where - tyCoVars = tyCoVarsOfTypesList tys - famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys - - matching_givens = mapMaybe matchable useful_givens - - matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) - = case ev_vars_matching of - [] -> Nothing - _ -> Just $ hang (pprTheta ev_vars_matching) - 2 (sep [ text "bound by" <+> ppr skol_info - , text "at" <+> - ppr (tcl_loc (ic_env implic)) ]) - where ev_vars_matching = [ pred - | ev_var <- evvars - , let pred = evVarPred ev_var - , any can_match (pred : transSuperClasses pred) ] - can_match pred - = case getClassPredTys_maybe pred of - Just (clas', tys') -> clas' == clas - && isJust (tcMatchTys tys tys') - Nothing -> False + = assert (not (null matches)) $ OverlappingInstances ct ispecs unifiers -- Overlap error because of Safe Haskell (first -- match should be the most specific match) safe_haskell_msg = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $ - vcat [ addArising orig (text "Unsafe overlapping instances for" - <+> pprType (mkClassPred clas tys)) - , sep [text "The matching instance is:", - nest 2 (pprInstance $ head ispecs)] - , vcat [ text "It is compiled in a Safe module and as such can only" - , text "overlap instances from the same module, however it" - , text "overlaps the following instances from different" <+> - text "modules:" - , nest 2 (vcat [pprInstances $ unsafe_ispecs]) - ] - ] - - -ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] -ctxtFixes has_ambig_tvs pred implics - | not has_ambig_tvs - , isTyVarClassPred pred - , (skol:skols) <- usefulContext implics pred - , let what | null skols - , SigSkol (PatSynCtxt {}) _ _ <- skol - = text "\"required\"" - | otherwise - = empty - = [sep [ text "add" <+> pprParendType pred - <+> text "to the" <+> what <+> text "context of" - , nest 2 $ ppr_skol skol $$ - vcat [ text "or" <+> ppr_skol skol - | skol <- skols ] ] ] - | otherwise = [] - where - ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) - ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) - ppr_skol skol_info = ppr skol_info - -discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] -discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] - | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens - | otherwise - = givens - where - discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' - discard _ _ = False - -usefulContext :: [Implication] -> PredType -> [SkolemInfo] --- usefulContext picks out the implications whose context --- the programmer might plausibly augment to solve 'pred' -usefulContext implics pred - = go implics - where - pred_tvs = tyCoVarsOfType pred - go [] = [] - go (ic : ics) - | implausible ic = rest - | otherwise = ic_info ic : rest - where - -- Stop when the context binds a variable free in the predicate - rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] - | otherwise = go ics - - implausible ic - | null (ic_skols ic) = True - | implausible_info (ic_info ic) = True - | otherwise = False - - implausible_info (SigSkol (InfSigCtxt {}) _ _) = True - implausible_info _ = False - -- Do not suggest adding constraints to an *inferred* type signature + UnsafeOverlap ct ispecs unsafe_ispecs + {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2829,47 +1995,6 @@ from being solved: Once these conditions are satisfied, we can safely say that ambiguity prevents the constraint from being solved. -Note [discardProvCtxtGivens] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In most situations we call all enclosing implications "useful". There is one -exception, and that is when the constraint that causes the error is from the -"provided" context of a pattern synonym declaration: - - pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a - -- required => provided => type - pattern Pat x <- (Just x, 4) - -When checking the pattern RHS we must check that it does actually bind all -the claimed "provided" constraints; in this case, does the pattern (Just x, 4) -bind the (Show a) constraint. Answer: no! - -But the implication we generate for this will look like - forall a. (Num a, Eq a) => [W] Show a -because when checking the pattern we must make the required -constraints available, since they are needed to match the pattern (in -this case the literal '4' needs (Num a, Eq a)). - -BUT we don't want to suggest adding (Show a) to the "required" constraints -of the pattern synonym, thus: - pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a -It would then typecheck but it's silly. We want the /pattern/ to bind -the alleged "provided" constraints, Show a. - -So we suppress that Implication in discardProvCtxtGivens. It's -painfully ad-hoc but the truth is that adding it to the "required" -constraints would work. Suppressing it solves two problems. First, -we never tell the user that we could not deduce a "provided" -constraint from the "required" context. Second, we never give a -possible fix that suggests to add a "provided" constraint to the -"required" context. - -For example, without this distinction the above code gives a bad error -message (showing both problems): - - error: Could not deduce (Show a) ... from the context: (Eq a) - ... Possible fix: add (Show a) to the context of - the signature for pattern synonym `Pat' ... - Note [Out-of-scope fields with -XOverloadedRecordDot] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ With -XOverloadedRecordDot, when a field isn't in scope, the error that appears @@ -2899,202 +2024,6 @@ results in in the import of ‘Data.Monoid’ -} -show_fixes :: [SDoc] -> SDoc -show_fixes [] = empty -show_fixes (f:fs) = sep [ text "Possible fix:" - , nest 2 (vcat (f : map (text "or" <+>) fs))] - - --- | This datatype collates instances that match or unifier, --- in order to report an error message for an unsolved typeclass constraint. -data PotentialInstances - = PotentialInstances - { matches :: [ClsInst] - , unifiers :: [ClsInst] - } - --- | Directly display the given matching and unifying instances, --- with a header for each: `Matching instances`/`Potentially matching instances`. -pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc -pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = - vcat - [ ppWhen (not $ null matches) $ - text "Matching instance" <> plural matches <> colon $$ - nest 2 (vcat (map ppr_inst matches)) - , ppWhen (not $ null unifiers) $ - (text "Potentially matching instance" <> plural unifiers <> colon) $$ - nest 2 (vcat (map ppr_inst unifiers)) - ] - --- | Display a summary of available instances, omitting those involving --- out-of-scope types, in order to explain why we couldn't solve a particular --- constraint, e.g. due to instance overlap or out-of-scope types. --- --- To directly display a collection of matching/unifying instances, --- use 'pprPotentialInstances'. -potentialInstancesErrMsg :: PotentialInstances -> SDoc --- See Note [Displaying potential instances] -potentialInstancesErrMsg potentials = - sdocOption sdocPrintPotentialInstances $ \print_insts -> - getPprStyle $ \sty -> - potentials_msg_with_options potentials print_insts sty - --- | Display a summary of available instances, omitting out-of-scope ones. --- --- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing --- options. -potentials_msg_with_options :: PotentialInstances - -> Bool -- ^ Whether to print /all/ potential instances - -> PprStyle - -> SDoc -potentials_msg_with_options - (PotentialInstances { matches, unifiers }) - show_all_potentials sty - | null matches && null unifiers - = empty - - | null show_these_matches && null show_these_unifiers - = vcat [ not_in_scope_msg empty - , flag_hint ] - - | otherwise - = vcat [ pprPotentialInstances - pprInstance -- print instance + location info - (PotentialInstances - { matches = show_these_matches - , unifiers = show_these_unifiers }) - , overlapping_but_not_more_specific_msg sorted_matches - , nest 2 $ vcat - [ ppWhen (n_in_scope_hidden > 0) $ - text "...plus" - <+> speakNOf n_in_scope_hidden (text "other") - , ppWhen (not_in_scopes > 0) $ - not_in_scope_msg (text "...plus") - , flag_hint ] ] - where - n_show_matches, n_show_unifiers :: Int - n_show_matches = 3 - n_show_unifiers = 2 - - (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches - (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers - sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches - sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers - (show_these_matches, show_these_unifiers) - | show_all_potentials = (sorted_matches, sorted_unifiers) - | otherwise = (take n_show_matches sorted_matches - ,take n_show_unifiers sorted_unifiers) - n_in_scope_hidden - = length sorted_matches + length sorted_unifiers - - length show_these_matches - length show_these_unifiers - - -- "in scope" means that all the type constructors - -- are lexically in scope; these instances are likely - -- to be more useful - inst_in_scope :: ClsInst -> Bool - inst_in_scope cls_inst = nameSetAll name_in_scope $ - orphNamesOfTypes (is_tys cls_inst) - - name_in_scope name - | pretendNameIsInScope name - = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names - | Just mod <- nameModule_maybe name - = qual_in_scope (qualName sty mod (nameOccName name)) - | otherwise - = True - - qual_in_scope :: QualifyName -> Bool - qual_in_scope NameUnqual = True - qual_in_scope (NameQual {}) = True - qual_in_scope _ = False - - not_in_scopes :: Int - not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers - - not_in_scope_msg herald = - hang (herald <+> speakNOf not_in_scopes (text "instance") - <+> text "involving out-of-scope types") - 2 (ppWhen show_all_potentials $ - pprPotentialInstances - pprInstanceHdr -- only print the header, not the instance location info - (PotentialInstances - { matches = not_in_scope_matches - , unifiers = not_in_scope_unifiers - })) - - flag_hint = ppUnless (show_all_potentials - || (equalLength show_these_matches matches - && equalLength show_these_unifiers unifiers)) $ - text "(use -fprint-potential-instances to see them all)" - --- | Compute a message informing the user of any instances that are overlapped --- but were not discarded because the instance overlapping them wasn't --- strictly more specific. -overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc -overlapping_but_not_more_specific_msg insts - -- Only print one example of "overlapping but not strictly more specific", - -- to avoid information overload. - | overlap : _ <- overlapping_but_not_more_specific - = overlap_header $$ ppr_overlapping overlap - | otherwise - = empty - where - overlap_header :: SDoc - overlap_header - | [_] <- overlapping_but_not_more_specific - = text "An overlapping instance can only be chosen when it is strictly more specific." - | otherwise - = text "Overlapping instances can only be chosen when they are strictly more specific." - overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] - overlapping_but_not_more_specific - = nubOrdBy (comparing (is_dfun . fst)) - [ (overlapper, overlappee) - | these <- groupBy ((==) `on` is_cls_nm) insts - -- Take all pairs of distinct instances... - , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` - , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` - -- ... such that one instance in the pair overlaps the other... - , let mb_overlapping - | hasOverlappingFlag (overlapMode $ is_flag one) - || hasOverlappableFlag (overlapMode $ is_flag other) - = [(one, other)] - | hasOverlappingFlag (overlapMode $ is_flag other) - || hasOverlappableFlag (overlapMode $ is_flag one) - = [(other, one)] - | otherwise - = [] - , (overlapper, overlappee) <- mb_overlapping - -- ... but the overlapper is not more specific than the overlappee. - , not (overlapper `more_specific_than` overlappee) - ] - more_specific_than :: ClsInst -> ClsInst -> Bool - is1 `more_specific_than` is2 - = isJust (tcMatchTys (is_tys is1) (is_tys is2)) - ppr_overlapping :: (ClsInst, ClsInst) -> SDoc - ppr_overlapping (overlapper, overlappee) - = text "The first instance that follows overlaps the second, but is not more specific than it:" - $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) - -{- Note [Displaying potential instances] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When showing a list of instances for - - overlapping instances (show ones that match) - - no such instance (show ones that could match) -we want to give it a bit of structure. Here's the plan - -* Say that an instance is "in scope" if all of the - type constructors it mentions are lexically in scope. - These are the ones most likely to be useful to the programmer. - -* Show at most n_show in-scope instances, - and summarise the rest ("plus N others") - -* Summarise the not-in-scope instances ("plus 4 not in scope") - -* Add the flag -fshow-potential-instances which replaces the - summary with the full list --} - {- Note [Kind arguments in error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3118,59 +2047,6 @@ the above error message would instead be displayed as: Which makes it clearer that the culprit is the mismatch between `k2` and `k20`. -} -mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence - -> Ct -> (Bool, SDoc) -mkAmbigMsg prepend_msg ct - | null ambig_kvs && null ambig_tvs = (False, empty) - | otherwise = (True, msg) - where - (ambig_kvs, ambig_tvs) = getAmbigTkvs ct - - msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] - || any isRuntimeUnkSkol ambig_tvs - = vcat [ text "Cannot resolve unknown runtime type" - <> plural ambig_tvs <+> pprQuotedList ambig_tvs - , text "Use :print or :force to determine these types"] - - | not (null ambig_tvs) - = pp_ambig (text "type") ambig_tvs - - | otherwise - = pp_ambig (text "kind") ambig_kvs - - pp_ambig what tkvs - | prepend_msg -- "Ambiguous type variable 't0'" - = text "Ambiguous" <+> what <+> text "variable" - <> plural tkvs <+> pprQuotedList tkvs - - | otherwise -- "The type variable 't0' is ambiguous" - = text "The" <+> what <+> text "variable" <> plural tkvs - <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" - -pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc -pprSkols ctxt tvs - = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) - where - pp_one (UnkSkol, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "(rigid, skolem)") - , nest 2 (text "of unknown origin") - , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) - ] - pp_one (RuntimeUnkSkol, tvs) - = hang (pprQuotedList tvs) - 2 (is_or_are tvs "an" "unknown runtime") - pp_one (skol_info, tvs) - = vcat [ hang (pprQuotedList tvs) - 2 (is_or_are tvs "a" "rigid" <+> text "bound by") - , nest 2 (pprSkolInfo skol_info) - , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] - - is_or_are [_] article adjective = text "is" <+> text article <+> text adjective - <+> text "type variable" - is_or_are _ _ adjective = text "are" <+> text adjective - <+> text "type variables" - getAmbigTkvs :: Ct -> ([Var],[Var]) getAmbigTkvs ct = partition (`elemVarSet` dep_tkv_set) ambig_tkvs @@ -3178,32 +2054,6 @@ getAmbigTkvs ct tkvs = tyCoVarsOfCtList ct ambig_tkvs = filter isAmbiguousTyVar tkvs dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) - -getSkolemInfo :: [Implication] -> [TcTyVar] - -> [(SkolemInfo, [TcTyVar])] -- #14628 --- Get the skolem info for some type variables --- from the implication constraints that bind them. --- --- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty -getSkolemInfo _ [] - = [] - -getSkolemInfo [] tvs - | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 - | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info - pprTraceUserWarning msg [(UnkSkol,tvs)] - where - msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs - $$ text "This should not happen, please report it as a bug following the instructions at:" - $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" - - -getSkolemInfo (implic:implics) tvs - | null tvs_here = getSkolemInfo implics tvs - | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other - where - (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs - ----------------------- -- relevantBindings looks at the value environment and finds values whose -- types mention any of the offending type variables. It has to be @@ -3216,7 +2066,7 @@ getSkolemInfo (implic:implics) tvs relevantBindings :: Bool -- True <=> filter by tyvar; False <=> no filtering -- See #8191 -> ReportErrCtxt -> Ct - -> TcM (ReportErrCtxt, SDoc, Ct) + -> TcM (ReportErrCtxt, RelevantBindings, Ct) -- Also returns the zonked and tidied CtOrigin of the constraint relevantBindings want_filtering ctxt ct = do { traceTc "relevantBindings" (ppr ct) @@ -3235,9 +2085,9 @@ relevantBindings want_filtering ctxt ct ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env] - ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs + ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs ; let ctxt' = ctxt { cec_tidy = env2 } - ; return (ctxt', doc, ct') } + ; return (ctxt', relev_bds, ct') } where loc = ctLoc ct lcl_env = ctLocEnv loc @@ -3247,7 +2097,7 @@ relevant_bindings :: Bool -> TcLclEnv -> NameEnv Type -- Cache of already zonked and tidied types -> TyCoVarSet - -> TcM SDoc + -> TcM RelevantBindings relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs = do { dflags <- getDynFlags ; traceTc "relevant_bindings" $ @@ -3257,18 +2107,12 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs , pprWithCommas id [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - ; (docs, discards) - <- go dflags (maxRelevantBinds dflags) - emptyVarSet [] False + ; go dflags (maxRelevantBinds dflags) + emptyVarSet (RelevantBindings [] False) (removeBindingShadowing $ tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first, -- which are probably the most relevant ones - - ; let doc = ppUnless (null docs) $ - hang (text "Relevant bindings include") - 2 (vcat docs $$ ppWhen discards discardMsg) - - ; return doc } + } where run_out :: Maybe Int -> Bool run_out Nothing = False @@ -3278,14 +2122,13 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs dec_max = fmap (\n -> n - 1) - go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc] - -> Bool -- True <=> some filtered out due to lack of fuel + go :: DynFlags -> Maybe Int -> TcTyVarSet + -> RelevantBindings -> [TcBinder] - -> TcM ([SDoc], Bool) -- The bool says if we filtered any out - -- because of lack of fuel - go _ _ _ docs discards [] - = return (reverse docs, discards) - go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs) + -> TcM RelevantBindings + go _ _ _ (RelevantBindings bds discards) [] + = return $ RelevantBindings (reverse bds) discards + go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs) = case tc_bndr of TcTvBndr {} -> discard_it TcIdBndr id top_lvl -> go2 (idName id) top_lvl @@ -3301,17 +2144,14 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs Nothing -> discard_it -- No info; discard } where - discard_it = go dflags n_left tvs_seen docs - discards tc_bndrs + discard_it = go dflags n_left tvs_seen rels tc_bndrs go2 id_name top_lvl = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of Just tty -> tty Nothing -> pprPanic "relevant_bindings" (ppr id_name) ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyCoVarsOfType tidy_ty - doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty - , nest 2 (parens (text "bound at" - <+> ppr (getSrcLoc id_name)))] + bd = (id_name, tidy_ty) new_seen = tvs_seen `unionVarSet` id_tvs ; if (want_filtering && not (hasPprDebug dflags) @@ -3328,44 +2168,26 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions already-seen type variables, so discard it - then go dflags n_left tvs_seen docs - True -- Record that we have now discarded something + then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something tc_bndrs -- Keep this binding, decrement fuel else go dflags (dec_max n_left) new_seen - (doc:docs) discards tc_bndrs } - - -discardMsg :: SDoc -discardMsg = text "(Some bindings suppressed;" <+> - text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + (RelevantBindings (bd:bds) discards) tc_bndrs } ----------------------- warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM () -warnDefaulting the_tv wanteds default_ty +warnDefaulting _ [] _ + = panic "warnDefaulting: empty Wanteds" +warnDefaulting the_tv wanteds@(ct:_) default_ty = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyCoVars env0 $ tyCoVarsOfCtsList (listToBag wanteds) tidy_wanteds = map (tidyCt tidy_env) wanteds tidy_tv = lookupVarEnv (snd tidy_env) the_tv - (loc, ppr_wanteds) = pprWithArising tidy_wanteds - warn_msg = - hang (hsep $ [ text "Defaulting" ] - ++ - (case tidy_tv of - Nothing -> [] - Just tv -> [text "the type variable" - , quotes (ppr tv)]) - ++ - [ text "to type" - , quotes (ppr default_ty) - , text "in the following constraint" <> plural tidy_wanteds ]) - 2 - ppr_wanteds - ; let diag = TcRnUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnTypeDefaults) noHints warn_msg + diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + loc = ctLoc ct ; setCtLocM loc $ diagnosticTc warn_default diag } {- diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index d1c727da35..7d1388c112 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -32,6 +32,8 @@ where import GHC.Prelude +import GHC.Tc.Errors.Types ( HoleFitDispConfig(..), FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits ) import GHC.Tc.Types import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint @@ -413,12 +415,6 @@ fits like (`id (_ :: a)` and `head (_ :: [a])`) when looking for fits of type `a`, where `a` is a skolem. -} -data HoleFitDispConfig = HFDC { showWrap :: Bool - , showWrapVars :: Bool - , showType :: Bool - , showProv :: Bool - , showMatches :: Bool } - -- We read the various -no-show-*-of-hole-fits flags -- and set the display config accordingly. getHoleFitDispConfig :: TcM HoleFitDispConfig @@ -560,14 +556,13 @@ findValidHoleFits :: TidyEnv -- ^ The tidy_env for zonking -- ^ The unsolved simple constraints in the implication for -- the hole. -> Hole - -> TcM (TidyEnv, SDoc) + -> TcM (TidyEnv, ValidHoleFits) findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ , hole_loc = ct_loc , hole_ty = hole_ty }) = do { rdr_env <- getGlobalRdrEnv ; lclBinds <- getLocalBindings tidy_env ct_loc ; maxVSubs <- maxValidHoleFits <$> getDynFlags - ; hfdc <- getHoleFitDispConfig ; sortingAlg <- getHoleFitSortingAlg ; dflags <- getDynFlags ; hfPlugs <- tcg_hf_plugins <$> getGblEnv @@ -607,12 +602,11 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs vDiscards = pVDisc || searchDiscards ; subs_with_docs <- addHoleFitDocs limited_subs - ; let vMsg = ppUnless (null subs_with_docs) $ - hang (text "Valid hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) subs_with_docs) - $$ ppWhen vDiscards subsDiscardMsg + ; let subs = Fits subs_with_docs vDiscards -- Refinement hole fits. See Note [Valid refinement hole fits include ...] - ; (tidy_env, refMsg) <- if refLevel >= Just 0 then + ; (tidy_env, rsubs) <- + if refLevel >= Just 0 + then do { maxRSubs <- maxRefHoleFits <$> getDynFlags -- We can use from just, since we know that Nothing >= _ is False. ; let refLvls = [1..(fromJust refLevel)] @@ -640,14 +634,11 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ possiblyDiscard maxRSubs $ plugin_handled_rsubs rDiscards = pRDisc || any fst refDs ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits - ; return (tidy_env, - ppUnless (null rsubs_with_docs) $ - hang (text "Valid refinement hole fits include") 2 $ - vcat (map (pprHoleFit hfdc) rsubs_with_docs) - $$ ppWhen rDiscards refSubsDiscardMsg) } - else return (tidy_env, empty) + ; return (tidy_env, Fits rsubs_with_docs rDiscards) } + else return (tidy_env, Fits [] False) ; traceTc "findingValidHoleFitsFor }" empty - ; return (tidy_env, vMsg $$ refMsg) } + ; let hole_fits = ValidHoleFits subs rsubs + ; return (tidy_env, hole_fits) } where -- We extract the TcLevel from the constraint. hole_lvl = ctLocLevel ct_loc @@ -688,19 +679,6 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ <*> sortHoleFitsByGraph (sort gblFits) where (lclFits, gblFits) = span hfIsLcl subs - subsDiscardMsg :: SDoc - subsDiscardMsg = - text "(Some hole fits suppressed;" <+> - text "use -fmax-valid-hole-fits=N" <+> - text "or -fno-max-valid-hole-fits)" - - refSubsDiscardMsg :: SDoc - refSubsDiscardMsg = - text "(Some refinement hole fits suppressed;" <+> - text "use -fmax-refinement-hole-fits=N" <+> - text "or -fno-max-refinement-hole-fits)" - - -- Based on the flags, we might possibly discard some or all the -- fits we've found. possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit]) @@ -709,7 +687,7 @@ findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _ -- We don't (as of yet) handle holes in types, only in expressions. -findValidHoleFits env _ _ _ = return (env, empty) +findValidHoleFits env _ _ _ = return (env, noValidHoleFits) -- See Note [Relevant constraints] relevantCts :: Type -> [Ct] -> [Ct] diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot index 8c4bfce546..94d3f51c58 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole.hs-boot @@ -5,6 +5,7 @@ module GHC.Tc.Errors.Hole where import GHC.Types.Var ( Id ) +import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Constraint ( Ct, CtLoc, Hole, Implication ) import GHC.Utils.Outputable ( SDoc ) @@ -18,7 +19,7 @@ import Data.Maybe ( Maybe ) import Data.Int ( Int ) findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Hole - -> TcM (TidyEnv, SDoc) + -> TcM (TidyEnv, ValidHoleFits) tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType -> TcM (Bool, HsWrapper) @@ -30,7 +31,6 @@ tcFilterHoleFits :: Maybe Int -> TypedHole -> (TcType, [TcTyVar]) getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] addHoleFitDocs :: [HoleFit] -> TcM [HoleFit] -data HoleFitDispConfig data HoleFitSortingAlg pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc diff --git a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot index 25d3f81aeb..f27d71b41b 100644 --- a/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot +++ b/compiler/GHC/Tc/Errors/Hole/FitTypes.hs-boot @@ -4,7 +4,27 @@ -- + which needs 'GHC.Tc.Types' module GHC.Tc.Errors.Hole.FitTypes where --- Build ordering -import GHC.Base() +import GHC.Base (Int, Maybe) +import {-# SOURCE #-} GHC.Types.Var (Id) +import GHC.Types.Name (Name) +import GHC.Types.Name.Reader (GlobalRdrElt) +import GHC.Tc.Utils.TcType (TcType) +import GHC.Hs.Doc (HsDocString) +import GHC.Utils.Outputable (SDoc) + +data HoleFitCandidate + = IdHFCand Id + | NameHFCand Name + | GreHFCand GlobalRdrElt data HoleFitPlugin +data HoleFit = + HoleFit { hfId :: Id + , hfCand :: HoleFitCandidate + , hfType :: TcType + , hfRefLvl :: Int + , hfWrap :: [TcType] + , hfMatches :: [TcType] + , hfDoc :: Maybe HsDocString + } + | RawHoleFit SDoc diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index eb7a03febb..0fc6407da4 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1,59 +1,104 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -module GHC.Tc.Errors.Ppr ( pprTypeDoesNotHaveFixedRuntimeRep ) +{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage + +module GHC.Tc.Errors.Ppr + ( pprTypeDoesNotHaveFixedRuntimeRep + , pprScopeError + ) where import GHC.Prelude -import Data.Maybe (isJust) - import GHC.Builtin.Names -import GHC.Core.Class (Class(..)) -import GHC.Core.Coercion (pprCoAxBranchUser) + +import GHC.Core.Coercion +import GHC.Core.Unify ( tcMatchTys ) +import GHC.Core.TyCon +import GHC.Core.Class +import GHC.Core.DataCon import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch) -import GHC.Core.DataCon (DataCon) +import GHC.Core.ConLike import GHC.Core.FamInstEnv (famInstAxiom) import GHC.Core.InstEnv -import GHC.Core.TyCon (isNewTyCon) -import GHC.Core.TyCo.Ppr (pprKind, pprParendType, pprType, - pprWithExplicitKindsWhen, pprTheta, pprClassPred, pprTypeApp, - pprSourceTyCon) +import GHC.Core.TyCo.Rep (Type(..)) +import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen, + pprSourceTyCon, pprTyVars, pprWithTYPE) +import GHC.Core.Predicate import GHC.Core.Type -import GHC.Data.Bag + +import GHC.Driver.Flags + +import GHC.Hs + import GHC.Tc.Errors.Types +import GHC.Tc.Types.Constraint +import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc) +import GHC.Tc.Types.Origin import GHC.Tc.Types.Rank (Rank(..)) -import GHC.Tc.Utils.TcType (TcType, tcSplitForAllTyVars, mkClassPred) -import GHC.Types.Basic (UnboxedTupleOrSum(..), unboxedTupleOrSumExtension) +import GHC.Tc.Utils.TcType import GHC.Types.Error -import GHC.Types.FieldLabel (FieldLabelString, flIsOverloaded, flSelector) -import GHC.Types.Id (isRecordSelector) +import GHC.Types.FieldLabel (flIsOverloaded) +import GHC.Types.Hint.Ppr () -- Outputable GhcHint +import GHC.Types.Basic +import GHC.Types.Id import GHC.Types.Name -import GHC.Types.Name.Reader (GreName(..), pprNameProvenance) -import GHC.Types.SrcLoc (GenLocated(..), unLoc) +import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance + , RdrName, rdrNameOcc, greMangledName ) +import GHC.Types.Name.Set +import GHC.Types.SrcLoc import GHC.Types.TyThing -import GHC.Types.Var.Env (emptyTidyEnv) -import GHC.Types.Var.Set (pprVarSet, pluralVarSet) -import GHC.Driver.Flags -import GHC.Hs -import GHC.Utils.Misc (capitalise) -import GHC.Utils.Outputable +import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) +import GHC.Types.Var +import GHC.Types.Var.Set +import GHC.Types.Var.Env + import GHC.Unit.State (pprWithUnitState, UnitState) +import GHC.Unit.Module + +import GHC.Data.Bag +import GHC.Data.FastString +import GHC.Data.List.SetOps ( nubOrdBy ) +import GHC.Data.Maybe +import GHC.Utils.Misc +import GHC.Utils.Outputable +import GHC.Utils.Panic + import qualified GHC.LanguageExtensions as LangExt + +import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE +import Data.Function (on) +import Data.List ( groupBy, sortBy, tails + , partition, unfoldr ) +import Data.Ord ( comparing ) instance Diagnostic TcRnMessage where diagnosticMessage = \case TcRnUnknownMessage m -> diagnosticMessage m - TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) - -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] TcRnMessageWithInfo unit_state msg_with_info -> case msg_with_info of TcRnMessageDetailed err_info msg -> messageWithInfoDiagnosticMessage unit_state err_info (diagnosticMessage msg) + TcRnSolverReport msgs _ _ + -> mkDecorated $ + map pprReportWithCtxt msgs + TcRnRedundantConstraints redundants (info, show_info) + -> mkSimpleDecorated $ + text "Redundant constraint" <> plural redundants <> colon + <+> pprEvVarTheta redundants + $$ if show_info then text "In" <+> ppr info else empty + TcRnInaccessibleCode implic contras + -> mkSimpleDecorated $ + hang (text "Inaccessible code in") + 2 (ppr (ic_info implic)) + $$ vcat (map pprReportWithCtxt (NE.toList contras)) + TcRnTypeDoesNotHaveFixedRuntimeRep ty prov (ErrInfo extra supplementary) + -> mkDecorated [pprTypeDoesNotHaveFixedRuntimeRep ty prov, extra, supplementary] TcRnImplicitLift id_or_name ErrInfo{..} -> mkDecorated $ ( text "The variable" <+> quotes (ppr id_or_name) <+> @@ -546,15 +591,45 @@ instance Diagnostic TcRnMessage where = text "Illegal term-level use of the" <+> what ns = nameNameSpace name what = pprNameSpace ns <+> quotes (ppr name) + TcRnNotInScope err name imp_errs _ + -> mkSimpleDecorated $ + pprScopeError name err $$ vcat (map ppr imp_errs) + TcRnUntickedPromotedConstructor name + -> mkSimpleDecorated $ + text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot + TcRnIllegalBuiltinSyntax what rdr_name + -> mkSimpleDecorated $ + hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr_name] + TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty + -> mkSimpleDecorated $ + hang (hsep $ [ text "Defaulting" ] + ++ + (case tidy_tv of + Nothing -> [] + Just tv -> [text "the type variable" + , quotes (ppr tv)]) + ++ + [ text "to type" + , quotes (ppr default_ty) + , text "in the following constraint" <> plural tidy_wanteds ]) + 2 + (pprWithArising tidy_wanteds) + diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m - TcRnTypeDoesNotHaveFixedRuntimeRep{} - -> ErrorWithoutFlag TcRnMessageWithInfo _ msg_with_info -> case msg_with_info of TcRnMessageDetailed _ m -> diagnosticReason m + TcRnSolverReport _ reason _ + -> reason -- Error, or a Warning if we are deferring type errors + TcRnRedundantConstraints {} + -> WarningWithFlag Opt_WarnRedundantConstraints + TcRnInaccessibleCode {} + -> WarningWithFlag Opt_WarnInaccessibleCode + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> ErrorWithoutFlag TcRnImplicitLift{} -> WarningWithFlag Opt_WarnImplicitLift TcRnUnusedPatternBinds{} @@ -768,15 +843,29 @@ instance Diagnostic TcRnMessage where -> WarningWithFlag Opt_WarnGADTMonoLocalBinds TcRnIncorrectNameSpace {} -> ErrorWithoutFlag + TcRnNotInScope {} + -> ErrorWithoutFlag + TcRnUntickedPromotedConstructor {} + -> WarningWithFlag Opt_WarnUntickedPromotedConstructors + TcRnIllegalBuiltinSyntax {} + -> ErrorWithoutFlag + TcRnWarnDefaulting {} + -> WarningWithFlag Opt_WarnTypeDefaults diagnosticHints = \case TcRnUnknownMessage m -> diagnosticHints m - TcRnTypeDoesNotHaveFixedRuntimeRep{} - -> noHints TcRnMessageWithInfo _ msg_with_info -> case msg_with_info of TcRnMessageDetailed _ m -> diagnosticHints m + TcRnSolverReport _ _ hints + -> hints + TcRnRedundantConstraints{} + -> noHints + TcRnInaccessibleCode{} + -> noHints + TcRnTypeDoesNotHaveFixedRuntimeRep{} + -> noHints TcRnImplicitLift{} -> noHints TcRnUnusedPatternBinds{} @@ -987,6 +1076,14 @@ instance Diagnostic TcRnMessage where -> [SuggestAppropriateTHTick $ nameNameSpace nm] | otherwise -> noHints + TcRnNotInScope err _ _ hints + -> scopeErrorHints err ++ hints + TcRnUntickedPromotedConstructor name + -> [SuggestAddTick name] + TcRnIllegalBuiltinSyntax {} + -> noHints + TcRnWarnDefaulting {} + -> noHints deriveInstanceErrReasonHints :: Class -> UsingGeneralizedNewtypeDeriving @@ -1334,3 +1431,1283 @@ derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \cas ppr2 = derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving False that in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald (ppr1 $$ text " or" $$ ppr2) + +{- ********************************************************************* +* * + Outputable ReportErrCtxt (for debugging) +* * +**********************************************************************-} + +instance Outputable ReportErrCtxt where + ppr (CEC { cec_binds = bvar + , cec_defer_type_errors = dte + , cec_expr_holes = eh + , cec_type_holes = th + , cec_out_of_scope_holes = osh + , cec_warn_redundant = wr + , cec_expand_syns = es + , cec_suppress = sup }) + = text "CEC" <+> braces (vcat + [ text "cec_binds" <+> equals <+> ppr bvar + , text "cec_defer_type_errors" <+> equals <+> ppr dte + , text "cec_expr_holes" <+> equals <+> ppr eh + , text "cec_type_holes" <+> equals <+> ppr th + , text "cec_out_of_scope_holes" <+> equals <+> ppr osh + , text "cec_warn_redundant" <+> equals <+> ppr wr + , text "cec_expand_syns" <+> equals <+> ppr es + , text "cec_suppress" <+> equals <+> ppr sup ]) + +{- ********************************************************************* +* * + Outputting TcReportMsg errors +* * +**********************************************************************-} + +-- | Pretty-print a 'ReportWithCtxt', containing a 'TcReportMsg' +-- with its enclosing 'ReportErrCtxt'. +pprReportWithCtxt :: ReportWithCtxt -> SDoc +pprReportWithCtxt (ReportWithCtxt { reportContext = ctxt, reportContent = msg }) + = pprTcReportMsg ctxt msg + +-- | Pretty-print a 'TcReportMsg', with its enclosing 'ReportErrCtxt'. +pprTcReportMsg :: ReportErrCtxt -> TcReportMsg -> SDoc +pprTcReportMsg ctxt (TcReportWithInfo msg (info :| infos)) = + vcat + ( pprTcReportMsg ctxt msg + : pprTcReportInfo ctxt info + : map (pprTcReportInfo ctxt) infos ) +pprTcReportMsg _ (BadTelescope telescope skols) = + hang (text "These kind and type variables:" <+> ppr telescope $$ + text "are out of dependency order. Perhaps try this ordering:") + 2 (pprTyVars sorted_tvs) + where + sorted_tvs = scopedSort skols +pprTcReportMsg _ (UserTypeError ty) = + pprUserTypeErrorTy ty +pprTcReportMsg ctxt (ReportHoleError hole err) = + pprHoleError ctxt hole err +pprTcReportMsg _ (CannotUnifyWithPolytype ct tv1 ty2) = + vcat [ (if isSkolemTyVar tv1 + then text "Cannot equate type variable" + else text "Cannot instantiate unification variable") + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel +pprTcReportMsg _ + (Mismatch { mismatch_ea = add_ea + , mismatch_ct = ct + , mismatch_ty1 = ty1 + , mismatch_ty2 = ty2 }) + = addArising (ctOrigin ct) msg + where + msg + | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) || + (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) || + (isLiftedLevity ty1 && isUnliftedLevity ty2) || + (isLiftedLevity ty2 && isUnliftedLevity ty1) + = text "Couldn't match a lifted type with an unlifted type" + + | isAtomicTy ty1 || isAtomicTy ty2 + = -- Print with quotes + sep [ text herald1 <+> quotes (ppr ty1) + , nest padding $ + text herald2 <+> quotes (ppr ty2) ] + + | otherwise + = -- Print with vertical layout + vcat [ text herald1 <> colon <+> ppr ty1 + , nest padding $ + text herald2 <> colon <+> ppr ty2 ] + + herald1 = conc [ "Couldn't match" + , if is_repr then "representation of" else "" + , if add_ea then "expected" else "" + , what ] + herald2 = conc [ "with" + , if is_repr then "that of" else "" + , if add_ea then ("actual " ++ what) else "" ] + + padding = length herald1 - length herald2 + + is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False } + + what = levelString (ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel) + + conc :: [String] -> String + conc = foldr1 add_space + + add_space :: String -> String -> String + add_space s1 s2 | null s1 = s2 + | null s2 = s1 + | otherwise = s1 ++ (' ' : s2) +pprTcReportMsg _ + (KindMismatch { kmismatch_what = thing + , kmismatch_expected = exp + , kmismatch_actual = act }) + = hang (text "Expected" <+> kind_desc <> comma) + 2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+> + quotes (ppr act)) + where + kind_desc | tcIsConstraintKind exp = text "a constraint" + | Just arg <- kindRep_maybe exp -- TYPE t0 + , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case + True -> text "kind" <+> quotes (ppr exp) + False -> text "a type" + | otherwise = text "kind" <+> quotes (ppr exp) + + +pprTcReportMsg ctxt + (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds + , teq_mismatch_ct = ct + , teq_mismatch_ty1 = ty1 + , teq_mismatch_ty2 = ty2 + , teq_mismatch_expected = exp + , teq_mismatch_actual = act + , teq_mismatch_what = mb_thing }) + = addArising orig $ pprWithExplicitKindsWhen ppr_explicit_kinds msg + where + msg + | isUnliftedTypeKind act, isLiftedTypeKind exp + = sep [ text "Expecting a lifted type, but" + , thing_msg mb_thing (text "an") (text "unlifted") ] + | isLiftedTypeKind act, isUnliftedTypeKind exp + = sep [ text "Expecting an unlifted type, but" + , thing_msg mb_thing (text "a") (text "lifted") ] + | tcIsLiftedTypeKind exp + = maybe_num_args_msg $$ + sep [ text "Expected a type, but" + , case mb_thing of + Nothing -> text "found something with kind" + Just thing -> quotes (ppr thing) <+> text "has kind" + , quotes (pprWithTYPE act) ] + | Just nargs_msg <- num_args_msg + , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig + = nargs_msg $$ pprTcReportMsg ctxt ea_msg + | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $ + ea_looks_same ty1 ty2 exp act + , Right ea_msg <- mk_ea_msg ctxt (Just ct) level orig + = pprTcReportMsg ctxt ea_msg + -- The mismatched types are /inside/ exp and act + | let mismatch_err = Mismatch False ct ty1 ty2 + errs = case mk_ea_msg ctxt Nothing level orig of + Left ea_info -> [ mkTcReportWithInfo mismatch_err ea_info ] + Right ea_err -> [ mismatch_err, ea_err ] + = vcat $ map (pprTcReportMsg ctxt) errs + + ct_loc = ctLoc ct + orig = ctOrigin ct + level = ctLocTypeOrKind_maybe ct_loc `orElse` TypeLevel + + thing_msg (Just thing) _ levity = quotes (ppr thing) <+> text "is" <+> levity + thing_msg Nothing an levity = text "got" <+> an <+> levity <+> text "type" + + num_args_msg = case level of + KindLevel + | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act) + -- if one is a meta-tyvar, then it's possible that the user + -- has asked for something impredicative, and we couldn't unify. + -- Don't bother with counting arguments. + -> let n_act = count_args act + n_exp = count_args exp in + case n_act - n_exp of + n | n > 0 -- we don't know how many args there are, so don't + -- recommend removing args that aren't + , Just thing <- mb_thing + -> Just $ pprTcReportMsg ctxt (ExpectingMoreArguments n thing) + _ -> Nothing + + _ -> Nothing + + maybe_num_args_msg = num_args_msg `orElse` empty + + count_args ty = count isVisibleBinder $ fst $ splitPiTys ty +pprTcReportMsg _ (FixedRuntimeRepError origs_and_tys) = + let + -- Assemble the error message: pair up each origin with the corresponding type, e.g. + -- • FixedRuntimeRep origin msg 1 ... + -- a :: TYPE r1 + -- • FixedRuntimeRep origin msg 2 ... + -- b :: TYPE r2 + combine_origin_ty :: FRROrigin -> Type -> SDoc + combine_origin_ty frr_orig ty = + -- Add bullet points if there is more than one error. + (if length origs_and_tys > 1 then (bullet <+>) else id) $ + vcat [pprFRROrigin frr_orig <> colon + ,nest 2 $ ppr ty <+> dcolon <+> pprWithTYPE (typeKind ty)] + in + vcat $ map (uncurry combine_origin_ty) origs_and_tys +pprTcReportMsg _ (SkolemEscape ct implic esc_skols) = + let + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + in + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr (ic_info implic) + , nest 2 $ text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ] ] + where + what = text $ levelString $ + ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel +pprTcReportMsg _ (UntouchableVariable tv implic) + | Implic { ic_given = given, ic_info = skol_info } <- implic + = sep [ quotes (ppr tv) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ] +pprTcReportMsg _ (BlockedEquality ct) = + vcat [ hang (text "Cannot use equality for substitution:") + 2 (ppr (ctPred ct)) + , text "Doing so would be ill-kinded." ] +pprTcReportMsg _ (ExpectingMoreArguments n thing) = + text "Expecting" <+> speakN (abs n) <+> + more <+> quotes (ppr thing) + where + more + | n == 1 = text "more argument to" + | otherwise = text "more arguments to" -- n > 1 +pprTcReportMsg ctxt (UnboundImplicitParams (ct :| cts)) = + let givens = getUserGivens ctxt + in if null givens + then addArising (ctOrigin ct) $ + sep [ text "Unbound implicit parameter" <> plural preds + , nest 2 (pprParendTheta preds) ] + else pprTcReportMsg ctxt (CouldNotDeduce givens (ct :| cts) Nothing) + where + preds = map ctPred (ct : cts) +pprTcReportMsg ctxt (CouldNotDeduce useful_givens (ct :| others) mb_extra) + = main_msg $$ + case supplementary of + Left infos + -> vcat (map (pprTcReportInfo ctxt) infos) + Right other_msg + -> pprTcReportMsg ctxt other_msg + where + main_msg + | null useful_givens + = addArising (ctOrigin ct) no_instance_msg + | otherwise + = vcat [ addArising (ctOrigin ct) no_deduce_msg + , vcat (pp_givens useful_givens) ] + supplementary = case mb_extra of + Nothing + -> Left [] + Just (CND_Extra level ty1 ty2) + -> mk_supplementary_ea_msg ctxt level ty1 ty2 orig + (wanted, wanteds) = (ctPred ct, map ctPred others) + orig = ctOrigin ct + no_instance_msg + | null others + , Just (tc, _) <- splitTyConApp_maybe wanted + , isClassTyCon tc + -- Don't say "no instance" for a constraint such as "c" for a type variable c. + = text "No instance for" <+> pprParendType wanted + | otherwise + = text "Could not solve:" <+> pprTheta wanteds + no_deduce_msg + | null others + = text "Could not deduce" <+> pprParendType wanted + | otherwise + = text "Could not deduce:" <+> pprTheta wanteds +pprTcReportMsg ctxt (AmbiguityPreventsSolvingCt ct ambigs) = + pprTcReportInfo ctxt (Ambiguity True ambigs) <+> + pprArising (ctOrigin ct) $$ + text "prevents the constraint" <+> quotes (pprParendType $ ctPred ct) + <+> text "from being solved." +pprTcReportMsg ctxt@(CEC {cec_encl = implics}) + (CannotResolveInstance ct unifiers candidates imp_errs suggs binds) + = + vcat + [ pprTcReportMsg ctxt no_inst_msg + , nest 2 extra_note + , mb_patsyn_prov `orElse` empty + , ppWhen (has_ambigs && not (null unifiers && null useful_givens)) + (vcat [ ppUnless lead_with_ambig $ + pprTcReportInfo ctxt (Ambiguity False (ambig_kvs, ambig_tvs)) + , pprRelevantBindings binds + , potential_msg ]) + , ppWhen (isNothing mb_patsyn_prov) $ + -- Don't suggest fixes for the provided context of a pattern + -- synonym; the right fix is to bind more in the pattern + show_fixes (ctxtFixes has_ambigs pred implics + ++ drv_fixes) + , ppWhen (not (null candidates)) + (hang (text "There are instances for similar types:") + 2 (vcat (map ppr candidates))) + -- See Note [Report candidate instances] + , vcat $ map ppr imp_errs + , vcat $ map ppr suggs ] + where + orig = ctOrigin ct + pred = ctPred ct + (clas, tys) = getClassPredTys pred + -- See Note [Highlighting ambiguous type variables] + (ambig_kvs, ambig_tvs) = ambigTkvsOfCt ct + ambigs = ambig_kvs ++ ambig_tvs + has_ambigs = not (null ambigs) + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + -- useful_givens are the enclosing implications with non-empty givens, + -- modulo the horrid discardProvCtxtGivens + lead_with_ambig = not (null ambigs) + && not (any isRuntimeUnkSkol ambigs) + && not (null unifiers) + && null useful_givens + + no_inst_msg :: TcReportMsg + no_inst_msg + | lead_with_ambig + = AmbiguityPreventsSolvingCt ct (ambig_kvs, ambig_tvs) + | otherwise + = CouldNotDeduce useful_givens (ct :| []) Nothing + + -- Report "potential instances" only when the constraint arises + -- directly from the user's use of an overloaded function + want_potential (TypeEqOrigin {}) = False + want_potential _ = True + + potential_msg + = ppWhen (not (null unifiers) && want_potential orig) $ + potential_hdr $$ + potentialInstancesErrMsg (PotentialInstances { matches = [], unifiers }) + + potential_hdr + = ppWhen lead_with_ambig $ + text "Probable fix: use a type annotation to specify what" + <+> pprQuotedList ambig_tvs <+> text "should be." + + mb_patsyn_prov :: Maybe SDoc + mb_patsyn_prov + | not lead_with_ambig + , ProvCtxtOrigin PSB{ psb_def = L _ pat } <- orig + = Just (vcat [ text "In other words, a successful match on the pattern" + , nest 2 $ ppr pat + , text "does not provide the constraint" <+> pprParendType pred ]) + | otherwise = Nothing + + extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys) + = text "(maybe you haven't applied a function to enough arguments?)" + | className clas == typeableClassName -- Avoid mysterious "No instance for (Typeable T) + , [_,ty] <- tys -- Look for (Typeable (k->*) (T k)) + , Just (tc,_) <- tcSplitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) + = hang (text "GHC can't yet do polykinded") + 2 (text "Typeable" <+> + parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty))) + | otherwise + = empty + + drv_fixes = case orig of + DerivClauseOrigin -> [drv_fix False] + StandAloneDerivOrigin -> [drv_fix True] + DerivOriginDC _ _ standalone -> [drv_fix standalone] + DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone] + _ -> [] + + drv_fix standalone_wildcard + | standalone_wildcard + = text "fill in the wildcard constraint yourself" + | otherwise + = hang (text "use a standalone 'deriving instance' declaration,") + 2 (text "so you can specify the instance context yourself") + +pprTcReportMsg (CEC {cec_encl = implics}) (OverlappingInstances ct matches unifiers) = + vcat + [ addArising orig $ + (text "Overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , ppUnless (null matching_givens) $ + sep [text "Matching givens (or their superclasses):" + , nest 2 (vcat matching_givens)] + , potentialInstancesErrMsg + (PotentialInstances { matches, unifiers }) + , ppWhen (null matching_givens && isSingleton matches && null unifiers) $ + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ text "There exists a (perhaps superclass) match:" + , nest 2 (vcat (pp_givens useful_givens))] + + , ppWhen (isSingleton matches) $ + parens (vcat [ ppUnless (null tyCoVars) $ + text "The choice depends on the instantiation of" <+> + quotes (pprWithCommas ppr tyCoVars) + , ppUnless (null famTyCons) $ + if (null tyCoVars) + then + text "The choice depends on the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + else + text "and the result of evaluating" <+> + quotes (pprWithCommas ppr famTyCons) + , ppWhen (null (matching_givens)) $ + vcat [ text "To pick the first instance above, use IncoherentInstances" + , text "when compiling the other instance declarations"] + ])] + where + orig = ctOrigin ct + pred = ctPred ct + (clas, tys) = getClassPredTys pred + tyCoVars = tyCoVarsOfTypesList tys + famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys + useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics) + matching_givens = mapMaybe matchable useful_givens + matchable implic@(Implic { ic_given = evvars, ic_info = skol_info }) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> + ppr (getLclEnvLoc (ic_env implic)) ]) + where ev_vars_matching = [ pred + | ev_var <- evvars + , let pred = evVarPred ev_var + , any can_match (pred : transSuperClasses pred) ] + can_match pred + = case getClassPredTys_maybe pred of + Just (clas', tys') -> clas' == clas + && isJust (tcMatchTys tys tys') + Nothing -> False +pprTcReportMsg _ (UnsafeOverlap ct matches unsafe_overlapped) = + vcat [ addArising orig (text "Unsafe overlapping instances for" + <+> pprType (mkClassPred clas tys)) + , sep [text "The matching instance is:", + nest 2 (pprInstance $ head matches)] + , vcat [ text "It is compiled in a Safe module and as such can only" + , text "overlap instances from the same module, however it" + , text "overlaps the following instances from different" <+> + text "modules:" + , nest 2 (vcat [pprInstances $ unsafe_overlapped]) + ] + ] + where + orig = ctOrigin ct + pred = ctPred ct + (clas, tys) = getClassPredTys pred + +{- ********************************************************************* +* * + Displaying potential instances +* * +**********************************************************************-} + +-- | Directly display the given matching and unifying instances, +-- with a header for each: `Matching instances`/`Potentially matching instances`. +pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc +pprPotentialInstances ppr_inst (PotentialInstances { matches, unifiers }) = + vcat + [ ppWhen (not $ null matches) $ + text "Matching instance" <> plural matches <> colon $$ + nest 2 (vcat (map ppr_inst matches)) + , ppWhen (not $ null unifiers) $ + (text "Potentially matching instance" <> plural unifiers <> colon) $$ + nest 2 (vcat (map ppr_inst unifiers)) + ] + +-- | Display a summary of available instances, omitting those involving +-- out-of-scope types, in order to explain why we couldn't solve a particular +-- constraint, e.g. due to instance overlap or out-of-scope types. +-- +-- To directly display a collection of matching/unifying instances, +-- use 'pprPotentialInstances'. +potentialInstancesErrMsg :: PotentialInstances -> SDoc +-- See Note [Displaying potential instances] +potentialInstancesErrMsg potentials = + sdocOption sdocPrintPotentialInstances $ \print_insts -> + getPprStyle $ \sty -> + potentials_msg_with_options potentials print_insts sty + +-- | Display a summary of available instances, omitting out-of-scope ones. +-- +-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing +-- options. +potentials_msg_with_options :: PotentialInstances + -> Bool -- ^ Whether to print /all/ potential instances + -> PprStyle + -> SDoc +potentials_msg_with_options + (PotentialInstances { matches, unifiers }) + show_all_potentials sty + | null matches && null unifiers + = empty + + | null show_these_matches && null show_these_unifiers + = vcat [ not_in_scope_msg empty + , flag_hint ] + + | otherwise + = vcat [ pprPotentialInstances + pprInstance -- print instance + location info + (PotentialInstances + { matches = show_these_matches + , unifiers = show_these_unifiers }) + , overlapping_but_not_more_specific_msg sorted_matches + , nest 2 $ vcat + [ ppWhen (n_in_scope_hidden > 0) $ + text "...plus" + <+> speakNOf n_in_scope_hidden (text "other") + , ppWhen (not_in_scopes > 0) $ + not_in_scope_msg (text "...plus") + , flag_hint ] ] + where + n_show_matches, n_show_unifiers :: Int + n_show_matches = 3 + n_show_unifiers = 2 + + (in_scope_matches, not_in_scope_matches) = partition inst_in_scope matches + (in_scope_unifiers, not_in_scope_unifiers) = partition inst_in_scope unifiers + sorted_matches = sortBy fuzzyClsInstCmp in_scope_matches + sorted_unifiers = sortBy fuzzyClsInstCmp in_scope_unifiers + (show_these_matches, show_these_unifiers) + | show_all_potentials = (sorted_matches, sorted_unifiers) + | otherwise = (take n_show_matches sorted_matches + ,take n_show_unifiers sorted_unifiers) + n_in_scope_hidden + = length sorted_matches + length sorted_unifiers + - length show_these_matches - length show_these_unifiers + + -- "in scope" means that all the type constructors + -- are lexically in scope; these instances are likely + -- to be more useful + inst_in_scope :: ClsInst -> Bool + inst_in_scope cls_inst = nameSetAll name_in_scope $ + orphNamesOfTypes (is_tys cls_inst) + + name_in_scope name + | pretendNameIsInScope name + = True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names + | Just mod <- nameModule_maybe name + = qual_in_scope (qualName sty mod (nameOccName name)) + | otherwise + = True + + qual_in_scope :: QualifyName -> Bool + qual_in_scope NameUnqual = True + qual_in_scope (NameQual {}) = True + qual_in_scope _ = False + + not_in_scopes :: Int + not_in_scopes = length not_in_scope_matches + length not_in_scope_unifiers + + not_in_scope_msg herald = + hang (herald <+> speakNOf not_in_scopes (text "instance") + <+> text "involving out-of-scope types") + 2 (ppWhen show_all_potentials $ + pprPotentialInstances + pprInstanceHdr -- only print the header, not the instance location info + (PotentialInstances + { matches = not_in_scope_matches + , unifiers = not_in_scope_unifiers + })) + + flag_hint = ppUnless (show_all_potentials + || (equalLength show_these_matches matches + && equalLength show_these_unifiers unifiers)) $ + text "(use -fprint-potential-instances to see them all)" + +-- | Compute a message informing the user of any instances that are overlapped +-- but were not discarded because the instance overlapping them wasn't +-- strictly more specific. +overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc +overlapping_but_not_more_specific_msg insts + -- Only print one example of "overlapping but not strictly more specific", + -- to avoid information overload. + | overlap : _ <- overlapping_but_not_more_specific + = overlap_header $$ ppr_overlapping overlap + | otherwise + = empty + where + overlap_header :: SDoc + overlap_header + | [_] <- overlapping_but_not_more_specific + = text "An overlapping instance can only be chosen when it is strictly more specific." + | otherwise + = text "Overlapping instances can only be chosen when they are strictly more specific." + overlapping_but_not_more_specific :: [(ClsInst, ClsInst)] + overlapping_but_not_more_specific + = nubOrdBy (comparing (is_dfun . fst)) + [ (overlapper, overlappee) + | these <- groupBy ((==) `on` is_cls_nm) insts + -- Take all pairs of distinct instances... + , one:others <- tails these -- if `these = [inst_1, inst_2, ...]` + , other <- others -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j` + -- ... such that one instance in the pair overlaps the other... + , let mb_overlapping + | hasOverlappingFlag (overlapMode $ is_flag one) + || hasOverlappableFlag (overlapMode $ is_flag other) + = [(one, other)] + | hasOverlappingFlag (overlapMode $ is_flag other) + || hasOverlappableFlag (overlapMode $ is_flag one) + = [(other, one)] + | otherwise + = [] + , (overlapper, overlappee) <- mb_overlapping + -- ... but the overlapper is not more specific than the overlappee. + , not (overlapper `more_specific_than` overlappee) + ] + more_specific_than :: ClsInst -> ClsInst -> Bool + is1 `more_specific_than` is2 + = isJust (tcMatchTys (is_tys is1) (is_tys is2)) + ppr_overlapping :: (ClsInst, ClsInst) -> SDoc + ppr_overlapping (overlapper, overlappee) + = text "The first instance that follows overlaps the second, but is not more specific than it:" + $$ nest 2 (vcat $ map pprInstanceHdr [overlapper, overlappee]) + +{- Note [Displaying potential instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When showing a list of instances for + - overlapping instances (show ones that match) + - no such instance (show ones that could match) +we want to give it a bit of structure. Here's the plan + +* Say that an instance is "in scope" if all of the + type constructors it mentions are lexically in scope. + These are the ones most likely to be useful to the programmer. + +* Show at most n_show in-scope instances, + and summarise the rest ("plus N others") + +* Summarise the not-in-scope instances ("plus 4 not in scope") + +* Add the flag -fshow-potential-instances which replaces the + summary with the full list +-} + +{- ********************************************************************* +* * + Outputting TcReportInfo +* * +**********************************************************************-} + +-- | Pretty-print an informational message, to accompany a 'TcReportMsg'. +pprTcReportInfo :: ReportErrCtxt -> TcReportInfo -> SDoc +pprTcReportInfo _ (Ambiguity prepend_msg (ambig_kvs, ambig_tvs)) = msg + where + + msg | any isRuntimeUnkSkol ambig_kvs -- See Note [Runtime skolems] + || any isRuntimeUnkSkol ambig_tvs + = vcat [ text "Cannot resolve unknown runtime type" + <> plural ambig_tvs <+> pprQuotedList ambig_tvs + , text "Use :print or :force to determine these types"] + + | not (null ambig_tvs) + = pp_ambig (text "type") ambig_tvs + + | otherwise + = pp_ambig (text "kind") ambig_kvs + + pp_ambig what tkvs + | prepend_msg -- "Ambiguous type variable 't0'" + = text "Ambiguous" <+> what <+> text "variable" + <> plural tkvs <+> pprQuotedList tkvs + + | otherwise -- "The type variable 't0' is ambiguous" + = text "The" <+> what <+> text "variable" <> plural tkvs + <+> pprQuotedList tkvs <+> isOrAre tkvs <+> text "ambiguous" +pprTcReportInfo ctxt (TyVarInfo tv) = + case tcTyVarDetails tv of + SkolemTv {} -> pprSkols ctxt [tv] + RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem" + MetaTv {} -> empty +pprTcReportInfo _ (NonInjectiveTyFam tc) = + text "NB:" <+> quotes (ppr tc) + <+> text "is a non-injective type family" +pprTcReportInfo _ (ReportCoercibleMsg msg) = + pprCoercibleMsg msg +pprTcReportInfo _ (ExpectedActual { ea_expected = exp, ea_actual = act }) = + vcat + [ text "Expected:" <+> ppr exp + , text " Actual:" <+> ppr act ] +pprTcReportInfo _ + (ExpectedActualAfterTySynExpansion + { ea_expanded_expected = exp + , ea_expanded_actual = act } ) + = vcat + [ text "Type synonyms expanded:" + , text "Expected type:" <+> ppr exp + , text " Actual type:" <+> ppr act ] +pprTcReportInfo ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) = + sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions -> + if printExplicitCoercions + || not (cty1 `pickyEqType` cty2) + then vcat [ hang (text "When matching" <+> sub_whats) + 2 (vcat [ ppr cty1 <+> dcolon <+> + ppr (tcTypeKind cty1) + , ppr cty2 <+> dcolon <+> + ppr (tcTypeKind cty2) ]) + , supplementary ] + else text "When matching the kind of" <+> quotes (ppr cty1) + where + sub_t_or_k = mb_sub_t_or_k `orElse` TypeLevel + sub_whats = text (levelString sub_t_or_k) <> char 's' + supplementary = + case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of + Left infos -> vcat $ map (pprTcReportInfo ctxt) infos + Right msg -> pprTcReportMsg ctxt msg +pprTcReportInfo _ (SameOcc same_pkg n1 n2) = + text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2) + where + ppr_from same_pkg nm + | isGoodSrcSpan loc + = hang (quotes (ppr nm) <+> text "is defined at") + 2 (ppr loc) + | otherwise -- Imported things have an UnhelpfulSrcSpan + = hang (quotes (ppr nm)) + 2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod)) + , ppUnless (same_pkg || pkg == mainUnit) $ + nest 4 $ text "in package" <+> quotes (ppr pkg) ]) + where + pkg = moduleUnit mod + mod = nameModule nm + loc = nameSrcSpan nm +pprTcReportInfo ctxt (OccursCheckInterestingTyVars (tv :| tvs)) = + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + (tv:tvs)) + where + tyvar_binding tyvar = ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar) + +pprCoercibleMsg :: CoercibleMsg -> SDoc +pprCoercibleMsg (UnknownRoles ty) = + hang (text "NB: We cannot know what roles the parameters to" <+> + quotes (ppr ty) <+> text "have;") + 2 (text "we must assume that the role is nominal") +pprCoercibleMsg (TyConIsAbstract tc) = + hsep [ text "NB: The type constructor" + , quotes (pprSourceTyCon tc) + , text "is abstract" ] +pprCoercibleMsg (OutOfScopeNewtypeConstructor tc dc) = + hang (text "The data constructor" <+> quotes (ppr $ dataConName dc)) + 2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc) + , text "is not in scope" ]) + +{- ********************************************************************* +* * + Outputting HoleError messages +* * +**********************************************************************-} + +pprHoleError :: ReportErrCtxt -> Hole -> HoleError -> SDoc +pprHoleError _ (Hole { hole_ty, hole_occ = occ }) (OutOfScopeHole imp_errs) + = out_of_scope_msg $$ vcat (map ppr imp_errs) + where + herald | isDataOcc occ = text "Data constructor not in scope:" + | otherwise = text "Variable not in scope:" + out_of_scope_msg -- Print v :: ty only if the type has structure + | boring_type = hang herald 2 (ppr occ) + | otherwise = hang herald 2 (pp_occ_with_type occ hole_ty) + boring_type = isTyVarTy hole_ty +pprHoleError ctxt (Hole { hole_ty, hole_occ }) (HoleError sort) = + vcat [ hole_msg + , tyvars_msg + , case sort of { ExprHole {} -> expr_hole_hint; _ -> type_hole_hint } ] + + where + + hole_msg = case sort of + ExprHole {} -> + hang (text "Found hole:") + 2 (pp_occ_with_type hole_occ hole_ty) + TypeHole -> + hang (text "Found type wildcard" <+> quotes (ppr hole_occ)) + 2 (text "standing for" <+> quotes pp_hole_type_with_kind) + ConstraintHole -> + hang (text "Found extra-constraints wildcard standing for") + 2 (quotes $ pprType hole_ty) -- always kind constraint + + hole_kind = tcTypeKind hole_ty + + pp_hole_type_with_kind + | isLiftedTypeKind hole_kind + || isCoVarType hole_ty -- Don't print the kind of unlifted + -- equalities (#15039) + = pprType hole_ty + | otherwise + = pprType hole_ty <+> dcolon <+> pprKind hole_kind + + tyvars = tyCoVarsOfTypeList hole_ty + tyvars_msg = ppUnless (null tyvars) $ + text "Where:" <+> (vcat (map loc_msg other_tvs) + $$ pprSkols ctxt skol_tvs) + where + (skol_tvs, other_tvs) = partition is_skol tyvars + is_skol tv = isTcTyVar tv && isSkolemTyVar tv + -- Coercion variables can be free in the + -- hole, via kind casts + expr_hole_hint -- Give hint for, say, f x = _x + | lengthFS (occNameFS hole_occ) > 1 -- Don't give this hint for plain "_" + = text "Or perhaps" <+> quotes (ppr hole_occ) + <+> text "is mis-spelled, or not in scope" + | otherwise + = empty + + type_hole_hint + | ErrorWithoutFlag <- cec_type_holes ctxt + = text "To use the inferred type, enable PartialTypeSignatures" + | otherwise + = empty + + loc_msg tv + | isTyVar tv + = case tcTyVarDetails tv of + MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable" + _ -> empty -- Skolems dealt with already + | otherwise -- A coercion variable can be free in the hole type + = ppWhenOption sdocPrintExplicitCoercions $ + quotes (ppr tv) <+> text "is a coercion variable" + +pp_occ_with_type :: OccName -> Type -> SDoc +pp_occ_with_type occ hole_ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType hole_ty) + +{- ********************************************************************* +* * + Outputting ScopeError messages +* * +**********************************************************************-} + +pprScopeError :: RdrName -> NotInScopeError -> SDoc +pprScopeError rdr_name scope_err = + case scope_err of + NotInScope {} -> + hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + NoExactName name -> + text "The Name" <+> quotes (ppr name) <+> text "is not in scope." + SameName gres -> + assertPpr (length gres >= 2) (text "pprScopeError SameName: fewer than 2 elements" $$ nest 2 (ppr gres)) + $ hang (text "Same Name in multiple name-spaces:") + 2 (vcat (map pp_one sorted_names)) + where + sorted_names = sortBy (leftmost_smallest `on` nameSrcSpan) (map greMangledName gres) + pp_one name + = hang (pprNameSpace (occNameSpace (getOccName name)) + <+> quotes (ppr name) <> comma) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) + MissingBinding thing _ -> + sep [ text "The" <+> thing + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding" ] + NoTopLevelBinding -> + 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 + where + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + +scopeErrorHints :: NotInScopeError -> [GhcHint] +scopeErrorHints scope_err = + case scope_err of + NotInScope -> noHints + NoExactName {} -> [SuggestDumpSlices] + SameName {} -> [SuggestDumpSlices] + MissingBinding _ hints -> hints + NoTopLevelBinding -> noHints + UnknownSubordinate {} -> noHints + +{- ********************************************************************* +* * + Outputting ImportError messages +* * +**********************************************************************-} + +instance Outputable ImportError where + ppr (MissingModule mod_name) = + hsep + [ text "NB: no module named" + , quotes (ppr mod_name) + , text "is imported." + ] + ppr (ModulesDoNotExport mods occ_name) + | mod NE.:| [] <- mods + = hsep + [ text "NB: the module" + , quotes (ppr mod) + , text "does not export" + , quotes (ppr occ_name) <> dot ] + | otherwise + = hsep + [ text "NB: neither" + , quotedListWithNor (map ppr $ NE.toList mods) + , text "export" + , quotes (ppr occ_name) <> dot ] + +{- ********************************************************************* +* * + Suggested fixes for implication constraints +* * +**********************************************************************-} + +-- TODO: these functions should use GhcHint instead. + +show_fixes :: [SDoc] -> SDoc +show_fixes [] = empty +show_fixes (f:fs) = sep [ text "Possible fix:" + , nest 2 (vcat (f : map (text "or" <+>) fs))] + +ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc] +ctxtFixes has_ambig_tvs pred implics + | not has_ambig_tvs + , isTyVarClassPred pred + , (skol:skols) <- usefulContext implics pred + , let what | null skols + , SigSkol (PatSynCtxt {}) _ _ <- skol + = text "\"required\"" + | otherwise + = empty + = [sep [ text "add" <+> pprParendType pred + <+> text "to the" <+> what <+> text "context of" + , nest 2 $ ppr_skol skol $$ + vcat [ text "or" <+> ppr_skol skol + | skol <- skols ] ] ] + | otherwise = [] + where + ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc) + ppr_skol (PatSkol (PatSynCon ps) _) = text "the pattern synonym" <+> quotes (ppr ps) + ppr_skol skol_info = ppr skol_info + +usefulContext :: [Implication] -> PredType -> [SkolemInfo] +-- usefulContext picks out the implications whose context +-- the programmer might plausibly augment to solve 'pred' +usefulContext implics pred + = go implics + where + pred_tvs = tyCoVarsOfType pred + go [] = [] + go (ic : ics) + | implausible ic = rest + | otherwise = ic_info ic : rest + where + -- Stop when the context binds a variable free in the predicate + rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = [] + | otherwise = go ics + + implausible ic + | null (ic_skols ic) = True + | implausible_info (ic_info ic) = True + | otherwise = False + + implausible_info (SigSkol (InfSigCtxt {}) _ _) = True + implausible_info _ = False + -- Do not suggest adding constraints to an *inferred* type signature + +pp_givens :: [Implication] -> [SDoc] +pp_givens givens + = case givens of + [] -> [] + (g:gs) -> ppr_given (text "from the context:") g + : map (ppr_given (text "or from:")) gs + where + ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info }) + = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs)) + -- See Note [Suppress redundant givens during error reporting] + -- for why we use mkMinimalBySCs above. + 2 (sep [ text "bound by" <+> ppr skol_info + , text "at" <+> ppr (getLclEnvLoc (ic_env implic)) ]) + +{- ********************************************************************* +* * + CtOrigin information +* * +**********************************************************************-} + +levelString :: TypeOrKind -> String +levelString TypeLevel = "type" +levelString KindLevel = "kind" + +pprArising :: CtOrigin -> SDoc +-- Used for the main, top-level error message +-- We've done special processing for TypeEq, KindEq, givens +pprArising (TypeEqOrigin {}) = empty +pprArising (KindEqOrigin {}) = empty +pprArising orig | isGivenOrigin orig = empty + | otherwise = pprCtOrigin orig + +-- Add the "arising from..." part to a message +addArising :: CtOrigin -> SDoc -> SDoc +addArising orig msg = hang msg 2 (pprArising orig) + +pprWithArising :: [Ct] -> SDoc +-- Print something like +-- (Eq a) arising from a use of x at y +-- (Show a) arising from a use of p at q +-- Also return a location for the error message +-- Works for Wanted/Derived only +pprWithArising [] + = panic "pprWithArising" +pprWithArising (ct:cts) + | null cts + = addArising (ctLocOrigin loc) (pprTheta [ctPred ct]) + | otherwise + = vcat (map ppr_one (ct:cts)) + where + loc = ctLoc ct + ppr_one ct' = hang (parens (pprType (ctPred ct'))) + 2 (pprCtLoc (ctLoc ct')) + +{- ********************************************************************* +* * + SkolemInfo +* * +**********************************************************************-} + +pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc +pprSkols ctxt tvs + = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs)) + where + pp_one (UnkSkol, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "(rigid, skolem)") + , nest 2 (text "of unknown origin") + , nest 2 (text "bound at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) + ] + pp_one (RuntimeUnkSkol, tvs) + = hang (pprQuotedList tvs) + 2 (is_or_are tvs "an" "unknown runtime") + pp_one (skol_info, tvs) + = vcat [ hang (pprQuotedList tvs) + 2 (is_or_are tvs "a" "rigid" <+> text "bound by") + , nest 2 (pprSkolInfo skol_info) + , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ] + + is_or_are [_] article adjective = text "is" <+> text article <+> text adjective + <+> text "type variable" + is_or_are _ _ adjective = text "are" <+> text adjective + <+> text "type variables" + +{- ********************************************************************* +* * + Utilities for expected/actual messages +* * +**********************************************************************-} + +mk_supplementary_ea_msg :: ReportErrCtxt -> TypeOrKind + -> Type -> Type -> CtOrigin -> Either [TcReportInfo] TcReportMsg +mk_supplementary_ea_msg ctxt level ty1 ty2 orig + | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig + , not (ea_looks_same ty1 ty2 exp act) + = mk_ea_msg ctxt Nothing level orig + | otherwise + = Left [] + +ea_looks_same :: Type -> Type -> Type -> Type -> Bool +-- True if the faulting types (ty1, ty2) look the same as +-- the expected/actual types (exp, act). +-- If so, we don't want to redundantly report the latter +ea_looks_same ty1 ty2 exp act + = (act `looks_same` ty1 && exp `looks_same` ty2) || + (exp `looks_same` ty1 && act `looks_same` ty2) + where + looks_same t1 t2 = t1 `pickyEqType` t2 + || t1 `eqType` liftedTypeKind && t2 `eqType` liftedTypeKind + -- pickyEqType is sensitive to synonyms, so only replies True + -- when the types really look the same. However, + -- (TYPE 'LiftedRep) and Type both print the same way. + +mk_ea_msg :: ReportErrCtxt -> Maybe Ct -> TypeOrKind -> CtOrigin -> Either [TcReportInfo] TcReportMsg +-- Constructs a "Couldn't match" message +-- The (Maybe Ct) says whether this is the main top-level message (Just) +-- or a supplementary message (Nothing) +mk_ea_msg ctxt at_top level + (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing }) + | Just thing <- mb_thing + , KindLevel <- level + = Right $ KindMismatch { kmismatch_what = thing + , kmismatch_expected = exp + , kmismatch_actual = act } + | Just ct <- at_top + , let mismatch = + Mismatch + { mismatch_ea = True + , mismatch_ct = ct + , mismatch_ty1 = exp + , mismatch_ty2 = act } + = Right $ + if expanded_syns + then mkTcReportWithInfo mismatch [ea_expanded] + else mismatch + | otherwise + = Left $ + if expanded_syns + then [ea,ea_expanded] + else [ea] + + where + ea = ExpectedActual { ea_expected = exp, ea_actual = act } + ea_expanded = + ExpectedActualAfterTySynExpansion + { ea_expanded_expected = expTy1 + , ea_expanded_actual = expTy2 } + + expanded_syns = cec_expand_syns ctxt + && not (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) + (expTy1, expTy2) = expandSynonymsToMatch exp act +mk_ea_msg _ _ _ _ = Left [] + +{- Note [Expanding type synonyms to make types similar] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In type error messages, if -fprint-expanded-types is used, we want to expand +type synonyms to make expected and found types as similar as possible, but we +shouldn't expand types too much to make type messages even more verbose and +harder to understand. The whole point here is to make the difference in expected +and found types clearer. + +`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms +only as much as necessary. Given two types t1 and t2: + + * If they're already same, it just returns the types. + + * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are + type constructors), it expands C1 and C2 if they're different type synonyms. + Then it recursively does the same thing on expanded types. If C1 and C2 are + same, then it applies the same procedure to arguments of C1 and arguments of + C2 to make them as similar as possible. + + Most important thing here is to keep number of synonym expansions at + minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3, + Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and + `T (T3, T3, Bool)`. + + * Otherwise types don't have same shapes and so the difference is clearly + visible. It doesn't do any expansions and show these types. + +Note that we only expand top-layer type synonyms. Only when top-layer +constructors are the same we start expanding inner type synonyms. + +Suppose top-layer type synonyms of t1 and t2 can expand N and M times, +respectively. If their type-synonym-expanded forms will meet at some point (i.e. +will have same shapes according to `sameShapes` function), it's possible to find +where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M)) +comparisons. We first collect all the top-layer expansions of t1 and t2 in two +lists, then drop the prefix of the longer list so that they have same lengths. +Then we search through both lists in parallel, and return the first pair of +types that have same shapes. Inner types of these two types with same shapes +are then expanded using the same algorithm. + +In case they don't meet, we return the last pair of types in the lists, which +has top-layer type synonyms completely expanded. (in this case the inner types +are not expanded at all, as the current form already shows the type error) +-} + +-- | Expand type synonyms in given types only enough to make them as similar as +-- possible. Returned types are the same in terms of used type synonyms. +-- +-- To expand all synonyms, see 'Type.expandTypeSynonyms'. +-- +-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for +-- some examples of how this should work. +expandSynonymsToMatch :: Type -> Type -> (Type, Type) +expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) + where + (ty1_ret, ty2_ret) = go ty1 ty2 + + -- | Returns (type synonym expanded version of first type, + -- type synonym expanded version of second type) + go :: Type -> Type -> (Type, Type) + go t1 t2 + | t1 `pickyEqType` t2 = + -- Types are same, nothing to do + (t1, t2) + + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) + | tc1 == tc2 + , tys1 `equalLength` tys2 = + -- Type constructors are same. They may be synonyms, but we don't + -- expand further. The lengths of tys1 and tys2 must be equal; + -- for example, with type S a = a, we don't want + -- to zip (S Monad Int) and (S Bool). + let (tys1', tys2') = + unzip (zipWithEqual "expandSynonymsToMatch" go tys1 tys2) + in (TyConApp tc1 tys1', TyConApp tc2 tys2') + + go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') + + go ty1@(FunTy _ w1 t1_1 t1_2) ty2@(FunTy _ w2 t2_1 t2_2) | w1 `eqType` w2 = + let (t1_1', t2_1') = go t1_1 t2_1 + (t1_2', t2_2') = go t1_2 t2_2 + in ( ty1 { ft_arg = t1_1', ft_res = t1_2' } + , ty2 { ft_arg = t2_1', ft_res = t2_2' }) + + go (ForAllTy b1 t1) (ForAllTy b2 t2) = + -- NOTE: We may have a bug here, but we just can't reproduce it easily. + -- See D1016 comments for details and our attempts at producing a test + -- case. Short version: We probably need RnEnv2 to really get this right. + let (t1', t2') = go t1 t2 + in (ForAllTy b1 t1', ForAllTy b2 t2') + + go (CastTy ty1 _) ty2 = go ty1 ty2 + go ty1 (CastTy ty2 _) = go ty1 ty2 + + go t1 t2 = + -- See Note [Expanding type synonyms to make types similar] for how this + -- works + let + t1_exp_tys = t1 : tyExpansions t1 + t2_exp_tys = t2 : tyExpansions t2 + t1_exps = length t1_exp_tys + t2_exps = length t2_exp_tys + dif = abs (t1_exps - t2_exps) + in + followExpansions $ + zipEqual "expandSynonymsToMatch.go" + (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys) + (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys) + + -- | Expand the top layer type synonyms repeatedly, collect expansions in a + -- list. The list does not include the original type. + -- + -- Example, if you have: + -- + -- type T10 = T9 + -- type T9 = T8 + -- ... + -- type T0 = Int + -- + -- `tyExpansions T10` returns [T9, T8, T7, ... Int] + -- + -- This only expands the top layer, so if you have: + -- + -- type M a = Maybe a + -- + -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded) + tyExpansions :: Type -> [Type] + tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t) + + -- | Drop the type pairs until types in a pair look alike (i.e. the outer + -- constructors are the same). + followExpansions :: [(Type, Type)] -> (Type, Type) + followExpansions [] = pprPanic "followExpansions" empty + followExpansions [(t1, t2)] + | sameShapes t1 t2 = go t1 t2 -- expand subtrees + | otherwise = (t1, t2) -- the difference is already visible + followExpansions ((t1, t2) : tss) + -- Traverse subtrees when the outer shapes are the same + | sameShapes t1 t2 = go t1 t2 + -- Otherwise follow the expansions until they look alike + | otherwise = followExpansions tss + + sameShapes :: Type -> Type -> Bool + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index f9de50f37a..8fa8e02b5e 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -31,22 +31,43 @@ module GHC.Tc.Errors.Types ( , associatedTyLastVarInKind , AssociatedTyNotParamOverLastTyVar(..) , associatedTyNotParamOverLastTyVar + + , SolverReport(..), SolverReportSupplementary(..) + , ReportWithCtxt(..) + , ReportErrCtxt(..) + , getUserGivens, discardProvCtxtGivens, getSkolemInfo + , TcReportMsg(..), TcReportInfo(..) + , CND_Extra(..) + , mkTcReportWithInfo + , FitsMbSuppressed(..) + , ValidHoleFits(..), noValidHoleFits + , HoleFitDispConfig(..) + , RelevantBindings(..), pprRelevantBindings + , NotInScopeError(..), mkTcRnNotInScope + , ImportError(..) + , HoleError(..) + , CoercibleMsg(..) + , PotentialInstances(..) ) where import GHC.Prelude import GHC.Hs import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo) +import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit) import GHC.Tc.Types.Constraint +import GHC.Tc.Types.Evidence (EvBindsVar) +import GHC.Tc.Types.Origin (CtOrigin (ProvCtxtOrigin), TypedThing, TyVarBndrs, SkolemInfo (SigSkol, UnkSkol, RuntimeUnkSkol), FRROrigin, UserTypeCtxt (PatSynCtxt)) import GHC.Tc.Types.Rank (Rank) -import GHC.Tc.Utils.TcType (TcType) +import GHC.Tc.Utils.TcType (TcType, isRuntimeUnkSkol) import GHC.Types.Error import GHC.Types.FieldLabel (FieldLabelString) -import GHC.Types.Name (Name, OccName) +import GHC.Types.Name (Name, OccName, getSrcLoc) import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Types.TyThing (TyThing) -import GHC.Types.Var (Id) +import GHC.Types.Var (Id, TyCoVar, TyVar, TcTyVar) +import GHC.Types.Var.Env (TidyEnv) import GHC.Types.Var.Set (TyVarSet, VarSet) import GHC.Unit.Types (Module) import GHC.Utils.Outputable @@ -61,10 +82,14 @@ import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Unit.State (UnitState) import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic +import GHC.Utils.Misc (filterOut) +import GHC.Utils.Trace (pprTraceUserWarning) import qualified GHC.LanguageExtensions as LangExt import qualified Data.List.NonEmpty as NE import Data.Typeable hiding (TyCon) +import qualified Data.Semigroup as Semigroup +import Data.List (partition) {- Note [Migrating TcM Messages] @@ -138,6 +163,50 @@ data TcRnMessage where -> !TcRnMessageDetailed -> TcRnMessage + {-| TcRnSolverReport is the constructor used to report unsolved constraints + after constraint solving, as well as other errors such as hole fit errors. + + See the documentation of the 'TcReportMsg' datatype for an overview + of the different errors. + -} + TcRnSolverReport :: [ReportWithCtxt] + -> DiagnosticReason + -> [GhcHint] + -> TcRnMessage + -- TODO: split up TcRnSolverReport into several components, + -- so that we can compute the reason and hints, as opposed + -- to having to pass them here. + + {-| TcRnRedundantConstraints is a warning that is emitted when a binding + has a user-written type signature which contains superfluous constraints. + + Example: + + f :: (Eq a, Ord a) => a -> a -> a + f x y = (x < y) || x == y + -- `Eq a` is superfluous: the `Ord a` constraint suffices. + + Test cases: T9939, T10632, T18036a, T20602, PluralS, T19296. + -} + TcRnRedundantConstraints :: [Id] -> (SkolemInfo, Bool) -> TcRnMessage + + {-| TcRnInaccessibleCode is a warning that is emitted when the RHS of a pattern + match is inaccessible, because the constraint solver has detected a contradiction. + + Example: + + data B a where { MkTrue :: B True; MkFalse :: B False } + + foo :: B False -> Bool + foo MkFalse = False + foo MkTrue = True -- Inaccessible: requires True ~ False + + Test cases: T7293, T7294, T15558, T17646, T18572, T18610, tcfail167. + -} + TcRnInaccessibleCode :: Implication -- ^ The implication containing a contradiction. + -> NE.NonEmpty ReportWithCtxt -- ^ The contradiction(s). + -> TcRnMessage + {-| A type which was expected to have a fixed runtime representation does not have a fixed runtime representation. @@ -1416,7 +1485,7 @@ data TcRnMessage where -} TcRnArrowProcGADTPattern :: TcRnMessage - {- TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs + {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs when a definition uses 'forall' as an identifier. Example: @@ -1435,6 +1504,60 @@ data TcRnMessage where Test cases: T20485, T20485a -} TcRnGADTMonoLocalBinds :: TcRnMessage + {-| The TcRnNotInScope constructor is used for various not-in-scope errors. + See 'NotInScopeError' for more details. -} + TcRnNotInScope :: NotInScopeError -- ^ what the problem is + -> RdrName -- ^ the name that is not in scope + -> [ImportError] -- ^ import errors that are relevant + -> [GhcHint] -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor + -> TcRnMessage + + {-| TcRnUntickedPromotedConstructor is a warning (controlled with -Wunticked-promoted-constructors + that is triggered by an unticked occurrence of a promoted data constructor. + + Example: + + data A = MkA + type family F (a :: A) where { F MkA = Bool } + + Test case: T9778. + -} + TcRnUntickedPromotedConstructor :: Name + -> TcRnMessage + + {-| TcRnIllegalBuiltinSyntax is an error that occurs when built-in syntax appears + in an unexpected location, e.g. as a data constructor or in a fixity declaration. + + Examples: + + infixl 5 : + + data P = (,) + + Test cases: rnfail042, T14907b, T15124, T15233. + -} + TcRnIllegalBuiltinSyntax :: SDoc -- ^ what kind of thing this is (a binding, fixity declaration, ...) + -> RdrName + -> TcRnMessage + -- TODO: remove the SDoc argument. + + {-| TcRnWarnDefaulting is a warning (controlled by -Wtype-defaults) + that is triggered whenever a Wanted typeclass constraint + is solving through the defaulting of a type variable. + + Example: + + one = show 1 + -- We get Wanteds Show a0, Num a0, and default a0 to Integer. + + Test cases: + none (which are really specific to defaulting), + but see e.g. tcfail204. + -} + TcRnWarnDefaulting :: [Ct] -- ^ Wanted constraints in which defaulting occurred + -> Maybe TyVar -- ^ The type variable being defaulted + -> Type -- ^ The default type + -> TcRnMessage {-| TcRnIncorrectNameSpace is an error that occurs when a 'Name' is used in the incorrect 'NameSpace', e.g. a type constructor @@ -1703,3 +1826,590 @@ data AssociatedTyNotParamOverLastTyVar associatedTyNotParamOverLastTyVar :: Maybe TyCon -> AssociatedTyNotParamOverLastTyVar associatedTyNotParamOverLastTyVar (Just tc) = YesAssociatedTyNotParamOverLastTyVar tc associatedTyNotParamOverLastTyVar Nothing = NoAssociatedTyNotParamOverLastTyVar + +-------------------------------------------------------------------------------- +-- Errors used in GHC.Tc.Errors + +{- Note [Error report] +~~~~~~~~~~~~~~~~~~~~~~ +The idea is that error msgs are divided into three parts: the main msg, the +context block ("In the second argument of ..."), and the relevant bindings +block, which are displayed in that order, with a mark to divide them. The +the main msg ('report_important') varies depending on the error +in question, but context and relevant bindings are always the same, which +should simplify visual parsing. + +See 'GHC.Tc.Errors.Types.SolverReport' and 'GHC.Tc.Errors.mkErrorReport'. +-} + +-- | A collection of main error messages and supplementary information. +-- +-- In practice, we will: +-- - display the important messages first, +-- - then the error context (e.g. by way of a call to 'GHC.Tc.Errors.mkErrorReport'), +-- - then the supplementary information (e.g. relevant bindings, valid hole fits), +-- - then the hints ("Possible fix: ..."). +-- +-- So this is mostly just a way of making sure that the error context appears +-- early on rather than at the end of the message. +-- +-- See Note [Error report] for details. +data SolverReport + = SolverReport + { sr_important_msgs :: [ReportWithCtxt] + , sr_supplementary :: [SolverReportSupplementary] + , sr_hints :: [GhcHint] + } + +-- | Additional information to print in a 'SolverReport', after the +-- important messages and after the error context. +-- +-- See Note [Error report]. +data SolverReportSupplementary + = SupplementaryBindings RelevantBindings + | SupplementaryHoleFits ValidHoleFits + | SupplementaryCts [(PredType, RealSrcSpan)] + +-- | A 'TcReportMsg', together with context (e.g. enclosing implication constraints) +-- that are needed in order to report it. +data ReportWithCtxt = + ReportWithCtxt + { reportContext :: ReportErrCtxt + -- ^ Context for what we wish to report. + -- This can change as we enter implications, so is + -- stored alongside the content. + , reportContent :: TcReportMsg + -- ^ The content of the message to report. + } + +instance Semigroup SolverReport where + SolverReport main1 supp1 hints1 <> SolverReport main2 supp2 hints2 + = SolverReport (main1 ++ main2) (supp1 ++ supp2) (hints1 ++ hints2) + +instance Monoid SolverReport where + mempty = SolverReport [] [] [] + mappend = (Semigroup.<>) + +-- | Context needed when reporting a 'TcReportMsg', such as +-- the enclosing implication constraints or whether we are deferring type errors. +data ReportErrCtxt + = CEC { cec_encl :: [Implication] -- | Enclosing implications + -- (innermost first) + -- ic_skols and givens are tidied, rest are not + , cec_tidy :: TidyEnv + + , cec_binds :: EvBindsVar -- Make some errors (depending on cec_defer) + -- into warnings, and emit evidence bindings + -- into 'cec_binds' for unsolved constraints + + , cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime + + -- cec_expr_holes is a union of: + -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' + -- cec_out_of_scope_holes - a set of variables which are + -- out of scope: 'x', 'y', 'bar' + , cec_expr_holes :: DiagnosticReason -- Holes in expressions. + , cec_type_holes :: DiagnosticReason -- Holes in types. + , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. + + , cec_warn_redundant :: Bool -- | True <=> -Wredundant-constraints + , cec_expand_syns :: Bool -- | True <=> -fprint-expanded-synonyms + + , cec_suppress :: Bool -- | True <=> More important errors have occurred, + -- so create bindings if need be, but + -- don't issue any more errors/warnings + -- See Note [Suppressing error messages] + } + +getUserGivens :: ReportErrCtxt -> [UserGiven] +-- One item for each enclosing implication +getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics + + +{- Note [discardProvCtxtGivens] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In most situations we call all enclosing implications "useful". There is one +exception, and that is when the constraint that causes the error is from the +"provided" context of a pattern synonym declaration: + + pattern Pat :: (Num a, Eq a) => Show a => a -> Maybe a + -- required => provided => type + pattern Pat x <- (Just x, 4) + +When checking the pattern RHS we must check that it does actually bind all +the claimed "provided" constraints; in this case, does the pattern (Just x, 4) +bind the (Show a) constraint. Answer: no! + +But the implication we generate for this will look like + forall a. (Num a, Eq a) => [W] Show a +because when checking the pattern we must make the required +constraints available, since they are needed to match the pattern (in +this case the literal '4' needs (Num a, Eq a)). + +BUT we don't want to suggest adding (Show a) to the "required" constraints +of the pattern synonym, thus: + pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a +It would then typecheck but it's silly. We want the /pattern/ to bind +the alleged "provided" constraints, Show a. + +So we suppress that Implication in discardProvCtxtGivens. It's +painfully ad-hoc but the truth is that adding it to the "required" +constraints would work. Suppressing it solves two problems. First, +we never tell the user that we could not deduce a "provided" +constraint from the "required" context. Second, we never give a +possible fix that suggests to add a "provided" constraint to the +"required" context. + +For example, without this distinction the above code gives a bad error +message (showing both problems): + + error: Could not deduce (Show a) ... from the context: (Eq a) + ... Possible fix: add (Show a) to the context of + the signature for pattern synonym `Pat' ... +-} + + +discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] +discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] + | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig + = filterOut (discard name) givens + | otherwise + = givens + where + discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n' + discard _ _ = False + + +getSkolemInfo :: [Implication] -> [TcTyVar] + -> [(SkolemInfo, [TcTyVar])] -- #14628 +-- Get the skolem info for some type variables +-- from the implication constraints that bind them. +-- +-- In the returned (skolem, tvs) pairs, the 'tvs' part is non-empty +getSkolemInfo _ [] + = [] + +getSkolemInfo [] tvs + | all isRuntimeUnkSkol tvs = [(RuntimeUnkSkol, tvs)] -- #14628 + | otherwise = -- See https://gitlab.haskell.org/ghc/ghc/-/issues?label_name[]=No%20skolem%20info + pprTraceUserWarning msg [(UnkSkol,tvs)] + where + msg = text "No skolem info - we could not find the origin of the following variables" <+> ppr tvs + $$ text "This should not happen, please report it as a bug following the instructions at:" + $$ text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug" + + +getSkolemInfo (implic:implics) tvs + | null tvs_here = getSkolemInfo implics tvs + | otherwise = (ic_info implic, tvs_here) : getSkolemInfo implics tvs_other + where + (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs + +-- | An error reported after constraint solving. +-- This is usually, some sort of unsolved constraint error, +-- but we try to be specific about the precise problem we encountered. +data TcReportMsg + -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors + -- to use the diagnostic infrastructure (TcRnMessage etc). + -- If you see possible improvements, please go right ahead! + + -- | Wrap a message with additional information. + -- + -- Prefer using the 'mkTcReportWithInfo' smart constructor + = TcReportWithInfo TcReportMsg (NE.NonEmpty TcReportInfo) + + -- | Quantified variables appear out of dependency order. + -- + -- Example: + -- + -- forall (a :: k) k. ... + -- + -- Test cases: BadTelescope2, T16418, T16247, T16726, T18451. + | BadTelescope TyVarBndrs [TyCoVar] + + -- | We came across a custom type error and we have decided to report it. + -- + -- Example: + -- + -- type family F a where + -- F a = TypeError (Text "error") + -- + -- err :: F () + -- err = () + -- + -- Test cases: CustomTypeErrors0{1,2,3,4,5}, T12104. + | UserTypeError Type + + -- | We want to report an out of scope variable or a typed hole. + -- See 'HoleError'. + | ReportHoleError Hole HoleError + + -- | A type equality between a type variable and a polytype. + -- + -- Test cases: T12427a, T2846b, T10194, ... + | CannotUnifyWithPolytype Ct TyVar Type + + -- | Couldn't unify two types or kinds. + -- + -- Example: + -- + -- 3 + 3# -- can't match a lifted type with an unlifted type + -- + -- Test cases: T1396, T8263, ... + | Mismatch + { mismatch_ea :: Bool -- ^ Should this be phrased in terms of expected vs actual? + , mismatch_ct :: Ct -- ^ The constraint in which the mismatch originated. + , mismatch_ty1 :: Type -- ^ First type (the expected type if if mismatch_ea is True) + , mismatch_ty2 :: Type -- ^ Second type (the actual type if mismatch_ea is True) + } + + -- | A type has an unexpected kind. + -- + -- Test cases: T2994, T7609, ... + | KindMismatch + { kmismatch_what :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of? + , kmismatch_expected :: Type + , kmismatch_actual :: Type + } + -- TODO: combine 'Mismatch' and 'KindMismatch' messages. + + -- | A mismatch between two types, which arose from a type equality. + -- + -- Test cases: T1470, tcfail212. + | TypeEqMismatch + { teq_mismatch_ppr_explicit_kinds :: Bool + , teq_mismatch_ct :: Ct + , teq_mismatch_ty1 :: Type + , teq_mismatch_ty2 :: Type + , teq_mismatch_expected :: Type -- ^ The overall expected type + , teq_mismatch_actual :: Type -- ^ The overall actual type + , teq_mismatch_what :: Maybe TypedThing -- ^ What thing is 'teq_mismatch_actual' the kind of? + } + -- TODO: combine 'Mismatch' and 'TypeEqMismatch' messages. + + -- | A violation of the representation-polymorphism invariants, + -- i.e. an unsolved `Concrete# ty` constraint. + -- + -- See 'FRROrigin' for more information. + | FixedRuntimeRepError [(FRROrigin, Type)] + + -- | A skolem type variable escapes its scope. + -- + -- Example: + -- + -- data Ex where { MkEx :: a -> MkEx } + -- foo (MkEx x) = x + -- + -- Test cases: TypeSkolEscape, T11142. + | SkolemEscape Ct Implication [TyVar] + + -- | Trying to unify an untouchable variable, e.g. a variable from an outer scope. + -- + -- Test case: Simple14 + | UntouchableVariable TyVar Implication + + -- | An equality between two types is blocked on a kind equality + -- beteen their kinds. + -- + -- Test cases: none. + | BlockedEquality Ct + + -- | Something was not applied to sufficiently many arguments. + -- + -- Example: + -- + -- instance Eq Maybe where {..} + -- + -- Test case: T11563. + | ExpectingMoreArguments Int TypedThing + + -- | Trying to use an unbound implicit parameter. + -- + -- Example: + -- + -- foo :: Int + -- foo = ?param + -- + -- Test case: tcfail130. + | UnboundImplicitParams + (NE.NonEmpty Ct) + + -- | Couldn't solve some Wanted constraints using the Givens. + -- This is the most commonly used constructor, used for generic + -- @"No instance for ..."@ and @"Could not deduce ... from"@ messages. + | CouldNotDeduce + { cnd_user_givens :: [Implication] + -- | The Wanted constraints we couldn't solve. + -- + -- N.B.: the 'Ct' at the head of the list has been tidied, + -- perhaps not the others. + , cnd_wanted :: NE.NonEmpty Ct + + -- | Some additional info consumed by 'mk_supplementary_ea_msg'. + , cnd_extra :: Maybe CND_Extra + } + + -- | A constraint couldn't be solved because it contains + -- ambiguous type variables. + -- + -- Example: + -- + -- class C a b where + -- f :: (a,b) + -- + -- x = fst f + -- + -- + -- Test case: T4921. + | AmbiguityPreventsSolvingCt + Ct -- ^ always a class constraint + ([TyVar], [TyVar]) -- ^ ambiguous kind and type variables, respectively + + -- | Could not solve a constraint; there were several unifying candidate instances + -- but no matching instances. This is used to report as much useful information + -- as possible about why we couldn't choose any instance, e.g. because of + -- ambiguous type variables. + | CannotResolveInstance + { cannotResolve_ct :: Ct + , cannotResolve_unifiers :: [ClsInst] + , cannotResolve_candidates :: [ClsInst] + , cannotResolve_importErrors :: [ImportError] + , cannotResolve_suggestions :: [GhcHint] + , cannotResolve_relevant_bindings :: RelevantBindings } + -- TODO: remove the fields of type [GhcHint] and RelevantBindings, + -- in order to handle them uniformly with other diagnostic messages. + + -- | Could not solve a constraint using available instances + -- because the instances overlap. + -- + -- Test cases: tcfail118, tcfail121, tcfail218. + | OverlappingInstances + { overlappingInstances_ct :: Ct + , overlappingInstances_matches :: [ClsInst] + , overlappingInstances_unifiers :: [ClsInst] } + + -- | Could not solve a constraint from instances because + -- instances declared in a Safe module cannot overlap instances + -- from other modules (with -XSafeHaskell). + -- + -- Test cases: SH_Overlap{1,2,5,6,7,11}. + | UnsafeOverlap + { unsafeOverlap_ct :: Ct + , unsafeOverlap_matches :: [ClsInst] + , unsafeOverlapped :: [ClsInst] } + +-- | Additional information to be given in a 'CouldNotDeduce' message, +-- which is then passed on to 'mk_supplementary_ea_msg'. +data CND_Extra = CND_Extra TypeOrKind Type Type + +-- | Additional information that can be appended to an existing 'TcReportMsg'. +data TcReportInfo + -- NB: this datatype is only a first step in refactoring GHC.Tc.Errors + -- to use the diagnostic infrastructure (TcRnMessage etc). + -- It would be better for these constructors to not be so closely tied + -- to the constructors of 'TcReportMsg'. + -- If you see possible improvements, please go right ahead! + + -- | Some type variables remained ambiguous: print them to the user. + = Ambiguity + { lead_with_ambig_msg :: Bool -- ^ True <=> start the message with "Ambiguous type variable ..." + -- False <=> create a message of the form "The type variable is ambiguous." + , ambig_tyvars :: ([TyVar], [TyVar]) -- ^ Ambiguous kind and type variables, respectively. + -- Guaranteed to not both be empty. + } + + -- | Specify some information about a type variable, + -- e.g. its 'SkolemInfo'. + | TyVarInfo TyVar + + -- | Remind the user that a particular type family is not injective. + | NonInjectiveTyFam TyCon + + -- | Explain why we couldn't coerce between two types. See 'CoercibleMsg'. + | ReportCoercibleMsg CoercibleMsg + + -- | Display the expected and actual types. + | ExpectedActual + { ea_expected, ea_actual :: Type } + + -- | Display the expected and actual types, after expanding type synonyms. + | ExpectedActualAfterTySynExpansion + { ea_expanded_expected, ea_expanded_actual :: Type } + + -- | Explain how a kind equality originated. + | WhenMatching TcType TcType CtOrigin (Maybe TypeOrKind) + + -- | Add some information to disambiguate errors in which + -- two 'Names' would otherwise appear to be identical. + -- + -- See Note [Disambiguating (X ~ X) errors]. + | SameOcc + { sameOcc_same_pkg :: Bool -- ^ Whether the two 'Name's also came from the same package. + , sameOcc_lhs :: Name + , sameOcc_rhs :: Name } + + -- | Report some type variables that might be participating in an occurs-check failure. + | OccursCheckInterestingTyVars (NE.NonEmpty TyVar) + +-- | Some form of @"not in scope"@ error. See also the 'OutOfScopeHole' +-- constructor of 'HoleError'. +data NotInScopeError + + -- | A run-of-the-mill @"not in scope"@ error. + = NotInScope + + -- | An exact 'Name' was not in scope. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test cases: T5971, T18263. + | NoExactName Name + + -- The same exact 'Name' occurs in multiple name-spaces. + -- + -- This usually indicates a problem with a Template Haskell splice. + -- + -- Test case: T7241. + | SameName [GlobalRdrElt] -- ^ always at least 2 elements + + -- A type signature, fixity declaration, pragma, standalone kind signature... + -- is missing an associated binding. + | MissingBinding SDoc [GhcHint] + -- TODO: remove the SDoc argument. + + -- | Couldn't find a top-level binding. + -- + -- Happens when specifying an annotation for something that + -- is not in scope. + -- + -- Test cases: annfail01, annfail02, annfail11. + | NoTopLevelBinding + + -- | A class doesnt have a method with this name, + -- 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 + +-- | Create a @"not in scope"@ error message for the given 'RdrName'. +mkTcRnNotInScope :: RdrName -> NotInScopeError -> TcRnMessage +mkTcRnNotInScope rdr err = TcRnNotInScope err rdr [] noHints + +-- | Configuration for pretty-printing valid hole fits. +data HoleFitDispConfig = + HFDC { showWrap, showWrapVars, showType, showProv, showMatches + :: Bool } + +-- | Report an error involving a 'Hole'. +-- +-- This could be an out of scope data constructor or variable, +-- a typed hole, or a wildcard in a type. +data HoleError + -- | Report an out-of-scope data constructor or variable + -- masquerading as an expression hole. + -- + -- See Note [Insoluble holes] in GHC.Tc.Types.Constraint. + -- See 'NotInScopeError' for other not-in-scope errors. + -- + -- Test cases: T9177a. + = OutOfScopeHole [ImportError] + -- | Report a typed hole, or wildcard, with additional information. + | HoleError HoleSort + +-- | A message that aims to explain why two types couldn't be seen +-- to be representationally equal. +data CoercibleMsg + -- | Not knowing the role of a type constructor prevents us from + -- concluding that two types are representationally equal. + -- + -- Example: + -- + -- foo :: Applicative m => m (Sum Int) + -- foo = coerce (pure $ 1 :: Int) + -- + -- We don't know what role `m` has, so we can't coerce `m Int` to `m (Sum Int)`. + -- + -- Test cases: T8984, TcCoercibleFail. + = UnknownRoles Type + + -- | The fact that a 'TyCon' is abstract prevents us from decomposing + -- a 'TyConApp' and deducing that two types are representationally equal. + -- + -- Test cases: none. + | TyConIsAbstract TyCon + + -- | We can't unwrap a newtype whose constructor is not in scope. + -- + -- Example: + -- + -- import Data.Ord (Down) -- NB: not importing the constructor + -- foo :: Int -> Down Int + -- foo = coerce + -- + -- Test cases: TcCoercibleFail. + | OutOfScopeNewtypeConstructor TyCon DataCon + +-- | Explain a problem with an import. +data ImportError + -- | Couldn't find a module with the requested name. + = MissingModule ModuleName + -- | The imported modules don't export what we're looking for. + | ModulesDoNotExport (NE.NonEmpty Module) OccName + +-- | This datatype collates instances that match or unifier, +-- in order to report an error message for an unsolved typeclass constraint. +data PotentialInstances + = PotentialInstances + { matches :: [ClsInst] + , unifiers :: [ClsInst] + } + +-- | Append additional information to a `TcReportMsg`. +mkTcReportWithInfo :: TcReportMsg -> [TcReportInfo] -> TcReportMsg +mkTcReportWithInfo msg [] + = msg +mkTcReportWithInfo (TcReportWithInfo msg (prev NE.:| prevs)) infos + = TcReportWithInfo msg (prev NE.:| prevs ++ infos) +mkTcReportWithInfo msg (info : infos) + = TcReportWithInfo msg (info NE.:| infos) + +-- | A collection of valid hole fits or refinement fits, +-- in which some fits might have been suppressed. +data FitsMbSuppressed + = Fits + { fits :: [HoleFit] + , fitsSuppressed :: Bool -- ^ Whether we have suppressed any fits because there were too many. + } + +-- | A collection of hole fits and refinement fits. +data ValidHoleFits + = ValidHoleFits + { holeFits :: FitsMbSuppressed + , refinementFits :: FitsMbSuppressed + } + +noValidHoleFits :: ValidHoleFits +noValidHoleFits = ValidHoleFits (Fits [] False) (Fits [] False) + +data RelevantBindings + = RelevantBindings + { relevantBindingNamesAndTys :: [(Name, Type)] + , ranOutOfFuel :: Bool -- ^ Whether we ran out of fuel generating the bindings. + } + +-- | Display some relevant bindings. +pprRelevantBindings :: RelevantBindings -> SDoc +-- This function should be in "GHC.Tc.Errors.Ppr", +-- but's it's here for the moment as it's needed in "GHC.Tc.Errors". +pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = + ppUnless (null bds) $ + hang (text "Relevant bindings include") + 2 (vcat (map ppr_binding bds) $$ ppWhen ran_out_of_fuel discardMsg) + where + ppr_binding (nm, tidy_ty) = + sep [ pprPrefixOcc nm <+> dcolon <+> ppr tidy_ty + , nest 2 (parens (text "bound at" + <+> ppr (getSrcLoc nm)))] + +discardMsg :: SDoc +discardMsg = text "(Some bindings suppressed;" <+> + text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 1ee4e95753..0db2d804a8 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -862,7 +862,7 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args go1 delta acc so_far fun_ty (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args) = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald - (Just (ppr rn_fun)) + (Just $ HsExprRnThing rn_fun) (n_val_args, so_far) fun_ty ; (delta', arg') <- if do_ql then addArgCtxt ctxt arg $ @@ -1238,7 +1238,7 @@ qlUnify delta ty1 ty2 -- Passes the occurs check = do { let ty2_kind = typeKind ty2 kappa_kind = tyVarKind kappa - ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind + ; co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind -- unifyKind: see Note [Actual unification in qlUnify] ; traceTc "qlUnify:update" $ diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index b6573897e2..0c1d4faf24 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -781,7 +781,7 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ scrut_ty = TcType.substTy scrut_subst con1_res_ty con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys - ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty + ; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty -- NB: normal unification is OK here (as opposed to subsumption), -- because for this to work out, both record_rho and scrut_ty have -- to be normal datatypes -- no contravariant stuff can go on diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index b878a5b45b..286eec6e5c 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -47,7 +47,6 @@ import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Family ( tcLookupDataFamInst ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core.UsageEnv ( unitUE ) -import GHC.Rename.Utils ( unknownSubordinateErr ) import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) ) import GHC.Unit.Module ( getModule ) import GHC.Tc.Errors.Types @@ -548,8 +547,8 @@ lookupParents is_selector rdr fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage fieldNotInType p rdr - = TcRnUnknownMessage $ mkPlainError noHints $ - unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + = mkTcRnNotInScope rdr $ + UnknownSubordinate (text "field of type" <+> quotes (ppr p)) notSelector :: Name -> TcRnMessage notSelector field @@ -676,10 +675,10 @@ tcInferOverLit lit@(OverLit { ol_val = val do { from_id <- tcLookupId from_name ; (wrap1, from_ty) <- topInstantiate orig (idType from_id) - ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc + ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing (1, []) from_ty ; hs_lit <- mkOverLit val - ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) + ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty) ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $ HsLit noAnn hs_lit @@ -691,9 +690,9 @@ tcInferOverLit lit@(OverLit { ol_val = val , ol_type = res_ty } } ; return (HsOverLit noAnn lit', res_ty) } where - orig = LiteralOrigin lit - mb_doc = Just (ppr from_name) - herald = sep [ text "The function" <+> quotes (ppr from_name) + orig = LiteralOrigin lit + mb_thing = Just (NameThing from_name) + herald = sep [ text "The function" <+> quotes (ppr from_name) , text "is applied to"] @@ -760,25 +759,29 @@ tc_infer_id id_name ppr thing <+> text "used where a value identifier was expected" } where fail_tycon tc = do - gre <- getGlobalRdrEnv - suggestions <- get_suggestions dataName - unit_state <- hsc_units <$> getTopEnv - let pprov = case lookupGRE_Name gre (tyConName tc) of + gre <- getGlobalRdrEnv + let nm = tyConName tc + pprov = case lookupGRE_Name gre nm of Just gre -> nest 2 (pprNameProvenance gre) Nothing -> empty - info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = suggestions } - msg = TcRnMessageWithInfo unit_state - $ TcRnMessageDetailed info (TcRnIncorrectNameSpace (tyConName tc) False) - failWithTc msg - - fail_tyvar name = do - suggestions <- get_suggestions varName - unit_state <- hsc_units <$> getTopEnv - let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc name)) - info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = suggestions } - msg = TcRnMessageWithInfo unit_state - $ TcRnMessageDetailed info (TcRnIncorrectNameSpace name False) - failWithTc msg + fail_with_msg dataName nm pprov + + fail_tyvar nm = + let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm)) + in fail_with_msg varName nm pprov + + fail_with_msg whatName nm pprov = do + (import_errs, hints) <- get_suggestions whatName + unit_state <- hsc_units <$> getTopEnv + let + -- TODO: unfortunate to have to convert to SDoc here. + -- This should go away once we refactor ErrInfo. + hint_msg = vcat $ map ppr hints + import_err_msg = vcat $ map ppr import_errs + info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg } + msg = TcRnMessageWithInfo unit_state + $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False) + failWithTc msg get_suggestions ns = do let occ = mkOccNameFS ns (occNameFS (occName id_name)) diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index b5386aa6a7..c9024a5cf5 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -1668,7 +1668,7 @@ tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args (HsValArg _ : _, Nothing) -> try_again_after_substing_or $ do { let arrows_needed = n_initial_val_args all_args - ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki + ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki ; fun' <- zonkTcType (fun `mkTcCastTy` co) -- This zonk is essential, to expose the fruits @@ -1925,7 +1925,7 @@ checkExpectedKind hs_ty ty act_kind exp_kind ; let origin = TypeEqOrigin { uo_actual = act_kind' , uo_expected = exp_kind - , uo_thing = Just (ppr hs_ty) + , uo_thing = Just (HsTypeRnThing hs_ty) , uo_visible = True } -- the hs_ty is visible ; traceTc "checkExpectedKindX" $ @@ -2683,7 +2683,7 @@ kcCheckDeclHeader_sig kisig name flav KindedTyVar _ _ v v_hs_ki -> do v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] - unifyKind (Just (ppr v)) + unifyKind (Just . NameThing $ unLoc v) (tyBinderType tb) v_ki @@ -3163,7 +3163,7 @@ tcExplicitTKBndrsX skol_mode bndrs thing_inside bindExplicitTKBndrsX skol_mode bndrs $ thing_inside - ; let skol_info = ForAllSkol (fsep (map ppr bndrs)) + ; let skol_info = ForAllSkol (HsTyVarBndrsRn $ map unLoc bndrs) -- Notice that we use ForAllSkol here, ignoring the enclosing -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope -- test applies only to ForAllSkol @@ -3247,7 +3247,7 @@ bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_ki , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind ; discardResult $ - unifyKind (Just (ppr name)) kind (tyVarKind tv) + unifyKind (Just . NameThing $ name) kind (tyVarKind tv) -- This unify rejects: -- class C (m :: * -> *) where -- type F (m :: *) = ... diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 00b2e053f8..2fbd7dcf8c 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -433,7 +433,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of -- Expression must be a function ; let herald = text "A view pattern expression expects" ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma) - <- matchActualFunTySigma herald (Just (ppr expr)) (1,[]) expr_ty + <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty -- See Note [View patterns and polymorphism] -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 9e7dca9bd4..da6054a74f 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -3191,7 +3191,7 @@ checkFamTelescope tclvl hs_outer_bndrs outer_tvs | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs , (b_first : _) <- bndrs , let b_last = last bndrs - skol_info = ForAllSkol (fsep (map ppr bndrs)) + skol_info = ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs) = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC | otherwise diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 98fb149c27..ff44f1864e 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -898,7 +898,7 @@ tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity -- is compatible with the explicit signature (or Type, if there -- is none) ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats - ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind + ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind ; traceTc "tcDataFamInstHeader" $ vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ] diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index 103f0744b6..955874b13f 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -25,6 +25,7 @@ module GHC.Tc.Types.Constraint ( ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, tyCoVarsOfCt, tyCoVarsOfCts, tyCoVarsOfCtList, tyCoVarsOfCtsList, + ambigTkvsOfCt, CtIrredReason(..), HoleSet, isInsolubleReason, @@ -49,6 +50,7 @@ module GHC.Tc.Types.Constraint ( Implication(..), implicationPrototype, checkTelescopeSkol, ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + UserGiven, getUserGivensFromImplics, HasGivenEqs(..), SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, bumpSubGoalDepth, subGoalDepthExceeded, @@ -114,7 +116,7 @@ import qualified Data.Semigroup ( (<>) ) -- these are for CheckTyEqResult import Data.Word ( Word8 ) -import Data.List ( intersperse ) +import Data.List ( intersperse, partition ) @@ -741,6 +743,14 @@ tyCoFVsOfHole (Hole { hole_ty = ty }) = tyCoFVsOfType ty tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV tyCoFVsOfBag tvs_of = foldr (unionFV . tvs_of) emptyFV +ambigTkvsOfCt :: Ct -> ([Var],[Var]) +ambigTkvsOfCt ct + = partition (`elemVarSet` dep_tkv_set) ambig_tkvs + where + tkvs = tyCoVarsOfCtList ct + ambig_tkvs = filter isAmbiguousTyVar tkvs + dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs) + --------------------------- dropDerivedWC :: WantedConstraints -> WantedConstraints -- See Note [Dropping derived constraints] @@ -1386,6 +1396,12 @@ data HasGivenEqs -- See Note [HasGivenEqs] -- is possible. deriving Eq +type UserGiven = Implication + +getUserGivensFromImplics :: [Implication] -> [UserGiven] +getUserGivensFromImplics implics + = reverse (filterOut (null . ic_given) implics) + {- Note [HasGivenEqs] ~~~~~~~~~~~~~~~~~~~~~ The GivenEqs data type describes the Given constraints of an implication constraint: diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs index d7c68ccd17..00f1ca10a0 100644 --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -1,4 +1,6 @@ - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -20,6 +22,8 @@ module GHC.Tc.Types.Origin ( isVisibleOrigin, toInvisibleOrigin, pprCtOrigin, isGivenOrigin, + TypedThing(..), TyVarBndrs(..), + -- CtOrigin and CallStack isPushCallStackOrigin, callStackOriginFS, -- FixedRuntimeRep origin @@ -212,8 +216,8 @@ data SkolemInfo -- hence, we have less info | ForAllSkol -- Bound by a user-written "forall". - SDoc -- Shows just the binders, used when reporting a bad telescope - -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint + TyVarBndrs -- Shows just the binders, used when reporting a bad telescope + -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint | DerivSkol Type -- Bound by a 'deriving' clause; -- the type is the instance we are trying to derive @@ -264,7 +268,7 @@ pprSkolInfo :: SkolemInfo -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx -pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> tvs +pprSkolInfo (ForAllSkol tvs) = text "an explicit forall" <+> ppr tvs pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) @@ -358,6 +362,32 @@ in the right place. So we proceed as follows: ************************************************************************ -} +-- | Some thing which has a type. +-- +-- This datatype is used when we want to report to the user +-- that something has an unexpected type. +data TypedThing + = HsTypeRnThing (HsType GhcRn) + | TypeThing Type + | HsExprRnThing (HsExpr GhcRn) + | NameThing Name + +-- | Some kind of type variable binder. +-- +-- Used for reporting errors, in 'SkolemInfo' and 'TcReportMsg'. +data TyVarBndrs + = forall flag. OutputableBndrFlag flag 'Renamed => + HsTyVarBndrsRn [HsTyVarBndr flag GhcRn] + +instance Outputable TypedThing where + ppr (HsTypeRnThing ty) = ppr ty + ppr (TypeThing ty) = ppr ty + ppr (HsExprRnThing expr) = ppr expr + ppr (NameThing name) = ppr name + +instance Outputable TyVarBndrs where + ppr (HsTyVarBndrsRn bndrs) = fsep (map ppr bndrs) + data CtOrigin = -- | A given constraint from a user-written type signature. The -- 'SkolemInfo' inside gives more information. @@ -404,9 +434,10 @@ data CtOrigin | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for -- function or instance + | TypeEqOrigin { uo_actual :: TcType , uo_expected :: TcType - , uo_thing :: Maybe SDoc + , uo_thing :: Maybe TypedThing -- ^ The thing that has type "actual" , uo_visible :: Bool -- ^ Is at least one of the three elements above visible? diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index a0b8106a8d..aa1a753369 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -89,7 +89,7 @@ import qualified Data.Semigroup as S ( (<>) ) -- returning an uninstantiated sigma-type matchActualFunTySigma :: SDoc -- See Note [Herald for matchExpectedFunTys] - -> Maybe SDoc -- The thing with type TcSigmaType + -> Maybe TypedThing -- The thing with type TcSigmaType -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and -- types of values args to which function has -- been applied already (reversed) @@ -190,7 +190,7 @@ Ugh! -- for example in function application matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys] -> CtOrigin - -> Maybe SDoc -- the thing with type TcSigmaType + -> Maybe TypedThing -- the thing with type TcSigmaType -> Arity -> TcSigmaType -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType) @@ -523,7 +523,7 @@ tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpR tcWrapResultO orig rn_expr expr actual_ty res_ty = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty , text "Expected:" <+> ppr res_ty ]) - ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty + ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty ; return (mkHsWrap wrap expr) } tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc @@ -545,7 +545,7 @@ unifyExpectedType :: HsExpr GhcRn unifyExpectedType rn_expr act_ty exp_ty = case exp_ty of Infer inf_res -> fillInferResult act_ty inf_res - Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty + Check exp_ty -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty ------------------------ tcSubTypePat :: CtOrigin -> UserTypeCtxt @@ -566,8 +566,8 @@ tcSubTypePat _ _ (Infer inf_res) ty_expected --------------- tcSubType :: CtOrigin -> UserTypeCtxt - -> TcSigmaType -- Actual - -> ExpRhoType -- Expected + -> TcSigmaType -- ^ Actual + -> ExpRhoType -- ^ Expected -> TcM HsWrapper -- Checks that 'actual' is more polymorphic than 'expected' tcSubType orig ctxt ty_actual ty_expected @@ -575,11 +575,11 @@ tcSubType orig ctxt ty_actual ty_expected do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } -tcSubTypeNC :: CtOrigin -- Used when instantiating - -> UserTypeCtxt -- Used when skolemising - -> Maybe SDoc -- The expression that has type 'actual' (if known) - -> TcSigmaType -- Actual type - -> ExpRhoType -- Expected type +tcSubTypeNC :: CtOrigin -- ^ Used when instantiating + -> UserTypeCtxt -- ^ Used when skolemising + -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known) + -> TcSigmaType -- ^ Actual type + -> ExpRhoType -- ^ Expected type -> TcM HsWrapper tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty = case res_ty of @@ -1071,7 +1071,7 @@ The exported functions are all defined as versions of some non-exported generic functions. -} -unifyType :: Maybe SDoc -- ^ If present, the thing that has type ty1 +unifyType :: Maybe TypedThing -- ^ If present, the thing that has type ty1 -> TcTauType -> TcTauType -- ty1, ty2 -> TcM TcCoercionN -- :: ty1 ~# ty2 -- Actual and expected types @@ -1081,7 +1081,7 @@ unifyType thing ty1 ty2 where origin = TypeEqOrigin { uo_actual = ty1 , uo_expected = ty2 - , uo_thing = ppr <$> thing + , uo_thing = thing , uo_visible = True } unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN @@ -1096,7 +1096,7 @@ unifyTypeET ty1 ty2 , uo_visible = True } -unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN +unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN unifyKind mb_thing ty1 ty2 = uType KindLevel origin ty1 ty2 where @@ -1820,8 +1820,7 @@ causing this wibble in behavior seen here. -- | Breaks apart a function kind into its pieces. matchExpectedFunKind - :: Outputable fun - => fun -- ^ type, only for errors + :: TypedThing -- ^ type, only for errors -> Arity -- ^ n: number of desired arrows -> TcKind -- ^ fun_ kind -> TcM Coercion -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res) @@ -1852,7 +1851,7 @@ matchExpectedFunKind hs_ty n k = go n k ; let new_fun = mkVisFunTysMany arg_kinds res_kind origin = TypeEqOrigin { uo_actual = k , uo_expected = new_fun - , uo_thing = Just (ppr hs_ty) + , uo_thing = Just hs_ty , uo_visible = True } ; uType KindLevel origin k new_fun } diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot index 7b4561420c..dc8bcce6e8 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs-boot +++ b/compiler/GHC/Tc/Utils/Unify.hs-boot @@ -4,15 +4,14 @@ import GHC.Prelude import GHC.Tc.Utils.TcType ( TcTauType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper ) -import GHC.Tc.Types.Origin ( CtOrigin ) -import GHC.Utils.Outputable( SDoc ) +import GHC.Tc.Types.Origin ( CtOrigin, TypedThing ) import GHC.Hs.Type ( Mult ) -- This boot file exists only to tie the knot between -- GHC.Tc.Utils.Unify and Inst -unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion -unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion +unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion +unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs index 519e55edb1..4182e40b3f 100644 --- a/compiler/GHC/Types/Hint.hs +++ b/compiler/GHC/Types/Hint.hs @@ -5,6 +5,10 @@ module GHC.Types.Hint ( , AvailableBindings(..) , InstantiationSuggestion(..) , LanguageExtensionHint(..) + , ImportSuggestion(..) + , HowInScope(..) + , SimilarName(..) + , StarIsType(..) , suggestExtension , suggestExtensionWithInfo , suggestExtensions @@ -12,6 +16,7 @@ module GHC.Types.Hint ( , suggestAnyExtension , suggestAnyExtensionWithInfo , useExtensionInOrderTo + , noStarIsTypeHints ) where import GHC.Prelude @@ -24,10 +29,14 @@ import Data.Typeable import GHC.Unit.Module (ModuleName, Module) import GHC.Hs.Extension (GhcTc) import GHC.Core.Coercion -import GHC.Types.Name (Name, NameSpace) +import GHC.Types.Name (Name, NameSpace, OccName (occNameFS)) +import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec) +import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Activation, RuleName) import GHC.Parser.Errors.Basic import {-# SOURCE #-} Language.Haskell.Syntax.Expr +import GHC.Unit.Module.Imported (ImportedModsVal) +import GHC.Data.FastString (fsLit) -- This {-# SOURCE #-} import should be removable once -- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'. @@ -237,7 +246,7 @@ data GhcHint Test case(s): wcompat-warnings/WCompatWarningsOn.hs -} - | SuggestUseTypeFromDataKind + | SuggestUseTypeFromDataKind (Maybe RdrName) {-| Suggests placing the 'qualified' keyword /after/ the module name. @@ -309,9 +318,9 @@ data GhcHint -} | SuggestFillInWildcardConstraint - {-| Suggests to use an identifier other than 'forall' - Triggered by: 'GHC.Tc.Errors.Types.TcRnForallIdentifier' - -} + {-| Suggests to use an identifier other than 'forall' + Triggered by: 'GHC.Tc.Errors.Types.TcRnForallIdentifier' + -} | SuggestRenameForall {-| Suggests to use the appropriate Template Haskell tick: @@ -321,6 +330,59 @@ data GhcHint Triggered by: 'GHC.Tc.Errors.Types.TcRnIncorrectNameSpace'. -} | SuggestAppropriateTHTick NameSpace + {-| Suggests enabling -ddump-splices to help debug an issue + when a 'Name' is not in scope or is used in multiple + different namespaces (e.g. both as a data constructor + and a type constructor). + + Concomitant with 'NoExactName' or 'SameName' errors, + see e.g. "GHC.Rename.Env.lookupExactOcc_either". + Test cases: T5971, T7241, T13937. + -} + | SuggestDumpSlices + + {-| Suggests adding a tick to refer to a data constructor + at the type level. + + Test case: T9778. + -} + | SuggestAddTick Name + + {-| Something is split off from its corresponding declaration. + For example, a datatype is given a role declaration + in a different module. + + Test cases: T495, T8485, T2713, T5533. + -} + | SuggestMoveToDeclarationSite + -- TODO: remove the SDoc argument. + SDoc -- ^ fixity declaration, role annotation, type signature, ... + RdrName -- ^ the 'RdrName' for the declaration site + + {-| Suggest a similar name that the user might have meant, + e.g. suggest 'traverse' when the user has written @travrese@. + + Test case: mod73. + -} + | SuggestSimilarNames RdrName (NE.NonEmpty SimilarName) + + {-| Remind the user that the field selector has been suppressed + because of -XNoFieldSelectors. + + Test cases: NFSSuppressed, records-nofieldselectors. + -} + | RemindFieldSelectorSuppressed + { suppressed_selector :: RdrName + , suppressed_parents :: [Name] } + + {-| Suggest importing from a module, removing a @hiding@ clause, + or explain to the user that we couldn't find a module + with the given 'ModuleName'. + + Test cases: mod28, mod36, mod87, mod114, ... + -} + | ImportSuggestion ImportSuggestion + -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way @@ -334,3 +396,101 @@ data GhcHint -- (Try passing -instantiated-with="MyStr=<MyStr>" -- replacing <MyStr> as necessary.) data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module + +-- | Suggest how to fix an import. +data ImportSuggestion + -- | Some module exports what we want, but we aren't explicitly importing it. + = CouldImportFrom (NE.NonEmpty (Module, ImportedModsVal)) OccName + -- | Some module exports what we want, but we are explicitly hiding it. + | CouldUnhideFrom (NE.NonEmpty (Module, ImportedModsVal)) OccName + +-- | Explain how something is in scope. +data HowInScope + -- | It was locally bound at this particular source location. + = LocallyBoundAt SrcSpan + -- | It was imported by this particular import declaration. + | ImportedBy ImpDeclSpec + +data SimilarName + = SimilarName Name + | SimilarRdrName RdrName HowInScope + +-------------------------------------------------------------------------------- + +-- | Whether '*' is a synonym for 'Data.Kind.Type'. +data StarIsType + = StarIsNotType + | StarIsType + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that they are working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'noStarIsTypeHints' returns appropriate hints to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, we will suggest using 'Data.Kind.Type'; otherwise we won't +-- suggest anything. +noStarIsTypeHints :: StarIsType -> RdrName -> [GhcHint] +noStarIsTypeHints is_star_type rdr_name + -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to + -- take star_is_type as input? Why not refactor? + -- + -- The reason is that `sdocOption sdocStarIsType` would indicate that + -- StarIsType is enabled in the module that tries to load the problematic + -- definition, not in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + | isUnqualStar + , StarIsNotType <- is_star_type + = [SuggestUseTypeFromDataKind (Just rdr_name)] + | otherwise + = [] + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs index a11be60209..9fd39e2a53 100644 --- a/compiler/GHC/Types/Hint/Ppr.hs +++ b/compiler/GHC/Types/Hint/Ppr.hs @@ -14,7 +14,10 @@ import GHC.Types.Hint import GHC.Hs.Expr () -- instance Outputable import GHC.Types.Id -import GHC.Types.Name (isValNameSpace) +import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace) +import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) +import GHC.Unit.Module.Imported (ImportedModsVal(..)) import GHC.Unit.Types import GHC.Utils.Outputable @@ -91,9 +94,16 @@ instance Outputable GhcHint where , whenPprDebug (ppr bad_rule) ] SuggestIncreaseSimplifierIterations -> text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit" - SuggestUseTypeFromDataKind + SuggestUseTypeFromDataKind mb_rdr_name -> text "Use" <+> quotes (text "Type") - <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + $$ + maybe empty + (\rdr_name -> + text "NB: with NoStarIsType, " <> quotes (ppr rdr_name) + <+> text "is treated as a regular type operator.") + mb_rdr_name + SuggestQualifiedAfterModuleName -> text "Place" <+> quotes (text "qualified") <+> text "after the module name." @@ -138,6 +148,105 @@ instance Outputable GhcHint where how_many | isValNameSpace ns = text "single" | otherwise = text "double" + SuggestDumpSlices + -> vcat [ text "If you bound a unique Template Haskell name (NameU)" + , text "perhaps via newName," + , text "then -ddump-splices might be useful." ] + SuggestAddTick name + -> hsep [ text "Use" + , quotes (char '\'' <> ppr name) + , text "instead of" + , quotes (ppr name) <> dot ] + SuggestMoveToDeclarationSite what rdr_name + -> text "Move the" <+> what <+> text "to the declaration site of" + <+> quotes (ppr rdr_name) <> dot + SuggestSimilarNames tried_rdr_name similar_names + -> case similar_names of + n NE.:| [] -> text "Perhaps use" <+> pp_item n + _ -> sep [ text "Perhaps use one of these:" + , nest 2 (pprWithCommas pp_item $ NE.toList similar_names) ] + where + tried_ns = occNameSpace $ rdrNameOcc tried_rdr_name + pp_item = pprSimilarName tried_ns + RemindFieldSelectorSuppressed rdr_name parents + -> text "Notice that" <+> quotes (ppr rdr_name) + <+> text "is a field selector" <+> whose + $$ text "that has been suppressed by NoFieldSelectors." + where + -- parents may be empty if this is a pattern synonym field without a selector + whose | null parents = empty + | otherwise = text "belonging to the type" <> plural parents + <+> pprQuotedList parents + ImportSuggestion import_suggestion + -> pprImportSuggestion import_suggestion perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" + +-- | Pretty-print an 'ImportSuggestion'. +pprImportSuggestion :: ImportSuggestion -> SDoc +pprImportSuggestion (CouldImportFrom mods occ_name) + | (mod, imv) NE.:| [] <- mods + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to the import list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | otherwise + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to one of these import lists:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- NE.toList mods + ]) +pprImportSuggestion (CouldUnhideFrom mods occ_name) + | (mod, imv) NE.:| [] <- mods + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the explicit hiding list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | otherwise + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the hiding clauses" + , text "in one of these imports:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- NE.toList mods + ]) + +-- | Pretty-print a 'SimilarName'. +pprSimilarName :: NameSpace -> SimilarName -> SDoc +pprSimilarName _ (SimilarName name) + = quotes (ppr name) <+> parens (pprDefinedAt name) +pprSimilarName tried_ns (SimilarRdrName rdr_name how_in_scope) + = case how_in_scope of + LocallyBoundAt loc -> + pp_ns rdr_name <+> quotes (ppr rdr_name) <+> loc' + where + loc' = case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) + ImportedBy is -> + pp_ns rdr_name <+> quotes (ppr rdr_name) <+> + parens (text "imported from" <+> ppr (is_mod is)) + + where + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = empty + where ns = rdrNameSpace rdr diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index 864101e8a9..05ea5a696b 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -71,11 +71,8 @@ module GHC.Types.Name.Reader ( ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), importSpecLoc, importSpecModule, isExplicitItem, bestImport, - -- * Utils for StarIsType - starInfo, - -- * Utils - opIsAt, + opIsAt ) where import GHC.Prelude @@ -1374,83 +1371,6 @@ pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty --- | Display info about the treatment of '*' under NoStarIsType. --- --- With StarIsType, three properties of '*' hold: --- --- (a) it is not an infix operator --- (b) it is always in scope --- (c) it is a synonym for Data.Kind.Type --- --- However, the user might not know that they are working on a module with --- NoStarIsType and write code that still assumes (a), (b), and (c), which --- actually do not hold in that module. --- --- Violation of (a) shows up in the parser. For instance, in the following --- examples, we have '*' not applied to enough arguments: --- --- data A :: * --- data F :: * -> * --- --- Violation of (b) or (c) show up in the renamer and the typechecker --- respectively. For instance: --- --- type K = Either * Bool --- --- This will parse differently depending on whether StarIsType is enabled, --- but it will parse nonetheless. With NoStarIsType it is parsed as a type --- operator, thus we have ((*) Either Bool). Now there are two cases to --- consider: --- --- 1. There is no definition of (*) in scope. In this case the renamer will --- fail to look it up. This is a violation of assumption (b). --- --- 2. There is a definition of the (*) type operator in scope (for example --- coming from GHC.TypeNats). In this case the user will get a kind --- mismatch error. This is a violation of assumption (c). --- --- The user might unknowingly be working on a module with NoStarIsType --- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a --- hint whenever an assumption about '*' is violated. Unfortunately, it is --- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). --- --- 'starInfo' generates an appropriate hint to the user depending on the --- extensions enabled in the module and the name that triggered the error. --- That is, if we have NoStarIsType and the error is related to '*' or its --- Unicode variant, the resulting SDoc will contain a helpful suggestion. --- Otherwise it is empty. --- -starInfo :: Bool -> RdrName -> SDoc -starInfo star_is_type rdr_name = - -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to - -- take star_is_type as input? Why not refactor? - -- - -- The reason is that `sdocOption sdocStarIsType` would indicate that - -- StarIsType is enabled in the module that tries to load the problematic - -- definition, not in the module that is being loaded. - -- - -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint - -- must be displayed even if we load this definition from a module (or GHCi) - -- with StarIsType enabled! - -- - if isUnqualStar && not star_is_type - then text "With NoStarIsType, " <> - quotes (ppr rdr_name) <> - text " is treated as a regular type operator. " - $$ - text "Did you mean to use " <> quotes (text "Type") <> - text " from Data.Kind instead?" - else empty - where - -- Does rdr_name look like the user might have meant the '*' kind by it? - -- We focus on unqualified stars specifically, because qualified stars are - -- treated as type operators even under StarIsType. - isUnqualStar - | Unqual occName <- rdr_name - = let fs = occNameFS occName - in fs == fsLit "*" || fs == fsLit "★" - | otherwise = False - -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool opIsAt e = e == mkUnqual varName (fsLit "@") |