From edb9bf77104a8afec6e54e646f07b1a9849dfc76 Mon Sep 17 00:00:00 2001
From: Jade <Nils.Jadefalke@gmail.com>
Date: Tue, 27 Feb 2024 23:13:40 +0100
Subject: [PATCH] Error messages: Improve Error messages for Data constructors
 in type signatures.

This patch improves the error messages from invalid type signatures by
trying to guess what the user did and suggesting an appropriate fix.

Partially fixes: #17879
---
 compiler/GHC/Parser/Errors/Ppr.hs             | 22 +++++++++++++------
 compiler/GHC/Parser/Errors/Types.hs           |  8 ++++++-
 compiler/GHC/Parser/PostProcess.hs            | 18 ++++++++++-----
 compiler/GHC/Types/Hint.hs                    |  7 +++---
 compiler/GHC/Types/Hint/Ppr.hs                |  4 ++--
 testsuite/tests/module/mod98.stderr           |  5 ++---
 .../should_fail/NoPatternSynonyms.stderr      |  3 ++-
 testsuite/tests/parser/should_fail/T17879a.hs |  4 ++++
 .../tests/parser/should_fail/T17879a.stderr   |  4 ++++
 testsuite/tests/parser/should_fail/T17879b.hs |  4 ++++
 .../tests/parser/should_fail/T17879b.stderr   |  4 ++++
 .../tests/parser/should_fail/T3811.stderr     |  5 ++---
 testsuite/tests/parser/should_fail/all.T      |  2 ++
 .../parser/should_fail/readFail031.stderr     |  5 ++---
 14 files changed, 66 insertions(+), 29 deletions(-)
 create mode 100644 testsuite/tests/parser/should_fail/T17879a.hs
 create mode 100644 testsuite/tests/parser/should_fail/T17879a.stderr
 create mode 100644 testsuite/tests/parser/should_fail/T17879b.hs
 create mode 100644 testsuite/tests/parser/should_fail/T17879b.stderr

diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 567922ce4f23..35d96ee83585 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -455,11 +455,17 @@ instance Diagnostic PsMessage where
     PsErrIllegalRoleName role _nearby
       -> mkSimpleDecorated $
            text "Illegal role name" <+> quotes (ppr role)
-    PsErrInvalidTypeSignature lhs
-      -> mkSimpleDecorated $
-           text "Invalid type signature:"
-           <+> ppr lhs
-           <+> text ":: ..."
+    PsErrInvalidTypeSignature reason lhs
+      -> mkSimpleDecorated $ case reason of
+           PsErrInvalidTypeSig_DataCon   -> text "Invalid data constructor" <+> quotes (ppr lhs) <+>
+                                            text "in type signature" <> colon $$
+                                            text "You can only define data constructors in data type declarations."
+           PsErrInvalidTypeSig_Qualified -> text "Invalid qualified name in type signature."
+           PsErrInvalidTypeSig_Other     -> text "Invalid type signature" <> colon $$
+                                            text "A type signature should be of form" <+>
+                                            placeHolder "variables" <+> dcolon <+> placeHolder "type" <>
+                                            dot
+            where placeHolder = angleBrackets . text
     PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where
        -> mkSimpleDecorated $
             vcat [ text "Unexpected type" <+> quotes (ppr t)
@@ -779,15 +785,17 @@ instance Diagnostic PsMessage where
         sug_missingdo _                                     = Nothing
     PsErrParseRightOpSectionInPat{}               -> noHints
     PsErrIllegalRoleName _ nearby                 -> [SuggestRoles nearby]
-    PsErrInvalidTypeSignature lhs                 ->
+    PsErrInvalidTypeSignature reason lhs          ->
         if | foreign_RDR `looks_like` lhs
            -> [suggestExtension LangExt.ForeignFunctionInterface]
            | default_RDR `looks_like` lhs
            -> [suggestExtension LangExt.DefaultSignatures]
            | pattern_RDR `looks_like` lhs
            -> [suggestExtension LangExt.PatternSynonyms]
+           | PsErrInvalidTypeSig_Qualified <- reason
+           -> [SuggestTypeSignatureRemoveQualifier]
            | otherwise
-           -> [SuggestTypeSignatureForm]
+           -> []
       where
         -- A common error is to forget the ForeignFunctionInterface flag
         -- so check for that, and suggest.  cf #3805
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index 0f0b8d19e284..3b12a18f93af 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -389,7 +389,7 @@ data PsMessage
    | PsErrIllegalRoleName !FastString [Role]
 
    -- | Invalid type signature
-   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)
+   | PsErrInvalidTypeSignature !PsInvalidTypeSignature !(LHsExpr GhcPs)
 
    -- | Unexpected type in declaration
    | PsErrUnexpectedTypeInDecl !(LHsType GhcPs)
