summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorKrzysztof Gogolewski <krzysztof.gogolewski@tweag.io>2021-07-27 20:02:14 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-07-29 13:15:09 -0400
commitf4aea1a20d522091286ce429b3aae278ee35d75e (patch)
tree014ed570cd1e86f3904f696303b4021f8ab7f090
parent9b916e81234fa71ffde85d17c7e6d96302518cd7 (diff)
downloadhaskell-f4aea1a20d522091286ce429b3aae278ee35d75e.tar.gz
Reject pattern synonyms with linear types (#18806)
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs7
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs9
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs10
-rw-r--r--testsuite/tests/linear/should_fail/LinearPatSyn.hs1
-rw-r--r--testsuite/tests/linear/should_fail/LinearPatSyn.stderr2
-rw-r--r--testsuite/tests/linear/should_fail/LinearPatSyn2.hs6
-rw-r--r--testsuite/tests/linear/should_fail/LinearPatSyn2.stderr5
-rw-r--r--testsuite/tests/linear/should_fail/all.T1
8 files changed, 36 insertions, 5 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 73ef9d9470..de04bedfe2 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -73,6 +73,9 @@ instance Diagnostic TcRnMessage where
-> mkSimpleDecorated $
hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
2 (text "Pattern synonym declarations are only valid at top level")
+ TcRnLinearPatSyn ty
+ -> mkSimpleDecorated $
+ hang (text "Pattern synonyms do not support linear fields (GHC #18806):") 2 (ppr ty)
TcRnEmptyRecordUpdate
-> mkSimpleDecorated $ text "Empty record update"
TcRnIllegalFieldPunning fld
@@ -123,6 +126,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnIllegalPatSynDecl{}
-> ErrorWithoutFlag
+ TcRnLinearPatSyn{}
+ -> ErrorWithoutFlag
TcRnEmptyRecordUpdate
-> ErrorWithoutFlag
TcRnIllegalFieldPunning{}
@@ -168,6 +173,8 @@ instance Diagnostic TcRnMessage where
-> [SuggestIncreaseSimplifierIterations]
TcRnIllegalPatSynDecl{}
-> noHints
+ TcRnLinearPatSyn{}
+ -> noHints
TcRnEmptyRecordUpdate{}
-> noHints
TcRnIllegalFieldPunning{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 6d133bff61..a82ac7328f 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -231,6 +231,15 @@ data TcRnMessage where
-}
TcRnIllegalPatSynDecl :: !(LIdP GhcPs) -> TcRnMessage
+ {-| TcRnLinearPatSyn is an error that occurs whenever a pattern
+ synonym signature uses a field that is not unrestricted.
+
+ Example(s): None
+
+ Test cases: linear/should_fail/LinearPatSyn2
+ -}
+ TcRnLinearPatSyn :: !Type -> TcRnMessage
+
{-| TcRnEmptyRecordUpdate is an error that occurs whenever
a record is updated without specifying any field.
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index bc78e8b592..fa4cd8fecf 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -23,7 +23,7 @@ import GHC.Prelude
import GHC.Hs
import GHC.Tc.Gen.Pat
import GHC.Core.Multiplicity
-import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )
+import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType, isManyDataConTy )
import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
@@ -389,6 +389,10 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
univ_tvs = binderVars univ_bndrs
ex_tvs = binderVars ex_bndrs
+ -- Pattern synonyms currently cannot be linear (#18806)
+ ; checkTc (all (isManyDataConTy . scaledMult) arg_tys) $
+ TcRnLinearPatSyn sig_body_ty
+
-- Skolemise the quantified type variables. This is necessary
-- in order to check the actual pattern type against the
-- expected type. Even though the tyvars in the type are
@@ -513,8 +517,8 @@ Hence a special-purpose skolemiseTvBndrX here, similar to
GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter
does cloning.
-[Pattern synonyms and higher rank types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Pattern synonyms and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT (forall a. a->a)
diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn.hs b/testsuite/tests/linear/should_fail/LinearPatSyn.hs
index 3e87bfc078..a874d320d0 100644
--- a/testsuite/tests/linear/should_fail/LinearPatSyn.hs
+++ b/testsuite/tests/linear/should_fail/LinearPatSyn.hs
@@ -7,7 +7,6 @@ module LinearPatSyn where
-- seems to require changes to the desugarer. So currently pattern synonyms are
-- disallowed in linear patterns.
-pattern P :: b %1 -> a %1 -> (a, b)
pattern P y x = (x, y)
s :: (a, b) %1 -> (b, a)
diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn.stderr b/testsuite/tests/linear/should_fail/LinearPatSyn.stderr
index f7c3aab406..95d18396aa 100644
--- a/testsuite/tests/linear/should_fail/LinearPatSyn.stderr
+++ b/testsuite/tests/linear/should_fail/LinearPatSyn.stderr
@@ -1,5 +1,5 @@
-LinearPatSyn.hs:14:4: error:
+LinearPatSyn.hs:13:4: error:
• Couldn't match type ‘'Many’ with ‘'One’
arising from a non-linear pattern
• In the pattern: P y x
diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn2.hs b/testsuite/tests/linear/should_fail/LinearPatSyn2.hs
new file mode 100644
index 0000000000..ae1d35ce66
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearPatSyn2.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE PatternSynonyms, LinearTypes #-}
+module LinearPatSyn2 where
+
+-- Should be rejected, #18806
+pattern J :: x %1 -> Maybe x
+pattern J a = Just a
diff --git a/testsuite/tests/linear/should_fail/LinearPatSyn2.stderr b/testsuite/tests/linear/should_fail/LinearPatSyn2.stderr
new file mode 100644
index 0000000000..1360983907
--- /dev/null
+++ b/testsuite/tests/linear/should_fail/LinearPatSyn2.stderr
@@ -0,0 +1,5 @@
+
+LinearPatSyn2.hs:6:9: error:
+ • Pattern synonyms do not support linear fields (GHC #18806):
+ x %1 -> Maybe x
+ • In the declaration for pattern synonym ‘J’
diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T
index a831011cef..9f8ba14483 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/testsuite/tests/linear/should_fail/all.T
@@ -17,6 +17,7 @@ test('LinearSeq', normal, compile_fail, [''])
test('LinearViewPattern', normal, compile_fail, [''])
test('LinearConfusedDollar', normal, compile_fail, [''])
test('LinearPatSyn', normal, compile_fail, [''])
+test('LinearPatSyn2', normal, compile_fail, [''])
test('LinearRole', normal, compile_fail, [''])
test('LinearGADTNewtype', normal, compile_fail, [''])
test('LinearPartialSig', normal, compile_fail, [''])