diff options
author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2021-06-01 15:46:49 +0300 |
---|---|---|
committer | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2021-06-01 15:48:16 +0300 |
commit | 00a32614dd6af3221b1df8320a25152ffe9f57c3 (patch) | |
tree | 98f4ffb2fd468b8a11488aa1f9765ba0114b43c8 | |
parent | 6db8a0f76ec45d47060e28bb303e9eef60bdb16b (diff) | |
download | haskell-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.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Types.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Parser/PostProcess.hs | 27 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19928.hs | 8 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/T19928.stderr | 12 | ||||
-rw-r--r-- | testsuite/tests/parser/should_fail/all.T | 1 |
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, ['']) |