@@ -480,6 +480,11 @@ data PsErrParseDetails
     -- ^ Did we parse a \"pattern\" keyword?
   }
 
+data PsInvalidTypeSignature
+  = PsErrInvalidTypeSig_Qualified
+  | PsErrInvalidTypeSig_DataCon
+  | PsErrInvalidTypeSig_Other
+
 -- | Is the parsed pattern recursive?
 data PatIsRecursive
   = YesPatIsRecursive
@@ -531,6 +536,7 @@ data NumUnderscoreReason
    | NumUnderscore_Float
    deriving (Show,Eq,Ord)
 
+
 data LexErrKind
    = LexErrKind_EOF        -- ^ End of input
    | LexErrKind_UTF8       -- ^ UTF-8 decoding error
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 582c35e2d249..8939da0b707f 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1398,13 +1398,19 @@ checkPatBind _loc annsIn lhs (L _ grhss) mult = do
 
 
 checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)
-checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))
-  | isUnqual v
-  , not (isDataOcc (rdrNameOcc v))
-  = return lrdr
+checkValSigLhs lhs@(L l lhs_expr) =
+  case lhs_expr of
+    HsVar _ lrdr@(L _ v) -> check_var v lrdr
+    _                    -> make_err PsErrInvalidTypeSig_Other
+  where
+    check_var v lrdr
+      | not (isUnqual v) = make_err PsErrInvalidTypeSig_Qualified
+      | isDataOcc occ_n  = make_err PsErrInvalidTypeSig_DataCon
+      | otherwise        = pure lrdr
+      where occ_n = rdrNameOcc v
+    make_err reason = addFatalError $
+      mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs)
 
-checkValSigLhs lhs@(L l _)
-  = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs
 
 checkDoAndIfThenElse
   :: (Outputable a, Outputable b, Outputable c)
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 2d9102dfff4d..e7c5d29ba977 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -54,6 +54,7 @@ data AvailableBindings
   | UnnamedBinding
   -- ^ An unknown binding (i.e. too complicated to turn into a 'Name')
 
+
 data LanguageExtensionHint
   = -- | Suggest to enable the input extension. This is the hint that
     -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving
@@ -297,13 +298,13 @@ data GhcHint
     -}
   | SuggestQualifyStarOperator
 
