[Git][ghc/ghc][master] Add structured error messages for GHC.Tc.Utils.Env
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Mar 21 15:19:02 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
eeea0343 by Torsten Schmits at 2023-03-21T11:18:34-04:00
Add structured error messages for GHC.Tc.Utils.Env
Tracking ticket: #20119
MR: !10129
This converts uses of `mkTcRnUnknownMessage` to newly added constructors
of `TcRnMessage`.
- - - - -
29 changed files:
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Rename/Splice.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Solver/Interact.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types.hs-boot
- compiler/GHC/Tc/Types/Origin.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Validity.hs
- compiler/GHC/Types/Error/Codes.hs
- testsuite/tests/annotations/should_fail/annfail03.stderr
- testsuite/tests/annotations/should_fail/annfail04.stderr
- testsuite/tests/annotations/should_fail/annfail06.stderr
- testsuite/tests/annotations/should_fail/annfail09.stderr
- testsuite/tests/quasiquotation/qq001/qq001.stderr
- testsuite/tests/quasiquotation/qq002/qq002.stderr
- testsuite/tests/quasiquotation/qq003/qq003.stderr
- testsuite/tests/quasiquotation/qq004/qq004.stderr
- testsuite/tests/th/T17820a.stderr
- testsuite/tests/th/T17820b.stderr
- testsuite/tests/th/T17820c.stderr
- testsuite/tests/th/T17820d.stderr
- testsuite/tests/th/T17820e.stderr
- testsuite/tests/th/T21547.stderr
- testsuite/tests/th/T5795.stderr
Changes:
=====================================
compiler/GHC/Core/InstEnv.hs
=====================================
@@ -7,7 +7,7 @@
The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv.
-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
module GHC.Core.InstEnv (
DFunId, InstMatch, ClsInstLookupResult,
@@ -19,6 +19,7 @@ module GHC.Core.InstEnv (
fuzzyClsInstCmp, orphNamesOfClsInst,
InstEnvs(..), VisibleOrphanModules, InstEnv,
+ LookupInstanceErrReason (..),
mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,
filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,
anyInstEnv,
@@ -51,6 +52,7 @@ import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Basic
import GHC.Types.Id
+import GHC.Generics (Generic)
import Data.Data ( Data )
import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
import qualified Data.List.NonEmpty as NE
@@ -928,18 +930,28 @@ anyone noticing, so it's manifestly not ruining anyone's day.)
-- yield 'Left errorMessage'.
lookupUniqueInstEnv :: InstEnvs
-> Class -> [Type]
- -> Either SDoc (ClsInst, [Type])
+ -> Either LookupInstanceErrReason (ClsInst, [Type])
lookupUniqueInstEnv instEnv cls tys
= case lookupInstEnv False instEnv cls tys of
([(inst, inst_tys)], _, _)
| noFlexiVar -> Right (inst, inst_tys')
- | otherwise -> Left $ text "flexible type variable:" <+>
- (ppr $ mkTyConApp (classTyCon cls) tys)
+ | otherwise -> Left $ LookupInstErrFlexiVar
where
inst_tys' = [ty | Just ty <- inst_tys]
noFlexiVar = all isJust inst_tys
- _other -> Left $ text "instance not found" <+>
- (ppr $ mkTyConApp (classTyCon cls) tys)
+ _other -> Left $ LookupInstErrNotFound
+
+-- | Why a particular typeclass application couldn't be looked up.
+data LookupInstanceErrReason =
+ -- | Tyvars aren't an exact match.
+ LookupInstErrNotExact
+ |
+ -- | One of the tyvars is flexible.
+ LookupInstErrFlexiVar
+ |
+ -- | No matching instance was found.
+ LookupInstErrNotFound
+ deriving (Generic)
data Coherence = IsCoherent | IsIncoherent
=====================================
compiler/GHC/Rename/Splice.hs
=====================================
@@ -915,7 +915,7 @@ checkThLocalName name
Nothing -> return () ; -- Not a locally-bound thing
Just (top_lvl, bind_lvl, use_stage) ->
do { let use_lvl = thLevel use_stage
- ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
+ ; checkWellStaged (StageCheckSplice name) bind_lvl use_lvl
; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
<+> ppr use_stage
<+> ppr use_lvl)
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -43,7 +43,7 @@ import GHC.Core.Type
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env
+-- import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Types.Error
import GHC.Types.Name
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -20,6 +20,7 @@ module GHC.Tc.Errors.Ppr
, pprHsDocContext
, inHsDocContext
, TcRnMessageOpts(..)
+ , pprTyThingUsedWrong
)
where
@@ -51,7 +52,7 @@ import GHC.Hs
import GHC.Tc.Errors.Types
import GHC.Tc.Types.Constraint
-import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )
+import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode, TcTyThing )
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank (Rank(..))
import GHC.Tc.Utils.TcType
@@ -100,6 +101,7 @@ import Data.Ord ( comparing )
import Data.Bifunctor
import GHC.Types.Name.Env
import qualified Language.Haskell.TH as TH
+import {-# SOURCE #-} GHC.Tc.Types (pprTcTyThingCategory)
data TcRnMessageOpts = TcRnMessageOpts { tcOptsShowContext :: !Bool -- ^ Whether we show the error context or not
}
@@ -665,6 +667,10 @@ instance Diagnostic TcRnMessage where
TcRnCannotDeriveInstance cls cls_tys mb_strat newtype_deriving reason
-> mkSimpleDecorated $
derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving True reason
+ TcRnLookupInstance cls tys reason
+ -> mkSimpleDecorated $
+ text "Couldn't match instance:" <+>
+ lookupInstanceErrDiagnosticMessage cls tys reason
TcRnLazyGADTPattern
-> mkSimpleDecorated $
hang (text "An existential or GADT data constructor cannot be used")
@@ -1433,6 +1439,20 @@ instance Diagnostic TcRnMessage where
hsep [ text "Unknown type variable" <> plural errorVars
, text "on the RHS of injectivity condition:"
, interpp'SP errorVars ]
+ TcRnBadlyStaged reason bind_lvl use_lvl
+ -> mkSimpleDecorated $
+ text "Stage error:" <+> pprStageCheckReason reason <+>
+ hsep [text "is bound at stage" <+> ppr bind_lvl,
+ text "but used at stage" <+> ppr use_lvl]
+ TcRnStageRestriction reason
+ -> mkSimpleDecorated $
+ sep [ text "GHC stage restriction:"
+ , nest 2 (vcat [ pprStageCheckReason reason <+>
+ text "is used in a top-level splice, quasi-quote, or annotation,"
+ , text "and must be imported, not defined locally"])]
+ TcRnTyThingUsedWrong sort thing name
+ -> mkSimpleDecorated $
+ pprTyThingUsedWrong sort thing name
diagnosticReason = \case
TcRnUnknownMessage m
@@ -1655,6 +1675,8 @@ instance Diagnostic TcRnMessage where
DerivErrBadConstructor{} -> ErrorWithoutFlag
DerivErrGenerics{} -> ErrorWithoutFlag
DerivErrEnumOrProduct{} -> ErrorWithoutFlag
+ TcRnLookupInstance _ _ _
+ -> ErrorWithoutFlag
TcRnLazyGADTPattern
-> ErrorWithoutFlag
TcRnArrowProcGADTPattern
@@ -1903,6 +1925,12 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> ErrorWithoutFlag
+ TcRnBadlyStaged{}
+ -> ErrorWithoutFlag
+ TcRnStageRestriction{}
+ -> ErrorWithoutFlag
+ TcRnTyThingUsedWrong{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -2123,6 +2151,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnCannotDeriveInstance cls _ _ newtype_deriving rea
-> deriveInstanceErrReasonHints cls newtype_deriving rea
+ TcRnLookupInstance _ _ _
+ -> noHints
TcRnLazyGADTPattern
-> noHints
TcRnArrowProcGADTPattern
@@ -2391,6 +2421,12 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnUnknownTyVarsOnRhsOfInjCond{}
-> noHints
+ TcRnBadlyStaged{}
+ -> noHints
+ TcRnStageRestriction{}
+ -> noHints
+ TcRnTyThingUsedWrong{}
+ -> noHints
diagnosticCode = constructorCode
@@ -2770,6 +2806,18 @@ derivErrDiagnosticMessage cls cls_tys mb_strat newtype_deriving pprHerald = \cas
in cannotMakeDerivedInstanceHerald cls cls_tys mb_strat newtype_deriving pprHerald
(ppr1 $$ text " or" $$ ppr2)
+lookupInstanceErrDiagnosticMessage :: Class
+ -> [Type]
+ -> LookupInstanceErrReason
+ -> SDoc
+lookupInstanceErrDiagnosticMessage cls tys = \case
+ LookupInstErrNotExact
+ -> text "Not an exact match (i.e., some variables get instantiated)"
+ LookupInstErrFlexiVar
+ -> text "flexible type variable:" <+> (ppr $ mkTyConApp (classTyCon cls) tys)
+ LookupInstErrNotFound
+ -> text "instance not found" <+> (ppr $ mkTyConApp (classTyCon cls) tys)
+
{- *********************************************************************
* *
Outputable SolverReportErrCtxt (for debugging)
@@ -3833,6 +3881,10 @@ pprScopeError rdr_name scope_err =
2 (what <+> quotes (ppr rdr_name) <+> text "in this module")
UnknownSubordinate doc ->
quotes (ppr rdr_name) <+> text "is not a (visible)" <+> doc
+ NotInScopeTc env ->
+ vcat[text "GHC internal error:" <+> quotes (ppr rdr_name) <+>
+ text "is not in scope during type checking, but it passed the renamer",
+ text "tcl_env of environment:" <+> ppr env]
where
what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
@@ -3845,6 +3897,7 @@ scopeErrorHints scope_err =
MissingBinding _ hints -> hints
NoTopLevelBinding -> noHints
UnknownSubordinate {} -> noHints
+ NotInScopeTc _ -> noHints
{- *********************************************************************
* *
@@ -4429,3 +4482,26 @@ pprConversionFailReason = \case
text "Function binding for"
<+> quotes (text (TH.pprint nm))
<+> text "has no equations"
+
+pprTyThingUsedWrong :: WrongThingSort -> TcTyThing -> Name -> SDoc
+pprTyThingUsedWrong sort thing name =
+ pprTcTyThingCategory thing <+> quotes (ppr name) <+>
+ text "used as a" <+> pprWrongThingSort sort
+
+pprWrongThingSort :: WrongThingSort -> SDoc
+pprWrongThingSort =
+ text . \case
+ WrongThingType -> "type"
+ WrongThingDataCon -> "data constructor"
+ WrongThingPatSyn -> "pattern synonym"
+ WrongThingConLike -> "constructor-like thing"
+ WrongThingClass -> "class"
+ WrongThingTyCon -> "type constructor"
+ WrongThingAxiom -> "axiom"
+
+pprStageCheckReason :: StageCheckReason -> SDoc
+pprStageCheckReason = \case
+ StageCheckInstance _ t ->
+ text "instance for" <+> quotes (ppr t)
+ StageCheckSplice t ->
+ quotes (ppr t)
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -92,6 +92,8 @@ module GHC.Tc.Errors.Types (
, NonStandardGuards(..)
, RuleLhsErrReason(..)
, HsigShapeMismatchReason(..)
+ , WrongThingSort(..)
+ , StageCheckReason(..)
) where
import GHC.Prelude
@@ -103,7 +105,7 @@ import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Evidence (EvBindsVar)
import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol)
, UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing
- , FixedRuntimeRepOrigin(..) )
+ , FixedRuntimeRepOrigin(..), InstanceWhat )
import GHC.Tc.Types.Rank (Rank)
import GHC.Tc.Utils.TcType (IllegalForeignTypeReason, TcType)
import GHC.Types.Avail (AvailInfo)
@@ -125,7 +127,7 @@ import GHC.Core.Coercion.Axiom (CoAxBranch)
import GHC.Core.ConLike (ConLike)
import GHC.Core.DataCon (DataCon)
import GHC.Core.FamInstEnv (FamInst)
-import GHC.Core.InstEnv (ClsInst)
+import GHC.Core.InstEnv (LookupInstanceErrReason, ClsInst)
import GHC.Core.PatSyn (PatSyn)
import GHC.Core.Predicate (EqRel, predTypeEqRel)
import GHC.Core.TyCon (TyCon, TyConFlavour)
@@ -146,6 +148,7 @@ import GHC.Unit.Module.Warnings (WarningTxt)
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Generics ( Generic )
+import GHC.Types.Name.Env (NameEnv)
{-
Note [Migrating TcM Messages]
@@ -3209,6 +3212,51 @@ data TcRnMessage where
-}
TcRnUnknownTyVarsOnRhsOfInjCond :: [Name] -> TcRnMessage
+ {-| TcRnLookupInstance groups several errors emitted when looking up class instances.
+
+ Test cases:
+ none
+ -}
+ TcRnLookupInstance
+ :: !Class
+ -> ![Type]
+ -> !LookupInstanceErrReason
+ -> TcRnMessage
+
+ {-| TcRnBadlyStaged is an error that occurs when a TH binding is used in an
+ invalid stage.
+
+ Test cases:
+ T17820d
+ -}
+ TcRnBadlyStaged
+ :: !StageCheckReason -- ^ The binding being spliced.
+ -> !Int -- ^ The binding stage.
+ -> !Int -- ^ The stage at which the binding is used.
+ -> TcRnMessage
+
+ {-| TcRnStageRestriction is an error that occurs when a top level splice refers to
+ a local name.
+
+ Test cases:
+ T17820, T21547, T5795, qq00[1-4], annfail0{3,4,6,9}
+ -}
+ TcRnStageRestriction
+ :: !StageCheckReason -- ^ The binding being spliced.
+ -> TcRnMessage
+
+ {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another
+ thing was expected.
+
+ Test cases:
+ none
+ -}
+ TcRnTyThingUsedWrong
+ :: !WrongThingSort -- ^ Expected thing.
+ -> !TcTyThing -- ^ Thing used wrongly.
+ -> !Name -- ^ Name of the thing used wrongly.
+ -> TcRnMessage
+
deriving Generic
-- | Things forbidden in @type data@ declarations.
@@ -4173,6 +4221,12 @@ data NotInScopeError
-- or, a class doesn't have an associated type with this name,
-- or, a record doesn't have a record field with this name.
| UnknownSubordinate SDoc
+
+ -- | A name is not in scope during type checking but passed the renamer.
+ --
+ -- Test cases:
+ -- none
+ | NotInScopeTc (NameEnv TcTyThing)
deriving Generic
-- | Create a @"not in scope"@ error message for the given 'RdrName'.
@@ -4471,3 +4525,16 @@ data HsigShapeMismatchReason =
-}
HsigShapeNotUnifiable !Name !Name !Bool
deriving (Generic)
+
+data WrongThingSort
+ = WrongThingType
+ | WrongThingDataCon
+ | WrongThingPatSyn
+ | WrongThingConLike
+ | WrongThingClass
+ | WrongThingTyCon
+ | WrongThingAxiom
+
+data StageCheckReason
+ = StageCheckInstance !InstanceWhat !PredType
+ | StageCheckSplice !Name
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -1994,7 +1994,7 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon
APromotionErr err -> promotionErr name err
- _ -> wrongThingErr "type" thing name }
+ _ -> wrongThingErr WrongThingType thing name }
{-
Note [Recursion through the kinds]
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -4,7 +4,7 @@
module GHC.Tc.Instance.Class (
matchGlobalInst,
ClsInstResult(..),
- InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
+ safeOverlap, instanceReturnsDictCon,
AssocInstInfo(..), isNotAssociated,
) where
@@ -21,6 +21,7 @@ import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType)
import GHC.Tc.Instance.Typeable
import GHC.Tc.Utils.TcMType
import GHC.Tc.Types.Evidence
+import GHC.Tc.Types.Origin (InstanceWhat (..), SafeOverlapping)
import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
import GHC.Rename.Env( addUsedGRE )
@@ -31,7 +32,7 @@ import GHC.Builtin.Names
import GHC.Types.FieldLabel
import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )
import GHC.Types.SafeHaskell
-import GHC.Types.Name ( Name, pprDefinedAt )
+import GHC.Types.Name ( Name )
import GHC.Types.Var.Env ( VarEnv )
import GHC.Types.Id
import GHC.Types.Var
@@ -86,13 +87,6 @@ isNotAssociated (InClsInst {}) = False
* *
**********************************************************************-}
--- | Indicates if Instance met the Safe Haskell overlapping instances safety
--- check.
---
--- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver
--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
-type SafeOverlapping = Bool
-
data ClsInstResult
= NoInstance -- Definitely no instance
@@ -103,23 +97,6 @@ data ClsInstResult
| NotSure -- Multiple matches and/or one or more unifiers
-data InstanceWhat -- How did we solve this constraint?
- = BuiltinEqInstance -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2
- -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
-
- | BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn)
- -- See Note [Well-staged instance evidence]
-
- | BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is
- -- KnownNat, .. etc (classes with no top-level evidence)
-
- | LocalInstance -- Solved by a quantified constraint
- -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
-
- | TopLevInstance -- Solved by a top-level instance decl
- { iw_dfun_id :: DFunId
- , iw_safe_over :: SafeOverlapping }
-
instance Outputable ClsInstResult where
ppr NoInstance = text "NoInstance"
ppr NotSure = text "NotSure"
@@ -127,15 +104,6 @@ instance Outputable ClsInstResult where
, cir_what = what })
= text "OneInst" <+> vcat [ppr ev, ppr what]
-instance Outputable InstanceWhat where
- ppr BuiltinInstance = text "a built-in instance"
- ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"
- ppr BuiltinEqInstance = text "a built-in equality instance"
- ppr LocalInstance = text "a locally-quantified instance"
- ppr (TopLevInstance { iw_dfun_id = dfun })
- = hang (text "instance" <+> pprSigmaType (idType dfun))
- 2 (text "--" <+> pprDefinedAt (idName dfun))
-
safeOverlap :: InstanceWhat -> Bool
safeOverlap (TopLevInstance { iw_safe_over = so }) = so
safeOverlap _ = True
=====================================
compiler/GHC/Tc/Solver/Interact.hs
=====================================
@@ -16,7 +16,7 @@ import GHC.Tc.Utils.TcType
import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )
import GHC.Tc.Instance.FunDeps
import GHC.Tc.Instance.Family
-import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap )
+import GHC.Tc.Instance.Class ( safeOverlap )
import GHC.Tc.Types.Evidence
import GHC.Utils.Outputable
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -134,7 +134,7 @@ import qualified GHC.Tc.Utils.Env as TcM
import GHC.Driver.Session
-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )
+import GHC.Tc.Instance.Class( safeOverlap, instanceReturnsDictCon )
import GHC.Tc.Utils.TcType
import GHC.Tc.Solver.Types
import GHC.Tc.Solver.InertSet
@@ -1420,11 +1420,9 @@ checkWellStagedDFun loc what pred
Just bind_lvl | bind_lvl > impLevel ->
wrapTcS $ TcM.setCtLocM loc $ do
{ use_stage <- TcM.getStage
- ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
+ ; TcM.checkWellStaged (StageCheckInstance what pred) bind_lvl (thLevel use_stage) }
_ ->
return ()
- where
- pp_thing = text "instance for" <+> quotes (ppr pred)
-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)
-- See Note [Well-staged instance evidence]
=====================================
compiler/GHC/Tc/Types.hs-boot
=====================================
@@ -22,3 +22,4 @@ setLclEnvLoc :: TcLclEnv -> RealSrcSpan -> TcLclEnv
getLclEnvLoc :: TcLclEnv -> RealSrcSpan
lclEnvInGeneratedCode :: TcLclEnv -> Bool
+pprTcTyThingCategory :: TcTyThing -> SDoc
=====================================
compiler/GHC/Tc/Types/Origin.hs
=====================================
@@ -35,6 +35,8 @@ module GHC.Tc.Types.Origin (
FRRArrowContext(..), pprFRRArrowContext,
ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald,
+ -- InstanceWhat
+ InstanceWhat(..), SafeOverlapping
) where
import GHC.Prelude
@@ -1401,3 +1403,42 @@ pprExpectedFunTyHerald (ExpectedFunTyLam match)
pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)
= sep [ text "The function" <+> quotes (ppr expr)
, text "requires" ]
+
+{- *******************************************************************
+* *
+ InstanceWhat
+* *
+**********************************************************************-}
+
+-- | Indicates if Instance met the Safe Haskell overlapping instances safety
+-- check.
+--
+-- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver
+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
+type SafeOverlapping = Bool
+
+data InstanceWhat -- How did we solve this constraint?
+ = BuiltinEqInstance -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2
+ -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
+
+ | BuiltinTypeableInstance TyCon -- Built-in solver for Typeable (T t1 .. tn)
+ -- See Note [Well-staged instance evidence]
+
+ | BuiltinInstance -- Built-in solver for (C t1 .. tn) where C is
+ -- KnownNat, .. etc (classes with no top-level evidence)
+
+ | LocalInstance -- Solved by a quantified constraint
+ -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
+
+ | TopLevInstance -- Solved by a top-level instance decl
+ { iw_dfun_id :: DFunId
+ , iw_safe_over :: SafeOverlapping }
+
+instance Outputable InstanceWhat where
+ ppr BuiltinInstance = text "a built-in instance"
+ ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"
+ ppr BuiltinEqInstance = text "a built-in equality instance"
+ ppr LocalInstance = text "a locally-quantified instance"
+ ppr (TopLevInstance { iw_dfun_id = dfun })
+ = hang (text "instance" <+> pprSigmaType (idType dfun))
+ 2 (text "--" <+> pprDefinedAt (idName dfun))
=====================================
compiler/GHC/Tc/Utils/Env.hs
=====================================
@@ -60,6 +60,7 @@ module GHC.Tc.Utils.Env(
tcGetDefaultTys,
-- Template Haskell stuff
+ StageCheckReason(..),
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, isBrackStage,
@@ -67,7 +68,7 @@ module GHC.Tc.Utils.Env(
newDFunName,
newFamInstTyConName, newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
- mkWrapperName
+ mkWrapperName,
) where
import GHC.Prelude
@@ -129,8 +130,8 @@ import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Name.Reader
import GHC.Types.TyThing
-import GHC.Types.Error
import qualified GHC.LanguageExtensions as LangExt
+import GHC.Tc.Errors.Ppr (pprTyThingUsedWrong)
import Data.IORef
import Data.List (intercalate)
@@ -192,21 +193,22 @@ importDecl_maybe hsc_env name
| otherwise
= initIfaceLoad hsc_env (importDecl name)
+-- | A 'TyThing'... except it's not the right sort.
+type WrongTyThing = TyThing
+
ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon hsc_env name = do
mb_thing <- ioLookupDataCon_maybe hsc_env name
case mb_thing of
Succeeded thing -> return thing
- Failed msg -> pprPanic "lookupDataConIO" msg
+ Failed thing -> pprPanic "lookupDataConIO" (pprTyThingUsedWrong WrongThingDataCon (AGlobal thing) name)
-ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr WrongTyThing DataCon)
ioLookupDataCon_maybe hsc_env name = do
thing <- lookupGlobal hsc_env name
return $ case thing of
AConLike (RealDataCon con) -> Succeeded con
- _ -> Failed $
- pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
- text "used as a data constructor"
+ _ -> Failed thing
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds tcg_env binds
@@ -274,42 +276,42 @@ tcLookupDataCon name = do
thing <- tcLookupGlobal name
case thing of
AConLike (RealDataCon con) -> return con
- _ -> wrongThingErr "data constructor" (AGlobal thing) name
+ _ -> wrongThingErr WrongThingDataCon (AGlobal thing) name
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn name = do
thing <- tcLookupGlobal name
case thing of
AConLike (PatSynCon ps) -> return ps
- _ -> wrongThingErr "pattern synonym" (AGlobal thing) name
+ _ -> wrongThingErr WrongThingPatSyn (AGlobal thing) name
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
- _ -> wrongThingErr "constructor-like thing" (AGlobal thing) name
+ _ -> wrongThingErr WrongThingConLike (AGlobal thing) name
tcLookupClass :: Name -> TcM Class
tcLookupClass name = do
thing <- tcLookupGlobal name
case thing of
ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
- _ -> wrongThingErr "class" (AGlobal thing) name
+ _ -> wrongThingErr WrongThingClass (AGlobal thing) name
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon name = do
thing <- tcLookupGlobal name
case thing of
ATyCon tc -> return tc
- _ -> wrongThingErr "type constructor" (AGlobal thing) name
+ _ -> wrongThingErr WrongThingTyCon (AGlobal thing) name
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom name = do
thing <- tcLookupGlobal name
case thing of
ACoAxiom ax -> return ax
- _ -> wrongThingErr "axiom" (AGlobal thing) name
+ _ -> wrongThingErr WrongThingAxiom (AGlobal thing) name
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = addLocMA tcLookupId
@@ -326,17 +328,13 @@ tcLookupLocatedTyCon = addLocMA tcLookupTyCon
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance cls tys
= do { instEnv <- tcGetInstEnvs
- ; case lookupUniqueInstEnv instEnv cls tys of
- Left err ->
- failWithTc $ mkTcRnUnknownMessage
- $ mkPlainError noHints (text "Couldn't match instance:" <+> err)
- Right (inst, tys)
- | uniqueTyVars tys -> return inst
- | otherwise -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact)
+ ; let inst = lookupUniqueInstEnv instEnv cls tys >>= \ (inst, tys) ->
+ if uniqueTyVars tys then Right inst else Left LookupInstErrNotExact
+ ; case inst of
+ Right i -> return i
+ Left err -> failWithTc (TcRnLookupInstance cls tys err)
}
where
- errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
-
uniqueTyVars tys = all isTyVarTy tys
&& hasNoDups (map getTyVar tys)
@@ -886,7 +884,7 @@ tcExtendRules lcl_rules thing_inside
************************************************************************
-}
-checkWellStaged :: SDoc -- What the stage check is for
+checkWellStaged :: StageCheckReason -- What the stage check is for
-> ThLevel -- Binding level (increases inside brackets)
-> ThLevel -- Use stage
-> TcM () -- Fail if badly staged, adding an error
@@ -895,22 +893,11 @@ checkWellStaged pp_thing bind_lvl use_lvl
= return () -- E.g. \x -> [| $(f x) |]
| bind_lvl == outerLevel -- GHC restriction on top level splices
- = stageRestrictionError pp_thing
+ = failWithTc (TcRnStageRestriction pp_thing)
| otherwise -- Badly staged
= failWithTc $ -- E.g. \x -> $(f x)
- mkTcRnUnknownMessage $ mkPlainError noHints $
- text "Stage error:" <+> pp_thing <+>
- hsep [text "is bound at stage" <+> ppr bind_lvl,
- text "but used at stage" <+> ppr use_lvl]
-
-stageRestrictionError :: SDoc -> TcM a
-stageRestrictionError pp_thing
- = failWithTc $
- mkTcRnUnknownMessage $ mkPlainError noHints $
- sep [ text "GHC stage restriction:"
- , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
- , text "and must be imported, not defined locally"])]
+ TcRnBadlyStaged pp_thing bind_lvl use_lvl
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
@@ -1173,12 +1160,9 @@ notFound name
Splice {}
| isUnboundName name -> failM -- If the name really isn't in scope
-- don't report it again (#11941)
- | otherwise -> stageRestrictionError (quotes (ppr name))
+ | otherwise -> failWithTc (TcRnStageRestriction (StageCheckSplice name))
_ -> failWithTc $
- mkTcRnUnknownMessage $ mkPlainError noHints $
- vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
- text "is not in scope during type checking, but it passed the renamer",
- text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
+ mkTcRnNotInScope (getRdrName name) (NotInScopeTc (tcl_env lcl_env))
-- Take care: printing the whole gbl env can
-- cause an infinite loop, in the case where we
-- are in the middle of a recursive TyCon/Class group;
@@ -1186,12 +1170,9 @@ notFound name
-- very unhelpful, because it hides one compiler bug with another
}
-wrongThingErr :: String -> TcTyThing -> Name -> TcM a
-wrongThingErr expected thing name
- = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $
- (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
- text "used as a" <+> text expected)
- in failWithTc msg
+wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
+wrongThingErr expected thing name =
+ failWithTc (TcRnTyThingUsedWrong expected thing name)
{- Note [Out of scope might be a staging error]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Validity.hs
=====================================
@@ -27,7 +27,7 @@ import GHC.Data.Maybe
-- friends:
import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity )
import GHC.Tc.Solver ( simplifyAmbiguityCheck )
-import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )
+import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo(..) )
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Exts ( proxy# )
import GHC.Generics
import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) )
import GHC.TypeNats ( Nat, KnownNat, natVal' )
+import GHC.Core.InstEnv (LookupInstanceErrReason)
{- Note [Diagnostic codes]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -535,6 +536,9 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnShadowedTyVarNameInFamResult" = 99412
GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond" = 88333
GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond" = 48254
+ GhcDiagnosticCode "TcRnBadlyStaged" = 28914
+ GhcDiagnosticCode "TcRnStageRestriction" = 18157
+ GhcDiagnosticCode "TcRnTyThingUsedWrong" = 10969
-- IllegalNewtypeReason
GhcDiagnosticCode "DoesNotHaveSingleField" = 23517
@@ -595,6 +599,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "MissingBinding" = 44432
GhcDiagnosticCode "NoTopLevelBinding" = 10173
GhcDiagnosticCode "UnknownSubordinate" = 54721
+ GhcDiagnosticCode "NotInScopeTc" = 76329
-- Diagnostic codes for deriving
GhcDiagnosticCode "DerivErrNotWellKinded" = 62016
@@ -625,6 +630,11 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "DerivErrGenerics" = 30367
GhcDiagnosticCode "DerivErrEnumOrProduct" = 58291
+ -- Diagnostic codes for instance lookup
+ GhcDiagnosticCode "LookupInstErrNotExact" = 10372
+ GhcDiagnosticCode "LookupInstErrFlexiVar" = 10373
+ GhcDiagnosticCode "LookupInstErrNotFound" = 10374
+
-- TcRnEmptyStmtsGroupError/EmptyStatementGroupErrReason
GhcDiagnosticCode "EmptyStmtsGroupInParallelComp" = 41242
GhcDiagnosticCode "EmptyStmtsGroupInTransformListComp" = 92693
@@ -693,6 +703,7 @@ type family ConRecursInto con where
ConRecursInto "TcRnWithHsDocContext" = 'Just TcRnMessage
ConRecursInto "TcRnCannotDeriveInstance" = 'Just DeriveInstanceErrReason
+ ConRecursInto "TcRnLookupInstance" = 'Just LookupInstanceErrReason
ConRecursInto "TcRnPragmaWarning" = 'Just (WarningTxt GhcRn)
ConRecursInto "TcRnNotInScope" = 'Just NotInScopeError
ConRecursInto "TcRnIllegalNewtype" = 'Just IllegalNewtypeReason
=====================================
testsuite/tests/annotations/should_fail/annfail03.stderr
=====================================
@@ -1,5 +1,5 @@
-annfail03.hs:17:11:
+annfail03.hs:17:11: [GHC-18157]
GHC stage restriction:
‘InModule’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/annotations/should_fail/annfail04.stderr
=====================================
@@ -1,5 +1,5 @@
-annfail04.hs:14:12:
+annfail04.hs:14:12: [GHC-18157]
GHC stage restriction:
instance for ‘Thing
Int’ is used in a top-level splice, quasi-quote, or annotation,
=====================================
testsuite/tests/annotations/should_fail/annfail06.stderr
=====================================
@@ -1,5 +1,5 @@
-annfail06.hs:22:1:
+annfail06.hs:22:1: [GHC-18157]
GHC stage restriction:
instance for ‘Data
InstancesInWrongModule’ is used in a top-level splice, quasi-quote, or annotation,
=====================================
testsuite/tests/annotations/should_fail/annfail09.stderr
=====================================
@@ -1,5 +1,5 @@
-annfail09.hs:11:11:
+annfail09.hs:11:11: [GHC-18157]
GHC stage restriction:
‘g’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/quasiquotation/qq001/qq001.stderr
=====================================
@@ -1,5 +1,5 @@
-qq001.hs:7:16:
+qq001.hs:7:16: [GHC-18157]
GHC stage restriction:
‘parse’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/quasiquotation/qq002/qq002.stderr
=====================================
@@ -1,5 +1,5 @@
-qq002.hs:8:10:
+qq002.hs:8:10: [GHC-18157]
GHC stage restriction:
‘parse’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/quasiquotation/qq003/qq003.stderr
=====================================
@@ -1,5 +1,5 @@
-qq003.hs:5:26:
+qq003.hs:5:26: [GHC-18157]
GHC stage restriction:
‘parse’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/quasiquotation/qq004/qq004.stderr
=====================================
@@ -1,5 +1,5 @@
-qq004.hs:8:21:
+qq004.hs:8:21: [GHC-18157]
GHC stage restriction:
‘parse’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/th/T17820a.stderr
=====================================
@@ -1,5 +1,5 @@
-T17820a.hs:7:17: error:
+T17820a.hs:7:17: error: [GHC-18157]
GHC stage restriction:
‘C’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/th/T17820b.stderr
=====================================
@@ -1,5 +1,5 @@
-T17820b.hs:7:17: error:
+T17820b.hs:7:17: error: [GHC-18157]
GHC stage restriction:
‘f’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/th/T17820c.stderr
=====================================
@@ -1,5 +1,5 @@
-T17820c.hs:8:18: error:
+T17820c.hs:8:18: error: [GHC-18157]
GHC stage restriction:
‘meth’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/th/T17820d.stderr
=====================================
@@ -1,5 +1,5 @@
-T17820d.hs:6:38: error:
+T17820d.hs:6:38: error: [GHC-28914]
• Stage error: ‘foo’ is bound at stage 2 but used at stage 1
• In the untyped splice: $(const [| 0 |] foo)
In the Template Haskell quotation
=====================================
testsuite/tests/th/T17820e.stderr
=====================================
@@ -1,5 +1,5 @@
-T17820e.hs:9:17: error:
+T17820e.hs:9:17: error: [GHC-18157]
GHC stage restriction:
‘C’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
=====================================
testsuite/tests/th/T21547.stderr
=====================================
@@ -1,5 +1,5 @@
-T21547.hs:9:14: error:
+T21547.hs:9:14: error: [GHC-18157]
• GHC stage restriction:
instance for ‘base-4.16.0.0:Data.Typeable.Internal.Typeable
T’ is used in a top-level splice, quasi-quote, or annotation,
=====================================
testsuite/tests/th/T5795.stderr
=====================================
@@ -1,5 +1,5 @@
-T5795.hs:9:7: error:
+T5795.hs:9:7: error: [GHC-18157]
• GHC stage restriction:
‘ty’ is used in a top-level splice, quasi-quote, or annotation,
and must be imported, not defined locally
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eeea0343f1bd5e3359c32c10fffb2a300c4924ba
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/eeea0343f1bd5e3359c32c10fffb2a300c4924ba
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230321/3d0e3680/attachment-0001.html>
More information about the ghc-commits
mailing list