diff options
| -rw-r--r-- | compiler/GHC/Rename/Bind.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/HsType.hs | 62 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Module.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Pat.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Splice.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Utils.hs | 72 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 98 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 115 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/HsType.hs | 18 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 1 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 1 | ||||
| -rw-r--r-- | testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr | 4 | ||||
| -rw-r--r-- | testsuite/tests/th/T15433_aux.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/th/T15433a.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/th/T15433a.stderr | 5 | ||||
| -rw-r--r-- | testsuite/tests/th/T15433b.hs | 20 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 2 |
18 files changed, 305 insertions, 122 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 19d27a33cf..adfceeef96 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -42,7 +42,7 @@ import GHC.Rename.Pat import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( HsDocContext(..), mapFvRn +import GHC.Rename.Utils ( mapFvRn , checkDupRdrNames, checkDupRdrNamesN , warnUnusedLocalBinds , warnForallIdentifier diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index b34581dd8e..6c7a55da1f 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -38,7 +38,7 @@ import GHC.Tc.Utils.Monad import GHC.Unit.Module ( getModule, isInteractiveModule ) import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames +import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames , bindLocalNames , mapMaybeFvRn, mapFvRn , warnUnusedLocalBinds, typeAppErr diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 1e1a0b538f..bf31991e8f 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -48,15 +48,15 @@ import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..), inHsDocContext, withHsDocContext - , mapFvRn, pprHsDocContext, bindLocalNamesFV +import GHC.Rename.Utils ( mapFvRn, bindLocalNamesFV , typeAppErr, newLocalBndrRn, checkDupRdrNamesN , 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.Errors.Ppr ( pprScopeError + , inHsDocContext, withHsDocContext, pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names @@ -291,10 +291,11 @@ checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () -- Check that extra-constraints are allowed at all, and -- if so that it's an anonymous wildcard checkExtraConstraintWildCard env hs_ctxt - = checkWildCard env mb_bad + = checkWildCard env Nothing mb_bad where mb_bad | not (extraConstraintWildCardsAllowed env) - = Just base_msg + = Just $ ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardNotAllowed -- Currently, we do not allow wildcards in their full glory in -- standalone deriving declarations. We only allow a single -- extra-constraints wildcard à la: @@ -306,18 +307,11 @@ checkExtraConstraintWildCard env hs_ctxt -- deriving instance (Eq a, _) => Eq (Foo a) | DerivDeclCtx {} <- rtke_ctxt env , not (null hs_ctxt) - = Just deriv_decl_msg + = Just $ ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardAllowed | otherwise = Nothing - base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard - <+> text "not allowed" - - deriv_decl_msg - = hang base_msg - 2 (vcat [ text "except as the sole constraint" - , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]) - extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool extraConstraintWildCardsAllowed env = case rtke_ctxt env of @@ -840,46 +834,39 @@ rnHsTyOp env overall_ty (L loc op) ; return (l_op', unitFV op') } -------------- -notAllowed :: SDoc -> SDoc -notAllowed doc - = text "Wildcard" <+> quotes doc <+> text "not allowed" - -checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () -checkWildCard env (Just doc) - = addErr $ TcRnUnknownMessage $ mkPlainError noHints $ - vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] -checkWildCard _ Nothing +checkWildCard :: RnTyKiEnv + -> Maybe Name -- ^ name of the wildcard, + -- or 'Nothing' for an anonymous wildcard + -> Maybe BadAnonWildcardContext + -> RnM () +checkWildCard env mb_name (Just bad) + = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env) +checkWildCard _ _ Nothing = return () checkAnonWildCard :: RnTyKiEnv -> RnM () -- Report an error if an anonymous wildcard is illegal here checkAnonWildCard env - = checkWildCard env mb_bad + = checkWildCard env Nothing mb_bad where - mb_bad :: Maybe SDoc + mb_bad :: Maybe BadAnonWildcardContext mb_bad | not (wildCardsAllowed env) - = Just (notAllowed pprAnonWildCard) + = Just WildcardsNotAllowedAtAll | otherwise = case rtke_what env of RnTypeBody -> Nothing - RnTopConstraint -> Just constraint_msg - RnConstraint -> Just constraint_msg - - constraint_msg = hang - (notAllowed pprAnonWildCard <+> text "in a constraint") - 2 hint_msg - hint_msg = vcat [ text "except as the last top-level constraint of a type signature" - , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + RnTopConstraint -> Just WildcardNotLastInConstraint + RnConstraint -> Just WildcardNotLastInConstraint checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () -- Report an error if a named wildcard is illegal here checkNamedWildCard env name - = checkWildCard env mb_bad + = checkWildCard env (Just name) mb_bad where mb_bad | not (name `elemNameSet` rtke_nwcs env) = Nothing -- Not a wildcard | not (wildCardsAllowed env) - = Just (notAllowed (ppr name)) + = Just WildcardsNotAllowedAtAll | otherwise = case rtke_what env of RnTypeBody -> Nothing -- Allowed @@ -887,8 +874,7 @@ checkNamedWildCard env name -- f :: (Eq _a) => _a -> Int -- g :: (_a, _b) => T _a _b -> Int -- The named tyvars get filled in from elsewhere - RnConstraint -> Just constraint_msg - constraint_msg = notAllowed (ppr name) <+> text "in a constraint" + RnConstraint -> Just WildcardNotLastInConstraint wildCardsAllowed :: RnTyKiEnv -> Bool -- ^ In what contexts are wildcards permitted diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 85f7467565..94864e8478 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -28,15 +28,16 @@ import GHC.Types.Name.Reader import GHC.Rename.HsType import GHC.Rename.Bind import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames +import GHC.Rename.Utils ( mapFvRn, bindLocalNames , checkDupRdrNamesN, bindLocalNamesFV , checkShadowedRdrNames, warnUnusedTypePatterns , newLocalBndrsRn - , withHsDocContext, noNestedForallsContextsErr + , noNestedForallsContextsErr , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 0f78a86b57..9eeaff6783 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -52,7 +52,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Zonk ( hsOverLitName ) import GHC.Rename.Env import GHC.Rename.Fixity -import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames +import GHC.Rename.Utils ( newLocalBndrRn, bindLocalNames , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard , checkDupNames, checkDupAndShadowedNames diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 97f5b2c2eb..54087c5b4e 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -22,7 +22,7 @@ import GHC.Tc.Utils.Monad import GHC.Driver.Env.Types import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) +import GHC.Rename.Utils ( newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 1647c19e32..597af3d778 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -21,8 +21,6 @@ module GHC.Rename.Utils ( badQualBndrErr, typeAppErr, badFieldConErr, wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType, genHsIntegralLit, genHsTyLit, - HsDocContext(..), pprHsDocContext, - inHsDocContext, withHsDocContext, newLocalBndrRn, newLocalBndrsRn, @@ -43,6 +41,7 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types +import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Error @@ -677,72 +676,3 @@ genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit) genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | StandaloneKindSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (LocatedN RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (LocatedN RdrName) - | TySynCtx (LocatedN RdrName) - | TyFamilyCtx (LocatedN RdrName) - | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [LocatedN Name] - | ClassDeclCtx (LocatedN RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | HsTypePatCtx - | GHCiCtx - | SpliceTypeCtx (LHsType GhcPs) - | ClassInstanceCtx - | GenericCtx SDoc -- Maybe we want to use this more! - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext HsTypePatCtx = text "a type argument in a pattern" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index a736a40871..2e535338e6 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -10,6 +10,10 @@ module GHC.Tc.Errors.Ppr -- , tidySkolemInfo , tidySkolemInfoAnon + -- + , withHsDocContext + , pprHsDocContext + , inHsDocContext ) where @@ -164,6 +168,53 @@ instance Diagnostic TcRnMessage where -> mkSimpleDecorated $ text "Illegal use of punning for field" <+> quotes (ppr fld) TcRnIllegalWildcardsInRecord fld_part -> mkSimpleDecorated $ text "Illegal `..' in record" <+> pprRecordFieldPart fld_part + TcRnIllegalWildcardInType mb_name bad mb_ctxt + -> mkSimpleDecorated $ vcat [ main_msg, context_msg ] + where + main_msg :: SDoc + main_msg = case bad of + WildcardNotLastInConstraint -> + hang notAllowed 2 constraint_hint_msg + ExtraConstraintWildcardNotAllowed allow_sole -> + case allow_sole of + SoleExtraConstraintWildcardNotAllowed -> + notAllowed + SoleExtraConstraintWildcardAllowed -> + hang notAllowed 2 sole_msg + WildcardsNotAllowedAtAll -> + notAllowed + context_msg :: SDoc + context_msg = case mb_ctxt of + Just ctxt -> nest 2 (text "in" <+> pprHsDocContext ctxt) + _ -> empty + notAllowed, what, wildcard, how :: SDoc + notAllowed = what <+> quotes wildcard <+> how + wildcard = case mb_name of + Nothing -> pprAnonWildCard + Just name -> ppr name + what + | Just _ <- mb_name + = text "Named wildcard" + | ExtraConstraintWildcardNotAllowed {} <- bad + = text "Extra-constraint wildcard" + | otherwise + = text "Wildcard" + how = case bad of + WildcardNotLastInConstraint + -> text "not allowed in a constraint" + _ -> text "not allowed" + constraint_hint_msg :: SDoc + constraint_hint_msg + | Just _ <- mb_name + = vcat [ text "Extra-constraint wildcards must be anonymous" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + | otherwise + = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + sole_msg :: SDoc + sole_msg = + vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ] TcRnDuplicateFieldName fld_part dups -> mkSimpleDecorated $ hsep [text "duplicate field name", @@ -691,6 +742,8 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnIllegalWildcardsInRecord{} -> ErrorWithoutFlag + TcRnIllegalWildcardInType{} + -> ErrorWithoutFlag TcRnDuplicateFieldName{} -> ErrorWithoutFlag TcRnIllegalViewPattern{} @@ -927,6 +980,8 @@ instance Diagnostic TcRnMessage where -> [suggestExtension LangExt.NamedFieldPuns] TcRnIllegalWildcardsInRecord{} -> [suggestExtension LangExt.RecordWildCards] + TcRnIllegalWildcardInType{} + -> noHints TcRnDuplicateFieldName{} -> noHints TcRnIllegalViewPattern{} @@ -2811,3 +2866,46 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 sameShapes _ _ = False + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +withHsDocContext :: HsDocContext -> SDoc -> SDoc +withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc +pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the rewrite rule" <+> doubleQuotes (ftext name) +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext HsTypePatCtx = text "a type argument in a pattern" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ClassInstanceCtx = text "GHC.Tc.Gen.Splice.reifyInstances" + +pprHsDocContext (ForeignDeclCtx name) + = text "the foreign declaration for" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 713232686f..d6004c7b96 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -26,6 +26,8 @@ module GHC.Tc.Errors.Types ( , DeriveInstanceBadConstructor(..) , HasWildcard(..) , hasWildcard + , BadAnonWildcardContext(..) + , SoleExtraConstraintWildcardAllowed(..) , DeriveGenericsErrReason(..) , HasAssociatedDataFamInsts(..) , hasAssociatedDataFamInsts @@ -35,6 +37,7 @@ module GHC.Tc.Errors.Types ( , associatedTyNotParamOverLastTyVar , MissingSignature(..) , Exported(..) + , HsDocContext(..) , ErrorItem(..), errorItemOrigin, errorItemEqRel, errorItemPred, errorItemCtLoc @@ -92,6 +95,7 @@ import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic import GHC.Utils.Misc (filterOut) import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.FastString (FastString) import qualified Data.List.NonEmpty as NE import Data.Typeable hiding (TyCon) @@ -426,6 +430,69 @@ data TcRnMessage where -} TcRnIllegalWildcardsInRecord :: !RecordFieldPart -> TcRnMessage + {-| TcRnIllegalWildcardInType is an error that occurs + when a wildcard appears in a type in a location in which + wildcards aren't allowed. + + Examples: + + Type synonyms: + + type T = _ + + Class declarations and instances: + + class C _ + instance C _ + + Standalone kind signatures: + + type D :: _ + data D + + Test cases: + ExtraConstraintsWildcardInTypeSplice2 + ExtraConstraintsWildcardInTypeSpliceUsed + ExtraConstraintsWildcardNotLast + ExtraConstraintsWildcardTwice + NestedExtraConstraintsWildcard + NestedNamedExtraConstraintsWildcard + PartialClassMethodSignature + PartialClassMethodSignature2 + T12039 + T13324_fail1 + UnnamedConstraintWildcard1 + UnnamedConstraintWildcard2 + WildcardInADT1 + WildcardInADT2 + WildcardInADT3 + WildcardInADTContext1 + WildcardInDefault + WildcardInDefaultSignature + WildcardInDeriving + WildcardInForeignExport + WildcardInForeignImport + WildcardInGADT1 + WildcardInGADT2 + WildcardInInstanceHead + WildcardInInstanceSig + WildcardInNewtype + WildcardInPatSynSig + WildcardInStandaloneDeriving + WildcardInTypeFamilyInstanceRHS + WildcardInTypeSynonymRHS + saks_fail003 + T15433a + -} + + TcRnIllegalWildcardInType + :: Maybe Name + -- ^ the wildcard name, or 'Nothing' for an anonymous wildcard + -> !BadAnonWildcardContext + -> !(Maybe HsDocContext) + -> TcRnMessage + + {-| TcRnDuplicateFieldName is an error that occurs whenever there are duplicate field names in a record. @@ -1812,6 +1879,19 @@ hasWildcard :: Bool -> HasWildcard hasWildcard True = YesHasWildcard hasWildcard False = NoHasWildcard +-- | A context in which we don't allow anonymous wildcards. +data BadAnonWildcardContext + = WildcardNotLastInConstraint + | ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardAllowed + | WildcardsNotAllowedAtAll + +-- | Whether a sole extra-constraint wildcard is allowed, +-- e.g. @_ => ..@ as opposed to @( .., _ ) => ..@. +data SoleExtraConstraintWildcardAllowed + = SoleExtraConstraintWildcardNotAllowed + | SoleExtraConstraintWildcardAllowed + -- | A type representing whether or not the input type has associated data family instances. data HasAssociatedDataFamInsts = YesHasAdfs @@ -2483,3 +2563,38 @@ pprRelevantBindings (RelevantBindings bds ran_out_of_fuel) = discardMsg :: SDoc discardMsg = text "(Some bindings suppressed;" <+> text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)" + + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- AZ:TODO: Change these all to be Name instead of RdrName. +-- Merge TcType.UserTypeContext in to it. +data HsDocContext + = TypeSigCtx SDoc + | StandaloneKindSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (LocatedN RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (LocatedN RdrName) + | TySynCtx (LocatedN RdrName) + | TyFamilyCtx (LocatedN RdrName) + | FamPatCtx (LocatedN RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [LocatedN Name] + | ClassDeclCtx (LocatedN RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | HsTypePatCtx + | GHCiCtx + | SpliceTypeCtx (LHsType GhcPs) + | ClassInstanceCtx + | GenericCtx SDoc diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 4463d25590..de16c657fd 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -2231,10 +2231,20 @@ tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) } HM_VTA -> False HM_TyAppPat -> False -tcAnonWildCardOcc _ mode ty _ --- mode_holes is Nothing. Should not happen, because renamer --- should already have rejected holes in unexpected places - = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty) +tcAnonWildCardOcc is_extra _ _ _ +-- mode_holes is Nothing. This means we have an anonymous wildcard +-- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard', +-- but it is possible for a wildcard to be introduced by a Template Haskell splice, +-- as per #15433. To account for this, we throw a generic catch-all error message. + = failWith $ TcRnIllegalWildcardInType Nothing reason Nothing + where + reason = + case is_extra of + YesExtraConstraint -> + ExtraConstraintWildcardNotAllowed + SoleExtraConstraintWildcardNotAllowed + NoExtraConstraint -> + WildcardsNotAllowedAtAll {- Note [Wildcard names] ~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index f2efb93f2d..2be524e1fc 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -83,7 +83,6 @@ import GHC.Runtime.Interpreter import GHC.Rename.Splice( traceSplice, SpliceInfo(..)) import GHC.Rename.Expr import GHC.Rename.Env -import GHC.Rename.Utils ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 11278d6bc7..aa43b7e4e0 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -91,7 +91,6 @@ import GHC.Tc.Utils.Backpack import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) ) import GHC.Rename.HsType import GHC.Rename.Expr -import GHC.Rename.Utils ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env diff --git a/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr index bd0cc8c3f8..c632d6eb64 100644 --- a/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NestedNamedExtraConstraintsWildcard.stderr @@ -1,4 +1,6 @@ NestedNamedExtraConstraintsWildcard.hs:4:23: error: - Wildcard ‘_a’ not allowed in a constraint + Named wildcard ‘_a’ not allowed in a constraint + Extra-constraint wildcards must be anonymous + e.g f :: (Eq a, _) => blah in the type signature for ‘foo’ diff --git a/testsuite/tests/th/T15433_aux.hs b/testsuite/tests/th/T15433_aux.hs new file mode 100644 index 0000000000..34973e7481 --- /dev/null +++ b/testsuite/tests/th/T15433_aux.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T15433_aux ( wild ) where + +import Language.Haskell.TH.Syntax + ( Q, Type ) + +wild :: Q Type +wild = [t| _ |] diff --git a/testsuite/tests/th/T15433a.hs b/testsuite/tests/th/T15433a.hs new file mode 100644 index 0000000000..f68c8efce0 --- /dev/null +++ b/testsuite/tests/th/T15433a.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} + +module T15433a where + +import T15433_aux ( wild ) + +type T = $wild diff --git a/testsuite/tests/th/T15433a.stderr b/testsuite/tests/th/T15433a.stderr new file mode 100644 index 0000000000..13efe8c376 --- /dev/null +++ b/testsuite/tests/th/T15433a.stderr @@ -0,0 +1,5 @@ + +T15433a.hs:7:11: error: + • Wildcard ‘_’ not allowed + • In the type ‘(_)’ + In the type declaration for ‘T’ diff --git a/testsuite/tests/th/T15433b.hs b/testsuite/tests/th/T15433b.hs new file mode 100644 index 0000000000..a661ad04e5 --- /dev/null +++ b/testsuite/tests/th/T15433b.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell, TypeApplications, TypeFamilies, PartialTypeSignatures #-} + +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +module T15433b where + +import T15433_aux ( wild ) + +type family F a where + F $wild = Int + +f :: Maybe a -> Maybe a +f (x :: Maybe $wild) = x + +g :: forall a. Maybe a -> Maybe a +g (Just @($wild) x) = Just x +g Nothing = Nothing + +h :: a -> $wild +h x = x diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index ebf4c0f1bf..165ef6a7e2 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -546,3 +546,5 @@ test('T20773', only_ways(['ghci']), ghci_script, ['T20773.script']) test('T20884', normal, compile_fail, ['']) test('T21038', normal, compile, ['']) test('T20842', normal, compile_and_run, ['']) +test('T15433a', [extra_files(['T15433_aux.hs'])], multimod_compile_fail, ['T15433a', '-v0']) +test('T15433b', [extra_files(['T15433_aux.hs'])], multimod_compile, ['T15433b', '-v0']) |