Reject illegal quote mark in data con declarations (#17865)

* Non-fatal (i.e. recoverable) parse error
* Checking infix constructors
* Extended the regression test

5 files changed, 42 insertions, 4 deletions

diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 3e83958c88..d108673e9c 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -300,6 +300,10 @@ instance Diagnostic PsMessage where
       -> mkSimpleDecorated $
            hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2
                 (ppr lhs <+> ppr tc <+> ppr rhs)
+    PsErrIllegalPromotionQuoteDataCon name
+      -> mkSimpleDecorated $
+           text "Illegal promotion quote mark in the declaration of" $$
+           text "data/newtype constructor" <+> pprPrefixOcc name
     PsErrUnpackDataCon
       -> mkSimpleDecorated $ text "{-# UNPACK #-} cannot be applied to a data constructor."
     PsErrUnexpectedKindAppInDataCon lhs ki
@@ -557,6 +561,7 @@ instance Diagnostic PsMessage where
     PsErrDotsInRecordUpdate                       -> ErrorWithoutFlag
     PsErrInvalidDataCon{}                         -> ErrorWithoutFlag
     PsErrInvalidInfixDataCon{}                    -> ErrorWithoutFlag
+    PsErrIllegalPromotionQuoteDataCon{}           -> ErrorWithoutFlag
     PsErrUnpackDataCon                            -> ErrorWithoutFlag
     PsErrUnexpectedKindAppInDataCon{}             -> ErrorWithoutFlag
     PsErrInvalidRecordCon{}                       -> ErrorWithoutFlag
@@ -688,6 +693,7 @@ instance Diagnostic PsMessage where
     PsErrDotsInRecordUpdate                       -> noHints
     PsErrInvalidDataCon{}                         -> noHints
     PsErrInvalidInfixDataCon{}                    -> noHints
+    PsErrIllegalPromotionQuoteDataCon{}           -> noHints
     PsErrUnpackDataCon                            -> noHints
     PsErrUnexpectedKindAppInDataCon{}             -> noHints
     PsErrInvalidRecordCon{}                       -> noHints
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index d2ff9c242d..7f40c73635 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -224,6 +224,9 @@ data PsMessage
    -- | Cannot parse data constructor in a data/newtype declaration
    | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)
 
+   -- | Illegal DataKinds quote mark in data/newtype constructor declaration
+   | PsErrIllegalPromotionQuoteDataCon !RdrName
+
    -- | UNPACK applied to a data constructor
    | PsErrUnpackDataCon
 
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index ef3f279567..c39cc478af 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -1976,9 +1976,10 @@ instance DisambTD DataConBuilder where
     addFatalError $ mkPlainErrorMsgEnvelope l_at $
                       (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))
 
-  mkHsOpTyPV _ lhs tc rhs = do
+  mkHsOpTyPV prom lhs tc rhs = do
       check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative
       data_con <- eitherToP $ tyConToDataCon tc
+      checkNotPromotedDataCon prom data_con
       return $ L l (InfixDataConBuilder lhs data_con rhs)
     where
       l = combineLocsA lhs rhs
@@ -2000,8 +2001,9 @@ instance DisambTD DataConBuilder where
          return constr_stuff
 
 tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)
-tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do
+tyToDataConBuilder (L l (HsTyVar _ prom v)) = do
   data_con <- eitherToP $ tyConToDataCon v
+  checkNotPromotedDataCon prom data_con
   return $ L l (PrefixDataConBuilder nilOL data_con)
 tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do
   let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))
@@ -2010,6 +2012,13 @@ tyToDataConBuilder t =
   addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $
                     (PsErrInvalidDataCon (unLoc t))
 
+-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).
+checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()
+checkNotPromotedDataCon NotPromoted _ = return ()
+checkNotPromotedDataCon IsPromoted (L l name) =
+  addError $ mkPlainErrorMsgEnvelope (locA l) $
+    PsErrIllegalPromotionQuoteDataCon name
+
 {- Note [Ambiguous syntactic categories]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 There are places in the grammar where we do not know whether we are parsing an
diff --git a/testsuite/tests/parser/should_fail/T17865.hs b/testsuite/tests/parser/should_fail/T17865.hs
index b278ec09ae..31efa0596d 100644
--- a/testsuite/tests/parser/should_fail/T17865.hs
+++ b/testsuite/tests/parser/should_fail/T17865.hs
@@ -1,3 +1,9 @@
 module T17865 where
 
 data T = 'MkT
+
+data T' = ' MkT'
+
+data I a b = a ':> b
+
+data I' a b = a ' :>$ b
diff --git a/testsuite/tests/parser/should_fail/T17865.stderr b/testsuite/tests/parser/should_fail/T17865.stderr
index 786196c3a8..560144fbe5 100644
--- a/testsuite/tests/parser/should_fail/T17865.stderr
+++ b/testsuite/tests/parser/should_fail/T17865.stderr
@@ -1,2 +1,16 @@
-T17865.hs:3:10:
-    Cannot parse data constructor in a data/newtype declaration: 'MkT
+
+T17865.hs:3:11: error:
+    Illegal promotion quote mark in the declaration of
+    data/newtype constructor MkT
+
+T17865.hs:5:13: error:
+    Illegal promotion quote mark in the declaration of
+    data/newtype constructor MkT'
+
+T17865.hs:7:16: error:
+    Illegal promotion quote mark in the declaration of
+    data/newtype constructor (:>)
+
+T17865.hs:9:17: error:
+    Illegal promotion quote mark in the declaration of
+    data/newtype constructor (:>$)