Convert More Diagnostics (#20116)

Replaces uses of `TcRnUnknownMessage` with proper diagnostics
constructors.

2 files changed, 458 insertions, 2 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index dee1a99775..86aac8d99d 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -21,6 +21,8 @@ module GHC.Tc.Errors.Ppr
 import GHC.Prelude
 
 import GHC.Builtin.Names
+import GHC.Builtin.Types (boxedRepDataConTyCon)
+import GHC.Builtin.Types.Prim (tYPETyCon)
 
 import GHC.Core.Coercion
 import GHC.Core.Unify     ( tcMatchTys )
@@ -802,6 +804,100 @@ instance Diagnostic TcRnMessage where
     TcRnInvalidCIdentifier target
       -> mkSimpleDecorated $
            sep [quotes (ppr target) <+> text "is not a valid C identifier"]
+    TcRnExpectedValueId thing
+      -> mkSimpleDecorated $
+           ppr thing <+> text "used where a value identifier was expected"
+    TcRnNotARecordSelector field
+      -> mkSimpleDecorated $
+           hsep [quotes (ppr field), text "is not a record selector"]
+    TcRnRecSelectorEscapedTyVar lbl
+      -> mkSimpleDecorated $
+           text "Cannot use record selector" <+> quotes (ppr lbl) <+>
+           text "as a function due to escaped type variables"
+    TcRnPatSynNotBidirectional name
+      -> mkSimpleDecorated $
+           text "non-bidirectional pattern synonym"
+           <+> quotes (ppr name) <+> text "used in an expression"
+    TcRnSplicePolymorphicLocalVar ident
+      -> mkSimpleDecorated $
+           text "Can't splice the polymorphic local variable" <+> quotes (ppr ident)
+    TcRnIllegalDerivingItem hs_ty
+      -> mkSimpleDecorated $
+           text "Illegal deriving item" <+> quotes (ppr hs_ty)
+    TcRnUnexpectedAnnotation ty bang
+      -> mkSimpleDecorated $
+           let err = case bang of
+                 HsSrcBang _ SrcUnpack _           -> "UNPACK"
+                 HsSrcBang _ SrcNoUnpack _         -> "NOUNPACK"
+                 HsSrcBang _ NoSrcUnpack SrcLazy   -> "laziness"
+                 HsSrcBang _ _ _                   -> "strictness"
+            in text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
+               text err <+> text "annotation cannot appear nested inside a type"
+    TcRnIllegalRecordSyntax ty
+      -> mkSimpleDecorated $
+           text "Record syntax is illegal here:" <+> ppr ty
+    TcRnUnexpectedTypeSplice ty
+      -> mkSimpleDecorated $
+           text "Unexpected type splice:" <+> ppr ty
+    TcRnInvalidVisibleKindArgument arg ty
+      -> mkSimpleDecorated $
+           text "Cannot apply function of kind" <+> quotes (ppr ty)
+             $$ text "to visible kind argument" <+> quotes (ppr arg)
+    TcRnTooManyBinders ki bndrs
+      -> mkSimpleDecorated $
+           hang (text "Not a function kind:")
+              4 (ppr ki) $$
+           hang (text "but extra binders found:")
+              4 (fsep (map ppr bndrs))
+    TcRnDifferentNamesForTyVar n1 n2
+      -> mkSimpleDecorated $
+           hang (text "Different names for the same type variable:") 2 info
+         where
+           info | nameOccName n1 /= nameOccName n2
+                = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)
+                | otherwise -- Same OccNames! See C2 in
+                            -- Note [Swizzling the tyvars before generaliseTcTyCon]
+                = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)
+                       , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]
+    TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext
+      -> mkSimpleDecorated $
+           sep [ ppDataSort data_sort <+>
+                 text "has non-" <>
+                 allowed_kind_tycon
+               , (if is_data_family then text "and non-variable" else empty) <+>
+                 text "return kind" <+> quotes (ppr kind)
+               ]
+         where
+          is_data_family =
+            case data_sort of
+              DataDeclSort{}     -> False
+              DataInstanceSort{} -> False
+              DataFamilySort     -> True
+          allowed_kind_tycon =
+            case allowed_kind of
+              AnyTYPEKind  -> ppr tYPETyCon
+              AnyBoxedKind -> ppr boxedRepDataConTyCon
+              LiftedKind   -> ppr liftedTypeKind
+    TcRnClassKindNotConstraint _kind
+      -> mkSimpleDecorated $
+           text "Kind signature on a class must end with" <+> ppr constraintKind $$
+           text "unobscured by type families"
+    TcRnUnpromotableThing name err
+      -> mkSimpleDecorated $
+           (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")
+                        2 (parens reason))
+        where
+          reason = case err of
+                     ConstrainedDataConPE pred
+                                    -> text "it has an unpromotable context"
+                                       <+> quotes (ppr pred)
+                     FamDataConPE   -> text "it comes from a data family instance"
+                     NoDataKindsDC  -> text "perhaps you intended to use DataKinds"
+                     PatSynPE       -> text "pattern synonyms cannot be promoted"
+                     RecDataConPE   -> same_rec_group_msg
+                     ClassPE        -> same_rec_group_msg
+                     TyConPE        -> same_rec_group_msg
+          same_rec_group_msg = text "it is defined and used in the same recursive group"
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -1062,6 +1158,36 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnInvalidCIdentifier{}
       -> ErrorWithoutFlag
