summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2021-06-01 15:46:49 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2021-06-01 15:48:16 +0300
commit00a32614dd6af3221b1df8320a25152ffe9f57c3 (patch)
tree98f4ffb2fd468b8a11488aa1f9765ba0114b43c8
parent6db8a0f76ec45d47060e28bb303e9eef60bdb16b (diff)
downloadhaskell-wip/t19928.tar.gz
Disallow linear arrows in GADT records (#19928)wip/t19928
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.
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs8
-rw-r--r--compiler/GHC/Parser/Errors/Types.hs3
-rw-r--r--compiler/GHC/Parser/PostProcess.hs27
-rw-r--r--testsuite/tests/parser/should_fail/T19928.hs8
-rw-r--r--testsuite/tests/parser/should_fail/T19928.stderr12
-rw-r--r--testsuite/tests/parser/should_fail/all.T1
6 files changed, 48 insertions, 11 deletions
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 6a2152f3f7..6b08ae0877 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -520,6 +520,12 @@ instance Diagnostic PsMessage where
text "character in package name"
]
+ PsErrIllegalGadtRecordMultiplicity arr
+ -> mkSimpleDecorated $ vcat
+ [ text "Parse error" <> colon <+> quotes (ppr arr)
+ , text "Record constructors in GADTs must use an ordinary, non-linear arrow."
+ ]
+
diagnosticReason = \case
PsUnknownMessage m -> diagnosticReason m
PsWarnTab{} -> WarningWithFlag Opt_WarnTabs
@@ -628,6 +634,7 @@ instance Diagnostic PsMessage where
PsErrUnexpectedTypeInDecl{} -> ErrorWithoutFlag
PsErrInvalidPackageName{} -> ErrorWithoutFlag
PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag
+ PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag
diagnosticHints = \case
PsUnknownMessage m -> diagnosticHints m
@@ -754,6 +761,7 @@ instance Diagnostic PsMessage where
PsErrInvalidTypeSignature{} -> noHints
PsErrUnexpectedTypeInDecl{} -> noHints
PsErrInvalidPackageName{} -> noHints
+ PsErrIllegalGadtRecordMultiplicity{} -> noHints
suggestParensAndBlockArgs :: [GhcHint]
suggestParensAndBlockArgs =
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index d75c223253..38c54b7149 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -395,6 +395,9 @@ data PsMessage
-- TODO: embed the proper operator, if possible
| forall infixOcc. (OutputableBndr infixOcc) => PsErrParseRightOpSectionInPat !infixOcc !(PatBuilder GhcPs)
+ -- | Illegal linear arrow or multiplicity annotation in GADT record syntax
+ | PsErrIllegalGadtRecordMultiplicity !(HsArrow GhcPs)
+
newtype StarIsType = StarIsType Bool
-- | Extra details about a parse error, which helps
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
diff --git a/testsuite/tests/parser/should_fail/T19928.hs b/testsuite/tests/parser/should_fail/T19928.hs
new file mode 100644
index 0000000000..c6c2947577
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19928.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE UnicodeSyntax, LinearTypes #-}
+
+module T19928 where
+
+data R where
+ D1 :: { d1 :: Int } %1 -> R
+ Dp :: { dp :: Int } %p -> R
+ Dl :: { dl :: Int } ⊸ R
diff --git a/testsuite/tests/parser/should_fail/T19928.stderr b/testsuite/tests/parser/should_fail/T19928.stderr
new file mode 100644
index 0000000000..342639a100
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/T19928.stderr
@@ -0,0 +1,12 @@
+
+T19928.hs:6:9: error:
+ Parse error: ‘(%1 ->)’
+ Record constructors in GADTs must use an ordinary, non-linear arrow.
+
+T19928.hs:7:9: error:
+ Parse error: ‘(%p ->)’
+ Record constructors in GADTs must use an ordinary, non-linear arrow.
+
+T19928.hs:8:9: error:
+ Parse error: ‘(%1 ->)’
+ Record constructors in GADTs must use an ordinary, non-linear arrow.
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 49a298c93f..9975f6c5d7 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -190,3 +190,4 @@ test('RecordDotSyntaxFail11', normal, compile_fail, [''])
test('RecordDotSyntaxFail12', normal, compile_fail, [''])
test('RecordDotSyntaxFail13', normal, compile_fail, [''])
test('T19504', normal, compile_fail, [''])
+test('T19928', normal, compile_fail, [''])