Meaning-preserving SCC annotations (#15730)

This patch implements GHC Proposal #176:
  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst

Before the change:

  1 /                    2 / 2 = 0.25
  1 / {-# SCC "name" #-} 2 / 2 = 1.0

After the change:

  1 /                    2 / 2 = 0.25
  1 / {-# SCC "name" #-} 2 / 2 = parse error

1 files changed, 93 insertions, 48 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 0076a01992..4272da7c82 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1080,7 +1080,7 @@ topdecl :: { LHsDecl GhcPs }
         -- The $(..) form is one possible form of infixexp
         -- but we treat an arbitrary expression just as if
         -- it had a $(..) wrapped around it
-        | infixexp_top                          {% runECP_P $1 >>= \ $1 ->
+        | infixexp                              {% runECP_P $1 >>= \ $1 ->
                                                    return $ sLL $1 $> $ mkSpliceDecl $1 }
 
 -- Type classes
@@ -2430,7 +2430,7 @@ docdecld :: { LDocDecl }
 decl_no_th :: { LHsDecl GhcPs }
         : sigdecl               { $1 }
 
-        | infixexp_top opt_sig rhs  {% runECP_P $1 >>= \ $1 ->
+        | infixexp     opt_sig rhs  {% runECP_P $1 >>= \ $1 ->
                                        do { (ann,r) <- checkValDef $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         -- Depending upon what the pattern looks like we might get either
@@ -2476,7 +2476,7 @@ gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }
 sigdecl :: { LHsDecl GhcPs }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
-          infixexp_top '::' sigtypedoc
+          infixexp     '::' sigtypedoc
                         {% do { $1 <- runECP_P $1
                               ; v <- checkValSigLhs $1
                               ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]
@@ -2571,7 +2571,8 @@ quasiquote :: { Located (HsSplice GhcPs) }
                             in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) }
 
 exp   :: { ECP }
-        : infixexp '::' sigtype { ECP $
+        : infixexp_no_prag '::' sigtype
+                                { ECP $
                                    runECP_PV $1 >>= \ $1 ->
                                    amms (mkHsTySigPV (comb2 $1 $>) $1 $3)
                                        [mu AnnDcolon $2] }
@@ -2600,10 +2601,35 @@ exp   :: { ECP }
                                                       HsHigherOrderApp False)
                                        [mu AnnRarrowtail $2] }
         | infixexp              { $1 }
+        | 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]
+                               { 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
+
+last_exp10 :: { ECP }
+  : exp10                { $1 }
+  | exp_prag(last_exp10) { $1 } -- See Note [Pragmas and operator fixity]
+
+exp_prag(e) :: { ECP }
+  : prag_e e  -- See Note [Pragmas and operator fixity]
+      {% runECP_P $2 >>= \ $2 ->
+         fmap ecpFromExp $
+         ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
+             (fst $ unLoc $1) }
+
+infixexp_no_prag :: { ECP }
         : exp10 { $1 }
-        | infixexp qop exp10  {  ECP $
+        | infixexp_no_prag qop exp10
+                               { ECP $
                                  superInfixOp $
                                  $2 >>= \ $2 ->
                                  runECP_PV $1 >>= \ $1 ->
@@ -2612,49 +2638,75 @@ infixexp :: { ECP }
                                      [mj AnnVal $2] }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
 
-infixexp_top :: { ECP }
-            : exp10_top               { $1 }
-            | infixexp_top qop exp10_top
-                                      { ECP $
-                                         superInfixOp $
-                                         $2 >>= \ $2 ->
-                                         runECP_PV $1 >>= \ $1 ->
-                                         runECP_PV $3 >>= \ $3 ->
-                                         amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)
-                                              [mj AnnVal $2] }
-
-exp10_top :: { ECP }
+exp10 :: { ECP }
         : '-' fexp                      { ECP $
                                            runECP_PV $2 >>= \ $2 ->
                                            amms (mkHsNegAppPV (comb2 $1 $>) $2)
                                                [mj AnnMinus $1] }
-
-        | exp_annot (prag_hpc)         { $1 }
-        | exp_annot (prag_core)        { $1 }
         | fexp                         { $1 }
 
-exp10 :: { ECP }
-        : exp10_top            { $1 }
-        | exp_annot(prag_scc)  { $1 }
-
 optSemi :: { ([Located Token],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }
 
-prag_scc :: { Located ([AddAnn], HsPragE GhcPs) }
-        : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
-                                            ; return $ sLL $1 $>
-                                               ([mo $1,mj AnnValStr $2,mc $3],
-                                                HsPragSCC noExtField
-                                                  (getSCC_PRAGs $1)
-                                                  (StringLiteral (getSTRINGs $2) scc)) }
-        | '{-# SCC' VARID  '#-}'      { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
-                                                    HsPragSCC noExtField
-                                                      (getSCC_PRAGs $1)
-                                                      (StringLiteral NoSourceText (getVARID $2))) }
-
-prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
-      : '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
+{- Note [Pragmas and operator fixity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'prag_e' is an expression pragma, such as {-# SCC ... #-}, {-# CORE ... #-}, or
+{-# GENERATED ... #-}.
+
+It must be used with care, or else #15730 happens. Consider this infix
+expression:
+
+         1 / 2 / 2
+
+There are two ways to parse it:
+
+    1.   (1 / 2) / 2   =  0.25
+    2.   1 / (2 / 2)   =  1.0
+
+Due to the fixity of the (/) operator (assuming it comes from Prelude),
+option 1 is the correct parse. However, in the past GHC's parser used to get
+confused by the SCC annotation when it occurred in the middle of an infix
+expression:
+
+         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2
+
+There are several ways to address this issue, see GHC Proposal #176 for a
+detailed exposition:
+
+  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst
+
+The accepted fix is to disallow pragmas that occur within infix expressions.
+Infix expressions are assembled out of 'exp10', so 'exp10' must not accept
+pragmas. Instead, we accept them in exactly two places:
+
+* at the start of an expression or a parenthesized subexpression:
+
+    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression
+    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression
+
+* immediately after the last operator:
+
+    f = 1 / 2 / {-# SCC ann #-} 2
+
+In both cases, the parse does not depend on operator fixity. The second case
+may sound unnecessary, but it's actually needed to support a common idiom:
+
+    f $ {-# SCC ann $-} ...
+
+-}
+prag_e :: { Located ([AddAnn], HsPragE GhcPs) }
+      : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
+                                          ; return $ sLL $1 $>
+                                             ([mo $1,mj AnnValStr $2,mc $3],
+                                              HsPragSCC noExtField
+                                                (getSCC_PRAGs $1)
+                                                (StringLiteral (getSTRINGs $2) scc)) }
+      | '{-# SCC' VARID  '#-}'      { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
+                                                  HsPragSCC noExtField
+                                                    (getSCC_PRAGs $1)
+                                                    (StringLiteral NoSourceText (getVARID $2))) }
+      | '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}'
                                       { let getINT = fromInteger . il_value . getINTEGER in
                                         sLL $1 $> $ ([mo $1,mj AnnVal $2
                                               ,mj AnnVal $3,mj AnnColon $4
@@ -2668,19 +2720,11 @@ prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
                                                  (getINT $7, getINT $9))
                                                 ((getINTEGERs $3, getINTEGERs $5),
                                                  (getINTEGERs $7, getINTEGERs $9) )) }
-
-prag_core :: { Located ([AddAnn], HsPragE GhcPs) }
-      : '{-# CORE' STRING '#-}'
+      | '{-# CORE' STRING '#-}'
         { sLL $1 $> $
             ([mo $1,mj AnnVal $2,mc $3],
              HsPragCore noExtField (getCORE_PRAGs $1) (getStringLiteral $2)) }
 
-exp_annot(prag) :: { ECP }
-      : prag exp             {% runECP_P $2 >>= \ $2 ->
-                                fmap ecpFromExp $
-                                ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)
-                                    (fst $ unLoc $1) }
-
 fexp    :: { ECP }
         : fexp aexp                  { ECP $
                                           superFunArg $
@@ -2912,7 +2956,8 @@ texp :: { ECP }
         -- Then when converting expr to pattern we unravel it again
         -- Meanwhile, the renamer checks that real sections appear
         -- inside parens.
-        | infixexp qop       {% runECP_P $1 >>= \ $1 ->
+        | infixexp_no_prag qop
+                             {% runECP_P $1 >>= \ $1 ->
                                 runPV $2 >>= \ $2 ->
                                 return $ ecpFromExp $
                                 sLL $1 $> $ SectionL noExtField $1 $2 }