+    TcRnExpectedValueId{}
+      -> ErrorWithoutFlag
+    TcRnNotARecordSelector{}
+      -> ErrorWithoutFlag
+    TcRnRecSelectorEscapedTyVar{}
+      -> ErrorWithoutFlag
+    TcRnPatSynNotBidirectional{}
+      -> ErrorWithoutFlag
+    TcRnSplicePolymorphicLocalVar{}
+      -> ErrorWithoutFlag
+    TcRnIllegalDerivingItem{}
+      -> ErrorWithoutFlag
+    TcRnUnexpectedAnnotation{}
+      -> ErrorWithoutFlag
+    TcRnIllegalRecordSyntax{}
+      -> ErrorWithoutFlag
+    TcRnUnexpectedTypeSplice{}
+      -> ErrorWithoutFlag
+    TcRnInvalidVisibleKindArgument{}
+      -> ErrorWithoutFlag
+    TcRnTooManyBinders{}
+      -> ErrorWithoutFlag
+    TcRnDifferentNamesForTyVar{}
+      -> ErrorWithoutFlag
+    TcRnInvalidReturnKind{}
+      -> ErrorWithoutFlag
+    TcRnClassKindNotConstraint{}
+      -> ErrorWithoutFlag
+    TcRnUnpromotableThing{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -1321,6 +1447,39 @@ instance Diagnostic TcRnMessage where
            _ -> noHints
     TcRnInvalidCIdentifier{}
       -> noHints
+    TcRnExpectedValueId{}
+      -> noHints
+    TcRnNotARecordSelector{}
+      -> noHints
+    TcRnRecSelectorEscapedTyVar{}
+      -> [SuggestPatternMatchingSyntax]
+    TcRnPatSynNotBidirectional{}
+      -> noHints
+    TcRnSplicePolymorphicLocalVar{}
+      -> noHints
+    TcRnIllegalDerivingItem{}
+      -> noHints
+    TcRnUnexpectedAnnotation{}
+      -> noHints
+    TcRnIllegalRecordSyntax{}
+      -> noHints
+    TcRnUnexpectedTypeSplice{}
+      -> noHints
+    TcRnInvalidVisibleKindArgument{}
+      -> noHints
+    TcRnTooManyBinders{}
+      -> noHints
+    TcRnDifferentNamesForTyVar{}
+      -> noHints
+    TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext
+      -> case mb_suggest_unlifted_ext of
+           Nothing -> noHints
+           Just SuggestUnliftedNewtypes -> [suggestExtension LangExt.UnliftedNewtypes]
+           Just SuggestUnliftedDatatypes -> [suggestExtension LangExt.UnliftedDatatypes]
+    TcRnClassKindNotConstraint{}
+      -> noHints
+    TcRnUnpromotableThing{}
+      -> noHints
 
 deriveInstanceErrReasonHints :: Class
                              -> UsingGeneralizedNewtypeDeriving
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 30780d9d0e..b86f1d1506 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -14,6 +14,9 @@ module GHC.Tc.Errors.Types (
   , hasKinds
   , SuggestUndecidableInstances(..)
   , suggestUndecidableInstances
+  , SuggestUnliftedTypes(..)
+  , DataSort(..), ppDataSort
+  , AllowedDataResKind(..)
   , NotClosedReason(..)
   , SuggestPartialTypeSignatures(..)
   , suggestPartialTypeSignatures
@@ -52,6 +55,7 @@ module GHC.Tc.Errors.Types (
   , ValidHoleFits(..), noValidHoleFits
   , HoleFitDispConfig(..)
   , RelevantBindings(..), pprRelevantBindings
+  , PromotionErr(..), pprPECategory, peCategory
   , NotInScopeError(..), mkTcRnNotInScope
   , ImportError(..)
   , HoleError(..)
@@ -65,7 +69,7 @@ module GHC.Tc.Errors.Types (
 import GHC.Prelude
 
 import GHC.Hs
-import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo)
+import {-# SOURCE #-} GHC.Tc.Types (TcIdSigInfo, TcTyThing)
 import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes (HoleFit)
 import GHC.Tc.Types.Constraint
 import GHC.Tc.Types.Evidence (EvBindsVar)
@@ -101,7 +105,7 @@ import GHC.Driver.Backend (Backend)
 import GHC.Unit.State (UnitState)
 import GHC.Unit.Module.Name (ModuleName)
 import GHC.Types.Basic
-import GHC.Utils.Misc (filterOut)
+import GHC.Utils.Misc (capitalise, filterOut)
 import qualified GHC.LanguageExtensions as LangExt
 import GHC.Data.FastString (FastString)
 
@@ -1790,6 +1794,220 @@ data TcRnMessage where
   -}
   TcRnInvalidCIdentifier :: !CLabelString -> TcRnMessage
 
+  {- TcRnExpectedValueId is an error occurring when something that is not a
+      value identifier is used where one is expected.
+
+     Example(s): none
+
+    Test cases: none
+  -}
+  TcRnExpectedValueId :: !TcTyThing -> TcRnMessage
+
+  {- TcRnNotARecordSelector is an error for when something that is not a record
+     selector is used in a record pattern.
+
+     Example(s):
+     data Rec = MkRec { field :: Int }
+     r = Mkrec 1
+     r' = r { notAField = 2 }
+
+    Test cases: rename/should_fail/rnfail054
+                typecheck/should_fail/tcfail114
+  -}
+  TcRnNotARecordSelector :: !Name -> TcRnMessage
+
+  {- TcRnRecSelectorEscapedTyVar is an error indicating that a record field selector
+     containing an existential type variable is used as a function rather than in
+     a pattern match.
+
+     Example(s):
+     data Rec = forall a. Rec { field :: a }
+     field (Rec True)
+
+    Test cases: patsyn/should_fail/records-exquant
+                typecheck/should_fail/T3176
+  -}
+  TcRnRecSelectorEscapedTyVar :: !OccName -> TcRnMessage
+
+  {- TcRnPatSynNotBidirectional is an error for when a non-bidirectional pattern
+     synonym is used as a constructor.
+
+     Example(s):
+     pattern Five :: Int
+     pattern Five <- 5
+     five = Five
+
+    Test cases: patsyn/should_fail/records-no-uni-update
+                patsyn/should_fail/records-no-uni-update2
+  -}
+  TcRnPatSynNotBidirectional :: !Name -> TcRnMessage
+
+  {- TcRnSplicePolymorphicLocalVar is the error that occurs when the expression
+     inside typed template haskell brackets is a polymorphic local variable.
+
+     Example(s):
+     x = \(y :: forall a. a -> a) -> [|| y ||]
+
+    Test cases: quotes/T10384
+  -}
+  TcRnSplicePolymorphicLocalVar :: !Id -> TcRnMessage
+
+  {- TcRnIllegalDerivingItem is an error for when something other than a type class
+     appears in a deriving statement.
+
+     Example(s):
+     data X = X deriving Int
+
+    Test cases: deriving/should_fail/T5922
+  -}
+  TcRnIllegalDerivingItem :: !(LHsSigType GhcRn) -> TcRnMessage
+
+  {- TcRnUnexpectedAnnotation indicates the erroroneous use of an annotation such
+     as strictness, laziness, or unpacking.
+
+     Example(s):
+     data T = T { t :: Maybe {-# UNPACK #-} Int }
+     data C = C { f :: !IntMap Int }
+
+    Test cases: parser/should_fail/unpack_inside_type
+                typecheck/should_fail/T7210
+  -}
+  TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsSrcBang -> TcRnMessage
+
+  {- TcRnIllegalRecordSyntax is an error indicating an illegal use of record syntax.
+
+     Example(s):
+     data T = T Int { field :: Int }
+
+    Test cases: rename/should_fail/T7943
+                rename/should_fail/T9077
+  -}
+  TcRnIllegalRecordSyntax :: !(HsType GhcRn) -> TcRnMessage
+
+  {- TcRnUnexpectedTypeSplice is an error for a typed template haskell splice
+     appearing unexpectedly.
+
+     Example(s): none
+
+    Test cases: none
+  -}
+  TcRnUnexpectedTypeSplice :: !(HsType GhcRn) -> TcRnMessage
+
+  {- TcRnInvalidVisibleKindArgument is an error for a kind application on a
+     target type that cannot accept it.
+
+     Example(s):
+     bad :: Int @Type
+     bad = 1
+     type Foo :: forall a {b}. a -> b -> b
+     type Foo x y = y
+     type Bar = Foo @Bool @Int True 42
+
+    Test cases: indexed-types/should_fail/T16356_Fail3
+                typecheck/should_fail/ExplicitSpecificity7
+                typecheck/should_fail/T12045b
+                typecheck/should_fail/T12045c
+                typecheck/should_fail/T15592a
+                typecheck/should_fail/T15816
+  -}
+  TcRnInvalidVisibleKindArgument
+    :: !(LHsType GhcRn) -- ^ The visible kind argument
+    -> !Type -- ^ Target of the kind application
+    -> TcRnMessage
+
+  {- TcRnTooManyBinders is an error for a type constructor that is declared with
+     more arguments then its kind specifies.
+
+     Example(s):
+     type T :: Type -> (Type -> Type) -> Type
+     data T a (b :: Type -> Type) x1 (x2 :: Type -> Type)
+
+    Test cases: saks/should_fail/saks_fail008
+  -}
+  TcRnTooManyBinders :: !Kind -> ![LHsTyVarBndr () GhcRn] -> TcRnMessage
+
+  {- TcRnDifferentNamesForTyVar is an error that indicates different names being
+     used for the same type variable.
+
+     Example(s):
+     data SameKind :: k -> k -> *
+     data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
+
+    Test cases: polykinds/T11203
+                polykinds/T11821a
+                saks/should_fail/T20916
+                typecheck/should_fail/T17566b
+                typecheck/should_fail/T17566c
+  -}
+  TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage
+
+  {- TcRnInvalidReturnKind is an error for a data declaration that has a kind signature
+     with an invalid result kind.
+
+     Example(s):
+     data family Foo :: Constraint
+
+    Test cases: typecheck/should_fail/T14048b
+                typecheck/should_fail/UnliftedNewtypesConstraintFamily
+                typecheck/should_fail/T12729
+                typecheck/should_fail/T15883
+                typecheck/should_fail/T16829a
+                typecheck/should_fail/T16829b
+                typecheck/should_fail/UnliftedNewtypesNotEnabled
+                typecheck/should_fail/tcfail079
+  -}
+  TcRnInvalidReturnKind
+    :: !DataSort -- ^ classification of thing being returned
+    -> !AllowedDataResKind -- ^ allowed kind
+    -> !Kind -- ^ the return kind
+    -> !(Maybe SuggestUnliftedTypes) -- ^ suggested extension
+    -> TcRnMessage
+
+  {- TcRnClassKindNotConstraint is an error for a type class that has a kind that
+     is not equivalent to Constraint.
+
+     Example(s):
+     type C :: Type -> Type
+     class C a
+
+    Test cases: saks/should_fail/T16826
+  -}
+  TcRnClassKindNotConstraint :: !Kind -> TcRnMessage
+
+  {- TcRnUnpromotableThing is an error that occurs when the user attempts to
+     use the promoted version of something which is not promotable.
+
+     Example(s):
+     data T :: T -> *
+     data X a where
+       MkX :: Show a => a -> X a
+     foo :: Proxy ('MkX 'True)
+     foo = Proxy
+
+    Test cases: dependent/should_fail/PromotedClass
+                dependent/should_fail/T14845_fail1
+                dependent/should_fail/T14845_fail2
+                dependent/should_fail/T15215
+                dependent/should_fail/T13780c
+                dependent/should_fail/T15245
+                polykinds/T5716
+                polykinds/T5716a
+                polykinds/T6129
+                polykinds/T7433
+                patsyn/should_fail/T11265
+                patsyn/should_fail/T9161-1
+                patsyn/should_fail/T9161-2
+                dependent/should_fail/SelfDep
+                polykinds/PolyKinds06
+                polykinds/PolyKinds07
+                polykinds/T13625
+                polykinds/T15116
+                polykinds/T15116a
+                saks/should_fail/T16727a
+                saks/should_fail/T16727b
+  -}
+  TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage
+
 -- | Specifies which backend code generators where expected for an FFI declaration
 data ExpectedBackends
   = COrAsmOrLlvm         -- ^ C, Asm, or LLVM
@@ -1873,6 +2091,44 @@ suggestUndecidableInstances :: Bool -> SuggestUndecidableInstances
 suggestUndecidableInstances True  = YesSuggestUndecidableInstaces
 suggestUndecidableInstances False = NoSuggestUndecidableInstaces
 
+data SuggestUnliftedTypes
+  = SuggestUnliftedNewtypes
+  | SuggestUnliftedDatatypes
+
+-- | A description of whether something is a
+--
+-- * @data@ or @newtype@ ('DataDeclSort')
+--
+-- * @data instance@ or @newtype instance@ ('DataInstanceSort')
+--
+-- * @data family@ ('DataFamilySort')
+--
+-- At present, this data type is only consumed by 'checkDataKindSig'.
+data DataSort
+  = DataDeclSort     NewOrData
+  | DataInstanceSort NewOrData
+  | DataFamilySort
+
+ppDataSort :: DataSort -> SDoc
+ppDataSort data_sort = text $
+  case data_sort of
+    DataDeclSort     DataType -> "Data type"
+    DataDeclSort     NewType  -> "Newtype"
+    DataInstanceSort DataType -> "Data instance"
+    DataInstanceSort NewType  -> "Newtype instance"
+    DataFamilySort            -> "Data family"
+
+-- | Helper type used in 'checkDataKindSig'.
+--
+-- Superficially similar to 'ContextKind', but it lacks 'AnyKind'
+-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@
+-- provides 'LiftedKind', which is much simpler to match on and
+-- handle in 'isAllowedDataResKind'.
+data AllowedDataResKind
+  = AnyTYPEKind
+  | AnyBoxedKind
+  | LiftedKind
+
 -- | A data type to describe why a variable is not closed.
 -- See Note [Not-closed error messages] in GHC.Tc.Gen.Expr
 data NotClosedReason = NotLetBoundReason
@@ -2710,6 +2966,47 @@ discardMsg :: SDoc
 discardMsg = text "(Some bindings suppressed;" <+>
              text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
 
+data PromotionErr
+  = TyConPE          -- TyCon used in a kind before we are ready
+                     --     data T :: T -> * where ...
+  | ClassPE          -- Ditto Class
+
+  | FamDataConPE     -- Data constructor for a data family
+                     -- See Note [AFamDataCon: not promoting data family constructors]
+                     -- in GHC.Tc.Utils.Env.
+  | ConstrainedDataConPE PredType
+                     -- Data constructor with a non-equality context
+                     -- See Note [Don't promote data constructors with
+                     --           non-equality contexts] in GHC.Tc.Gen.HsType
+  | PatSynPE         -- Pattern synonyms
+                     -- See Note [Don't promote pattern synonyms] in GHC.Tc.Utils.Env
+
+  | RecDataConPE     -- Data constructor in a recursive loop
+                     -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl
+  | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)
+
+instance Outputable PromotionErr where
+  ppr ClassPE                     = text "ClassPE"
+  ppr TyConPE                     = text "TyConPE"
+  ppr PatSynPE                    = text "PatSynPE"
+  ppr FamDataConPE                = text "FamDataConPE"
+  ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE"
+                                      <+> parens (ppr pred)
+  ppr RecDataConPE                = text "RecDataConPE"
+  ppr NoDataKindsDC               = text "NoDataKindsDC"
+
+pprPECategory :: PromotionErr -> SDoc
+pprPECategory = text . capitalise . peCategory
+
+peCategory :: PromotionErr -> String
+peCategory ClassPE                = "class"
+peCategory TyConPE                = "type constructor"
+peCategory PatSynPE               = "pattern synonym"
+peCategory FamDataConPE           = "data constructor"
+peCategory ConstrainedDataConPE{} = "data constructor"
+peCategory RecDataConPE           = "data constructor"
+peCategory NoDataKindsDC          = "data constructor"
+
 -- | Stores the information to be reported in a representation-polymorphism
 -- error message.
 data FixedRuntimeRepErrorInfo