Improve error messages for SCC pragmas

4 files changed, 26 insertions, 21 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 4272da7c82..ce4d277f6b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2571,9 +2571,10 @@ quasiquote :: { Located (HsSplice GhcPs) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { ECP }
-        : infixexp_no_prag '::' sigtype
+        : infixexp '::' sigtype
                                 { ECP $
                                    runECP_PV $1 >>= \ $1 ->
+                                   rejectPragmaPV $1 >>
                                    amms (mkHsTySigPV (comb2 $1 $>) $1 $3)
                                        [mu AnnDcolon $2] }
         | infixexp '-<' exp     {% runECP_P $1 >>= \ $1 ->
@@ -2604,20 +2605,21 @@ exp   :: { ECP }
         | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]
 
 infixexp :: { ECP }
-        : infixexp_no_prag    { $1 }
-        | infixexp_no_prag qop exp_prag(last_exp10)    -- See Note [Pragmas and operator fixity]
+        : exp10 { $1 }
+        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]
                                { ECP $
                                  superInfixOp $
                                  $2 >>= \ $2 ->
                                  runECP_PV $1 >>= \ $1 ->
                                  runECP_PV $3 >>= \ $3 ->
+                                 rejectPragmaPV $1 >>
                                  amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
                                      [mj AnnVal $2] }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
 
-last_exp10 :: { ECP }
-  : exp10                { $1 }
-  | exp_prag(last_exp10) { $1 } -- See Note [Pragmas and operator fixity]
+exp10p :: { ECP }
+  : exp10            { $1 }
+  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]
 
 exp_prag(e) :: { ECP }
   : prag_e e  -- See Note [Pragmas and operator fixity]
@@ -2626,18 +2628,6 @@ exp_prag(e) :: { ECP }
          ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
              (fst $ unLoc $1) }
 
-infixexp_no_prag :: { ECP }
-        : exp10 { $1 }
-        | infixexp_no_prag qop exp10
-                               { ECP $
-                                 superInfixOp $
-                                 $2 >>= \ $2 ->
-                                 runECP_PV $1 >>= \ $1 ->
-                                 runECP_PV $3 >>= \ $3 ->
-                                 amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
-                                     [mj AnnVal $2] }
-                 -- AnnVal annotation for NPlusKPat, which discards the operator
-
 exp10 :: { ECP }
         : '-' fexp                      { ECP $
                                            runECP_PV $2 >>= \ $2 ->
@@ -2956,8 +2946,9 @@ texp :: { ECP }
         -- Then when converting expr to pattern we unravel it again
         -- Meanwhile, the renamer checks that real sections appear
         -- inside parens.
-        | infixexp_no_prag qop
+        | infixexp qop
                              {% runECP_P $1 >>= \ $1 ->
+                                runPV (rejectPragmaPV $1) >>
                                 runPV $2 >>= \ $2 ->
                                 return $ ecpFromExp $
                                 sLL $1 $> $ SectionL noExtField $1 $2 }
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 0ffad547a7..75ce613353 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -1807,6 +1807,9 @@ class b ~ (Body b) GhcPs => DisambECP b where
   mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b)
   -- | Disambiguate tuple sections and unboxed sums
   mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)
+  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas
+  rejectPragmaPV :: Located b -> PV ()
+
 
 {- Note [UndecidableSuperClasses for associated types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1899,6 +1902,7 @@ instance DisambECP (HsCmd GhcPs) where
   mkHsBangPatPV l c = cmdFail l $
     text "!" <> ppr c
   mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a)
+  rejectPragmaPV _ = return ()
 
 cmdFail :: SrcSpan -> SDoc -> PV a
 cmdFail loc e = addFatalError loc $
@@ -1951,6 +1955,13 @@ instance DisambECP (HsExpr GhcPs) where
   mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $
     text "Did you mean to add a space after the '!'?"
   mkSumOrTuplePV = mkSumOrTupleExpr
+  rejectPragmaPV (L _ (OpApp _ _ _ e)) =
+    -- assuming left-associative parsing of operators
+    rejectPragmaPV e
+  rejectPragmaPV (L l (HsPragE _ prag _)) =
+    addError l $
+      hang (text "A pragma is not allowed in this position:") 2 (ppr prag)
+  rejectPragmaPV _ = return ()
 
 patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)
 patSynErr item l e explanation =
@@ -2039,6 +2050,7 @@ instance DisambECP (PatBuilder GhcPs) where
     hintBangPat l pb
     return $ L l (PatBuilderPat pb)
   mkSumOrTuplePV = mkSumOrTuplePat
+  rejectPragmaPV _ = return ()
 
 checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()
 checkUnboxedStringLitPat (L loc lit) =
diff --git a/testsuite/tests/parser/should_fail/T15730.stderr b/testsuite/tests/parser/should_fail/T15730.stderr
index 32b5b33759..7eb649e1b6 100644
--- a/testsuite/tests/parser/should_fail/T15730.stderr
+++ b/testsuite/tests/parser/should_fail/T15730.stderr
@@ -1,2 +1,3 @@
 
-T15730.hs:3:27: error: parse error on input ‘/’
+T15730.hs:3:9: error:
+    A pragma is not allowed in this position: {-# SCC ann #-}
diff --git a/testsuite/tests/parser/should_fail/T15730b.stderr b/testsuite/tests/parser/should_fail/T15730b.stderr
index 5794dc00fe..032c5a49f4 100644
--- a/testsuite/tests/parser/should_fail/T15730b.stderr
+++ b/testsuite/tests/parser/should_fail/T15730b.stderr
@@ -1,2 +1,3 @@
 
-T15730b.hs:8:48: error: parse error on input ‘::’
+T15730b.hs:8:16: error:
+    A pragma is not allowed in this position: {-# SCC a1 #-}