-    {-| Suggests that a type signature should have form <variable> :: <type>
+    {-| Suggests that for a type signature 'M.x :: ...' the qualifier should be omitted
         in order to be accepted by GHC.
 
         Triggered by: 'GHC.Parser.Errors.Types.PsErrInvalidTypeSignature'
-        Test case(s): parser/should_fail/T3811
+        Test case(s): module/mod98
     -}
-  | SuggestTypeSignatureForm
+  | SuggestTypeSignatureRemoveQualifier
 
     {-| Suggests to move an orphan instance (for a typeclass or a type or data
         family), or to newtype-wrap it.
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 7a91b01122a3..e214619271dd 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -127,8 +127,8 @@ instance Outputable GhcHint where
       -> text "To use (or export) this operator in"
             <+> text "modules with StarIsType,"
          $$ text "    including the definition module, you must qualify it."
-    SuggestTypeSignatureForm
-      -> text "A type signature should be of form <variables> :: <type>"
+    SuggestTypeSignatureRemoveQualifier
+      -> text "Perhaps you meant to omit the qualifier"
     SuggestAddToHSigExportList _name mb_mod
       -> let header = text "Try adding it to the export list of"
          in case mb_mod of
diff --git a/testsuite/tests/module/mod98.stderr b/testsuite/tests/module/mod98.stderr
index 52c0cf646e32..59716fe1a783 100644
--- a/testsuite/tests/module/mod98.stderr
+++ b/testsuite/tests/module/mod98.stderr
@@ -1,5 +1,4 @@
 
 mod98.hs:3:1: error: [GHC-94426]
-    Invalid type signature: M.x :: ...
-    Suggested fix:
-      A type signature should be of form <variables> :: <type>
+    Invalid qualified name in type signature.
+    Suggested fix: Perhaps you meant to omit the qualifier
diff --git a/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr b/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr
index f4cd44c04ad1..84af9aa95ef5 100644
--- a/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr
+++ b/testsuite/tests/parser/should_fail/NoPatternSynonyms.stderr
@@ -1,4 +1,5 @@
 
 NoPatternSynonyms.hs:3:1: error: [GHC-94426]
-    Invalid type signature: pattern P :: ...
+    Invalid type signature:
+    A type signature should be of form <variables> :: <type>.
     Suggested fix: Perhaps you intended to use PatternSynonyms
diff --git a/testsuite/tests/parser/should_fail/T17879a.hs b/testsuite/tests/parser/should_fail/T17879a.hs
new file mode 100644
index 000000000000..2ca1e04dde6d
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T17879a.hs
@@ -0,0 +1,4 @@
+module Main where
+
+Foo :: ()
+Foo = ()
diff --git a/testsuite/tests/parser/should_fail/T17879a.stderr b/testsuite/tests/parser/should_fail/T17879a.stderr
new file mode 100644
index 000000000000..46a4fddbe2f3
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T17879a.stderr
@@ -0,0 +1,4 @@
+
+T17879a.hs:3:1: error: [GHC-94426]
+    Invalid data constructor ‘Foo’ in type signature:
+    You can only define data constructors in data type declarations.
diff --git a/testsuite/tests/parser/should_fail/T17879b.hs b/testsuite/tests/parser/should_fail/T17879b.hs
new file mode 100644
index 000000000000..88bd72d833ac
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T17879b.hs
@@ -0,0 +1,4 @@
+module Main where
+
+_ :: ()
+_ = ()
diff --git a/testsuite/tests/parser/should_fail/T17879b.stderr b/testsuite/tests/parser/should_fail/T17879b.stderr
new file mode 100644
index 000000000000..8752e597436a
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T17879b.stderr
@@ -0,0 +1,4 @@
+
+T17879b.hs:3:1: error: [GHC-94426]
+    Invalid type signature:
+    A type signature should be of form <variables> :: <type>.
diff --git a/testsuite/tests/parser/should_fail/T3811.stderr b/testsuite/tests/parser/should_fail/T3811.stderr
index 4e1bf3fef19c..947042fbdf5d 100644
--- a/testsuite/tests/parser/should_fail/T3811.stderr
+++ b/testsuite/tests/parser/should_fail/T3811.stderr
@@ -1,5 +1,4 @@
 
 T3811.hs:4:1: error: [GHC-94426]
-    Invalid type signature: f x :: ...
-    Suggested fix:
-      A type signature should be of form <variables> :: <type>
+    Invalid type signature:
+    A type signature should be of form <variables> :: <type>.
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 12f3889882a2..92f39f0fc18d 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -225,3 +225,5 @@ test('ListTuplePunsFail2', extra_files(['ListTuplePunsFail2.hs']), ghci_script,
 test('ListTuplePunsFail3', extra_files(['ListTuplePunsFail3.hs']), ghci_script, ['ListTuplePunsFail3.script'])
 test('ListTuplePunsFail4', extra_files(['ListTuplePunsFail4.hs']), ghci_script, ['ListTuplePunsFail4.script'])
 test('ListTuplePunsFail5', extra_files(['ListTuplePunsFail5.hs']), ghci_script, ['ListTuplePunsFail5.script'])
+test('T17879a', normal, compile_fail, [''])
+test('T17879b', normal, compile_fail, [''])
diff --git a/testsuite/tests/parser/should_fail/readFail031.stderr b/testsuite/tests/parser/should_fail/readFail031.stderr
index 6b8937c94cf1..272c8ec8f00c 100644
--- a/testsuite/tests/parser/should_fail/readFail031.stderr
+++ b/testsuite/tests/parser/should_fail/readFail031.stderr
@@ -1,5 +1,4 @@
 
 readFail031.hs:4:3: error: [GHC-94426]
-    Invalid type signature: (:+) :: ...
-    Suggested fix:
-      A type signature should be of form <variables> :: <type>
+    Invalid data constructor ‘(:+)’ in type signature:
+    You can only define data constructors in data type declarations.
-- 
GitLab