Simon Peyton Jones pushed to branch wip/ani/kill-SrcCodeOrigin at Glasgow Haskell Compiler / GHC Commits: 5cca9b8d by Simon Peyton Jones at 2026-02-27T00:44:47+00:00 Improvements in ErrCtxt - - - - - 24 changed files: - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/Bind.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Match.hs-boot - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/TyCl/Class.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/BasicTypes.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Types/Origin.hs-boot - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs Changes: ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -21,6 +21,7 @@ import GHC.Driver.Session import GHC.Tc.Errors.Types import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..) ) import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils import GHC.Tc.Deriv.Generate @@ -695,7 +696,7 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo = setSrcSpanA loc $ addErrCtxt (StandaloneDerivCtxt deriv_ty) $ do { traceTc "Standalone deriving decl for" (ppr deriv_ty) - ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True + ; let ctxt = GHC.Tc.Types.ErrCtxt.InstDeclCtxt True ; traceTc "Deriving strategy (standalone deriving)" $ vcat [ppr mb_lderiv_strat, ppr deriv_ty] ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -37,6 +37,7 @@ import GHC.Tc.Deriv.Generics import GHC.Tc.Errors.Types import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt( InstDeclCtxt, DerivClauseCtxt ) ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Unify (tcSubTypeSigma) ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Tc.Zonk.Type import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.TcType import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( redundantConstraintsSpan ) import GHC.Tc.Types.Evidence import GHC.Tc.Instance.Family import GHC.Tc.Utils.Instantiate ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -7703,11 +7703,17 @@ pprErrCtxtMsg = \case make_lines_msg [last] = ppr last <> dot make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot make_lines_msg (l:ls) = l <> comma $$ make_lines_msg ls + PatSigErrCtxt sig_ty res_ty -> vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") - 2 (ppr res_ty)) ] + , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ] + where + -- Zonking will have turned Infer into Check + pp_res_ty = case res_ty of + Check ty -> ppr ty + Infer ir -> text "OOPS" <+> ppr ir + PatCtxt pat -> hang (text "In the pattern:") 2 (ppr pat) PatSynDeclCtxt name -> ===================================== compiler/GHC/Tc/Errors/Types.hs ===================================== @@ -184,7 +184,7 @@ import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence (EvBindsVar) import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Origin ( CtOrigin (ProvCtxtOrigin), SkolemInfoAnon (SigSkol) - , UserTypeCtxt (PatSynCtxt), TyVarBndrs, TypedThing + , TyVarBndrs, TypedThing , FixedRuntimeRepOrigin(..), InstanceWhat ) import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin, SubGoalDepth ) import GHC.Tc.Types.Rank (Rank) ===================================== compiler/GHC/Tc/Gen/Bind.hs ===================================== @@ -35,6 +35,7 @@ import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Unify import GHC.Tc.Solver ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -41,6 +41,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint( WantedConstraints ) import GHC.Tc.Utils.TcType as TcType ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -52,6 +52,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt( GenSigCtxt ), pprUserTypeCtxt ) import GHC.Tc.Types.Evidence import GHC.Rename.Env ( irrefutableConLikeTc ) ===================================== compiler/GHC/Tc/Gen/Match.hs-boot ===================================== @@ -2,7 +2,7 @@ module GHC.Tc.Gen.Match where import GHC.Hs ( GRHSs, MatchGroup, LHsExpr, Mult ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType, ExpPatType ) import GHC.Tc.Types ( TcM ) -import GHC.Tc.Types.Origin ( UserTypeCtxt ) +import GHC.Tc.Types.ErrCtxt ( UserTypeCtxt ) import GHC.Tc.Types.Evidence ( HsWrapper ) import GHC.Types.Name ( Name ) import GHC.Hs.Extension ( GhcRn, GhcTc ) ===================================== compiler/GHC/Tc/Gen/Pat.hs ===================================== @@ -1021,8 +1021,7 @@ tcPatSig in_pat_bind sig res_ty ; case NE.nonEmpty sig_tvs of Nothing -> do { -- Just do the subsumption check and return - msg <- mk_msg res_ty sig_ty - ; wrap <- addErrCtxtM msg $ + ; wrap <- addErrCtxtM (PatSigErrCtxt sig_ty res_ty) $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty ; return (sig_ty, [], sig_wcs, wrap) } @@ -1036,17 +1035,12 @@ tcPatSig in_pat_bind sig res_ty (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne)) -- Now do a subsumption check of the pattern signature against res_ty - msg <- mk_msg res_ty sig_ty - wrap <- addErrCtxtM msg $ + wrap <- addErrCtxtM (PatSigErrCtxt sig_ty res_ty) $ tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty -- Phew! return (sig_ty, sig_tvs, sig_wcs, wrap) } - where - mk_msg res_ty sig_ty - = do { res_ty <- readExpType res_ty -- should be filled in by now - ; return $ PatSigErrCtxt sig_ty res_ty } {- ********************************************************************* * * ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -50,6 +50,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -65,6 +65,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Instance.Family import GHC.Tc.Gen.Annotation ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -23,6 +23,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc( ctLocEnv, ctLocOrigin, setCtLocOrigin ) import GHC.Tc.Types import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..), reportRedundantConstraints ) import GHC.Tc.Types.Constraint import GHC.Tc.Types.CtLoc( mkGivenLoc ) import GHC.Tc.Solver.InertSet ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -58,6 +58,7 @@ import GHC.Tc.Instance.Family import GHC.Tc.Types.ErrCtxt ( TyConInstFlavour(..) ) import GHC.Tc.Types.LclEnv import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Builtin.Types ( oneDataConTy, unitTy, makeRecoveryTyCon, manyDataConTy ) ===================================== compiler/GHC/Tc/TyCl/Class.hs ===================================== @@ -38,6 +38,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -38,6 +38,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( ReportRedundantConstraints(..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Instantiate import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated ) ===================================== compiler/GHC/Tc/TyCl/PatSyn.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..) ) import GHC.Tc.TyCl.Build import GHC.Core.Multiplicity ===================================== compiler/GHC/Tc/Types/BasicTypes.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Tc.Types.BasicTypes ( import GHC.Prelude -import GHC.Tc.Types.Origin( UserTypeCtxt ) +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt ) import GHC.Tc.Utils.TcType import GHC.Types.Id ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -120,6 +120,7 @@ import GHC.Types.Var import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.CtLoc import GHC.Builtin.Names ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -4,6 +4,11 @@ module GHC.Tc.Types.ErrCtxt ( ErrCtxt (..), ErrCtxtMsg(..), CodeSrcFlag (..) , UserSigType(..), FunAppCtxtFunArg(..) , TyConInstFlavour(..) + + -- * UserTypeCtxt + , UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe + , ReportRedundantConstraints(..), reportRedundantConstraints + , redundantConstraintsSpan, ) where @@ -16,12 +21,12 @@ import GHC.Hs.Extension import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA ) import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt ) -import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin, UserTypeCtxt ) -import {-# SOURCE #-} GHC.Tc.Utils.TcType ( TcType, TcTyCon ) +import {-# SOURCE #-} GHC.Tc.Types.Origin ( CtOrigin ) +import GHC.Tc.Utils.TcType ( TcType, TcTyCon, ExpType ) import GHC.Types.Basic ( TyConFlavour ) import GHC.Types.Name ( Name ) -import GHC.Types.SrcLoc ( SrcSpan ) +import GHC.Types.SrcLoc ( SrcSpan, noSrcSpan ) import GHC.Types.Var ( Id, TyCoVar ) import GHC.Unit.Types ( Module, InstantiatedModule ) @@ -35,7 +40,7 @@ import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType ) import {-# SOURCE #-} GHC.Unit.State ( UnitState ) -- Break the module graph cycle for accesing ErrCtxtMsg in GHC.Hs.Expr import GHC.Data.FastString ( FastString ) -import GHC.Utils.Outputable ( Outputable(..) ) +import GHC.Utils.Outputable import Language.Haskell.Syntax import Language.Haskell.Syntax.Basic ( FieldLabelString(..) ) @@ -43,6 +48,156 @@ import GHC.Boot.TH.Syntax qualified as TH import qualified Data.List.NonEmpty as NE +{- ********************************************************************* +* * + UserTypeCtxt +* * +********************************************************************* -} + +------------------------------------- +-- | UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need an expression to have that type +data UserTypeCtxt + = FunSigCtxt -- Function type signature, when checking the type + -- Also used for types in SPECIALISE pragmas + Name -- Name of the function + ReportRedundantConstraints + -- See Note [Tracking needed EvIds] in GHC.Tc.Solver + -- This field is usually 'WantRCC', but 'NoRCC' for + -- * Record selectors (not important here) + -- * Class and instance methods. Here the code may legitimately + -- be more polymorphic than the signature generated from the + -- class declaration + -- * Functions whose type signature has hidden the constraints + -- behind a type synonym. E.g. + -- type Foo = forall a. Eq a => a -> a + -- id :: Foo + -- id x = x + -- Here we can't give a good location for the redundant constraints + -- (see lhsSigWcTypeContextSpan), so we don't report redundant + -- constraints at all. It's not clear that this a good choice; + -- perhaps we should report, just with a less informative SrcSpan. + -- c.f. #16154 + + | InfSigCtxt Name -- Inferred type for function + | ExprSigCtxt -- Expression type signature + ReportRedundantConstraints + | KindSigCtxt -- Kind signature + | StandaloneKindSigCtxt -- Standalone kind signature + Name -- Name of the type/class + | TypeAppCtxt -- Visible type application + | ConArgCtxt Name -- Data constructor argument + | TySynCtxt Name -- RHS of a type synonym decl + | PatSynCtxt Name -- Type sig for a pattern synonym + | PatSigCtxt -- Type sig in pattern + -- eg f (x::t) = ... + -- or (x::t, y) = e + | ForSigCtxt Name -- Foreign import or export signature + | DefaultDeclCtxt -- Class or types in a default declaration + | InstDeclCtxt Bool -- An instance declaration + -- True: stand-alone deriving + -- False: vanilla instance declaration + | SpecInstCtxt -- SPECIALISE instance pragma + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + | GhciCtxt Bool -- GHCi command :kind <type> + -- The Bool indicates if we are checking the outermost + -- type application. + -- See Note [Unsaturated type synonyms in GHCi] in + -- GHC.Tc.Validity. + + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: <S> => a -> a + | DataTyCtxt Name -- The "stupid theta" part of a data decl + -- data <S> => T a = MkT a + | DerivClauseCtxt -- A 'deriving' clause + | TyVarBndrKindCtxt Name -- The kind of a type variable being bound + | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE + -- or SPECIALISE pragma + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... + | DataKindCtxt Name -- The kind of a data/newtype (instance) + | TySynKindCtxt Name -- The kind of the RHS of a type synonym + | TyFamResKindCtxt Name -- The result kind of a type family + deriving( Eq ) -- Just for checkSkolInfoAnon + +-- | Report Redundant Constraints. +data ReportRedundantConstraints + = NoRRC -- ^ Don't report redundant constraints + + | WantRRC SrcSpan -- ^ Report redundant constraints + -- The SrcSpan is for the constraints + -- E.g. f :: (Eq a, Ord b) => blah + -- The span is for the (Eq a, Ord b) + -- We need to record the span here because we have + -- long since discarded the HsType in favour of a Type + + deriving( Eq ) -- Just for checkSkolInfoAnon + +reportRedundantConstraints :: ReportRedundantConstraints -> Bool +reportRedundantConstraints NoRRC = False +reportRedundantConstraints (WantRRC {}) = True + +redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan +redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span +redundantConstraintsSpan (ExprSigCtxt (WantRRC span)) = span +redundantConstraintsSpan _ = noSrcSpan + +{- +-- Notes re TySynCtxt +-- We allow type synonyms that aren't types; e.g. type List = [] +-- +-- If the RHS mentions tyvars that aren't in scope, we'll +-- quantify over them: +-- e.g. type T = a->a +-- will become type T = forall a. a->a +-- +-- With gla-exts that's right, but for H98 we should complain. +-} + + +pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" +pprUserTypeCtxt KindSigCtxt = text "a kind signature" +pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a `default' declaration" +pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" +pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) +pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) +pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" +pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) +pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) + +isSigMaybe :: UserTypeCtxt -> Maybe Name +isSigMaybe (FunSigCtxt n _) = Just n +isSigMaybe (ConArgCtxt n) = Just n +isSigMaybe (ForSigCtxt n) = Just n +isSigMaybe (PatSynCtxt n) = Just n +isSigMaybe _ = Nothing + + +{- ********************************************************************* +* * + ErrCtxt +* * +********************************************************************* -} -------------------------------------------------------------------------------- -- type ErrCtxtMsgM = TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg) @@ -113,7 +268,7 @@ data ErrCtxtMsg -- | In the instance type signature of a class method. | MethSigCtxt !Name !TcType !TcType -- | In a pattern type signature. - | PatSigErrCtxt !TcType !TcType + | PatSigErrCtxt !TcType !ExpType -- | In a pattern. | PatCtxt !(Pat GhcRn) -- | In a pattern synonym declaration. ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -3,11 +3,6 @@ -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation. module GHC.Tc.Types.Origin ( - -- * UserTypeCtxt - UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, - ReportRedundantConstraints(..), reportRedundantConstraints, - redundantConstraintsSpan, - -- * SkolemInfo, SkolemInfoAnon SkolemInfo(..), SkolemInfoAnon(..), mkSkolemInfo, getSkolemInfo, pprSigSkolInfo, pprSkolInfo, unkSkol, unkSkolAnon, isStaticSkolInfo, @@ -83,150 +78,6 @@ import qualified Data.Kind as Hs import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isNothing) -{- ********************************************************************* -* * - UserTypeCtxt -* * -********************************************************************* -} - -------------------------------------- --- | UserTypeCtxt describes the origin of the polymorphic type --- in the places where we need an expression to have that type -data UserTypeCtxt - = FunSigCtxt -- Function type signature, when checking the type - -- Also used for types in SPECIALISE pragmas - Name -- Name of the function - ReportRedundantConstraints - -- See Note [Tracking needed EvIds] in GHC.Tc.Solver - -- This field is usually 'WantRCC', but 'NoRCC' for - -- * Record selectors (not important here) - -- * Class and instance methods. Here the code may legitimately - -- be more polymorphic than the signature generated from the - -- class declaration - -- * Functions whose type signature has hidden the constraints - -- behind a type synonym. E.g. - -- type Foo = forall a. Eq a => a -> a - -- id :: Foo - -- id x = x - -- Here we can't give a good location for the redundant constraints - -- (see lhsSigWcTypeContextSpan), so we don't report redundant - -- constraints at all. It's not clear that this a good choice; - -- perhaps we should report, just with a less informative SrcSpan. - -- c.f. #16154 - - | InfSigCtxt Name -- Inferred type for function - | ExprSigCtxt -- Expression type signature - ReportRedundantConstraints - | KindSigCtxt -- Kind signature - | StandaloneKindSigCtxt -- Standalone kind signature - Name -- Name of the type/class - | TypeAppCtxt -- Visible type application - | ConArgCtxt Name -- Data constructor argument - | TySynCtxt Name -- RHS of a type synonym decl - | PatSynCtxt Name -- Type sig for a pattern synonym - | PatSigCtxt -- Type sig in pattern - -- eg f (x::t) = ... - -- or (x::t, y) = e - | ForSigCtxt Name -- Foreign import or export signature - | DefaultDeclCtxt -- Class or types in a default declaration - | InstDeclCtxt Bool -- An instance declaration - -- True: stand-alone deriving - -- False: vanilla instance declaration - | SpecInstCtxt -- SPECIALISE instance pragma - | GenSigCtxt -- Higher-rank or impredicative situations - -- e.g. (f e) where f has a higher-rank type - -- We might want to elaborate this - | GhciCtxt Bool -- GHCi command :kind <type> - -- The Bool indicates if we are checking the outermost - -- type application. - -- See Note [Unsaturated type synonyms in GHCi] in - -- GHC.Tc.Validity. - - | ClassSCCtxt Name -- Superclasses of a class - | SigmaCtxt -- Theta part of a normal for-all type - -- f :: <S> => a -> a - | DataTyCtxt Name -- The "stupid theta" part of a data decl - -- data <S> => T a = MkT a - | DerivClauseCtxt -- A 'deriving' clause - | TyVarBndrKindCtxt Name -- The kind of a type variable being bound - | RuleBndrTypeCtxt Name -- The type of a term variable being bound in a RULE - -- or SPECIALISE pragma - -- RULE "foo" forall (x :: a -> a). f (Just x) = ... - | DataKindCtxt Name -- The kind of a data/newtype (instance) - | TySynKindCtxt Name -- The kind of the RHS of a type synonym - | TyFamResKindCtxt Name -- The result kind of a type family - deriving( Eq ) -- Just for checkSkolInfoAnon - --- | Report Redundant Constraints. -data ReportRedundantConstraints - = NoRRC -- ^ Don't report redundant constraints - - | WantRRC SrcSpan -- ^ Report redundant constraints - -- The SrcSpan is for the constraints - -- E.g. f :: (Eq a, Ord b) => blah - -- The span is for the (Eq a, Ord b) - -- We need to record the span here because we have - -- long since discarded the HsType in favour of a Type - - deriving( Eq ) -- Just for checkSkolInfoAnon - -reportRedundantConstraints :: ReportRedundantConstraints -> Bool -reportRedundantConstraints NoRRC = False -reportRedundantConstraints (WantRRC {}) = True - -redundantConstraintsSpan :: UserTypeCtxt -> SrcSpan -redundantConstraintsSpan (FunSigCtxt _ (WantRRC span)) = span -redundantConstraintsSpan (ExprSigCtxt (WantRRC span)) = span -redundantConstraintsSpan _ = noSrcSpan - -{- --- Notes re TySynCtxt --- We allow type synonyms that aren't types; e.g. type List = [] --- --- If the RHS mentions tyvars that aren't in scope, we'll --- quantify over them: --- e.g. type T = a->a --- will become type T = forall a. a->a --- --- With gla-exts that's right, but for H98 we should complain. --} - - -pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) -pprUserTypeCtxt (ExprSigCtxt _) = text "an expression type signature" -pprUserTypeCtxt KindSigCtxt = text "a kind signature" -pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n) -pprUserTypeCtxt TypeAppCtxt = text "a type argument" -pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) -pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" -pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) -pprUserTypeCtxt DefaultDeclCtxt = text "a `default' declaration" -pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" -pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" -pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" -pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" -pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" -pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) -pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" -pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) -pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) -pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" -pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) -pprUserTypeCtxt (RuleBndrTypeCtxt n) = text "the type signature for" <+> quotes (ppr n) -pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) -pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) - -isSigMaybe :: UserTypeCtxt -> Maybe Name -isSigMaybe (FunSigCtxt n _) = Just n -isSigMaybe (ConArgCtxt n) = Just n -isSigMaybe (ForSigCtxt n) = Just n -isSigMaybe (PatSynCtxt n) = Just n -isSigMaybe _ = Nothing - {- ************************************************************************ * * ===================================== compiler/GHC/Tc/Types/Origin.hs-boot ===================================== @@ -5,7 +5,6 @@ import GHC.Utils.Misc ( HasDebugCallStack ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) data CtOrigin -data UserTypeCtxt data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -76,6 +76,8 @@ import GHC.Tc.Types.CtLoc , tyConAppRoleExplanation, appTyRoleExplanation ) import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt( UserTypeCtxt(..), ReportRedundantConstraints(..) + , pprUserTypeCtxt ) import GHC.Tc.Zonk.TcType import GHC.Tc.Utils.TcMType qualified as TcM ===================================== compiler/GHC/Tc/Validity.hs ===================================== @@ -26,6 +26,7 @@ import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), AssocInstInfo import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family import GHC.Tc.Types.Origin +import GHC.Tc.Types.ErrCtxt import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types import GHC.Tc.Types.Constraint ( userTypeError_maybe ) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cca9b8d98d6842b8a7c963499c175f8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5cca9b8d98d6842b8a7c963499c175f8... You're receiving this email because of your account on gitlab.haskell.org.