Add TcRnIllegalViewPattern to TcRnMessage

6 files changed, 33 insertions, 6 deletions

diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index eef23cf56d..91da0f4454 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -558,7 +558,7 @@ rnPatAndThen mk (AsPat _ rdr pat)
 
 rnPatAndThen mk p@(ViewPat _ expr pat)
   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
-                      ; checkErr vp_flag (badViewPat p) }
+                      ; checkErr vp_flag (TcRnIllegalViewPattern p) }
          -- Because of the way we're arranging the recursive calls,
          -- this will be in the right context
        ; expr' <- liftCpsFV $ rnLExpr expr
@@ -1026,8 +1026,3 @@ bogusCharError :: Char -> TcRnMessage
 bogusCharError c
   = TcRnUnknownMessage $ mkPlainError noHints $
   text "character literal out of range: '\\" <> char c  <> char '\''
-
-badViewPat :: Pat GhcPs -> TcRnMessage
-badViewPat pat = TcRnUnknownMessage $ mkPlainError noHints $
-  vcat [text "Illegal view pattern: " <+> ppr pat,
-       text "Use ViewPatterns to enable view patterns"]
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 034f04f91b..c8ed6a04eb 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -84,6 +84,8 @@ instance Diagnostic TcRnMessage where
            hsep [text "duplicate field name",
                  quotes (ppr (NE.head dups)),
                  text "in record", pprRecordFieldPart fld_part]
+    TcRnIllegalViewPattern pat
+      -> mkSimpleDecorated $ vcat [text "Illegal view pattern: " <+> ppr pat]
 
   diagnosticReason = \case
     TcRnUnknownMessage m
@@ -123,6 +125,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnDuplicateFieldName{}
       -> ErrorWithoutFlag
+    TcRnIllegalViewPattern{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -162,6 +166,8 @@ instance Diagnostic TcRnMessage where
       -> [SuggestExtension LangExt.RecordWildCards]
     TcRnDuplicateFieldName{}
       -> noHints
+    TcRnIllegalViewPattern{}
+      -> [SuggestExtension LangExt.ViewPatterns]
 
 messageWithInfoDiagnosticMessage :: UnitState
                                  -> ErrInfo
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index d1b61e344c..3fd9698b10 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -278,6 +278,20 @@ data TcRnMessage where
   -}
   TcRnDuplicateFieldName :: !RecordFieldPart -> NE.NonEmpty RdrName -> TcRnMessage
 
+  {-| TcRnIllegalViewPattern is an error that occurs whenever
+      the ViewPatterns syntax is used but the ViewPatterns language extension
+      is not enabled.
+
+      Examples(s):
+      data Foo = Foo { a :: Int }
+
+      foo :: Foo -> Int
+      foo (a -> l) = l -- not OK, the 'ViewPattern' extension is not enabled.
+
+     Test cases: parser/should_fail/ViewPatternsFail
+  -}
+  TcRnIllegalViewPattern :: !(Pat GhcPs) -> TcRnMessage
+
 -- | Which parts of a record field are affected by a particular error or warning.
 data RecordFieldPart
   = RecordFieldConstructor !Name
diff --git a/testsuite/tests/parser/should_fail/ViewPatternsFail.hs b/testsuite/tests/parser/should_fail/ViewPatternsFail.hs
new file mode 100644
index 0000000000..35517575b5
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/ViewPatternsFail.hs
@@ -0,0 +1,7 @@
+
+module ViewPatternsFail where
+
+data Foo = Foo { a :: Int }
+
+foo :: Foo -> Int
+foo (a -> l) = l
diff --git a/testsuite/tests/parser/should_fail/ViewPatternsFail.stderr b/testsuite/tests/parser/should_fail/ViewPatternsFail.stderr
new file mode 100644
index 0000000000..97d82b4c16
--- /dev/null
+++ b/testsuite/tests/parser/should_fail/ViewPatternsFail.stderr
@@ -0,0 +1,4 @@
+
+ViewPatternsFail.hs:7:6: error:
+    Illegal view pattern:  a -> l
+    Suggested fix: Perhaps you intended to use ViewPatterns
diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T
index 7787826a4b..c288f47c2f 100644
--- a/testsuite/tests/parser/should_fail/all.T
+++ b/testsuite/tests/parser/should_fail/all.T
@@ -195,3 +195,4 @@ test('T19923a', normal, compile_fail, [''])
 test('T19923b', normal, compile_fail, [''])
 test('T19923c', normal, compile_fail, [''])
 test('RecordWildCardsFail', normal, compile_fail, [''])
+test('ViewPatternsFail', normal, compile_fail, [''])