Disallow linear arrows in GADT records (#19928)

Before this patch, GHC used to silently accept programs such as the
following:

	data R where
	  D1 :: { d1 :: Int } %1 -> R

The %1 annotation was completely ignored. Now it is a proper error.

One remaining issue is that in the error message (⊸) turns
into (%1 ->). This is to be corrected with upcoming exactprint updates.

1 files changed, 16 insertions, 11 deletions

diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 34c973fefc..ffe44227fd 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -716,17 +716,22 @@ mkGadtDecl loc names ty annsIn = do
   cs <- getCommentsFor loc
   let l = noAnnSrcSpan loc
 
-  let (args, res_ty, annsa, csa)
-        | L ll (HsFunTy af _w (L loc' (HsRecTy an rf)) res_ty) <- body_ty
-        = let
-            an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an
-          in ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty
-             , [], epAnnComments (ann ll))
-        | otherwise
-        = let (anns, cs, arg_types, res_type) = splitHsFunType body_ty
-          in (PrefixConGADT arg_types, res_type, anns, cs)
-
-      an = case outer_bndrs of
+  (args, res_ty, annsa, csa) <-
+    case body_ty of
+     L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do
+       let an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an
+       case hsArr of
+         HsUnrestrictedArrow _ -> return ()
+         _ -> addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $
+                                 (PsErrIllegalGadtRecordMultiplicity hsArr)
+
+       return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty
+              , [], epAnnComments (ann ll))
+     _ -> do
+       let (anns, cs, arg_types, res_type) = splitHsFunType body_ty
+       return (PrefixConGADT arg_types, res_type, anns, cs)
+
+  let an = case outer_bndrs of
         _                -> EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa)
 
   pure $ L l ConDeclGADT