Support SCC pragmas in declaration context

Not having SCCs at the top level is becoming annoying real quick. For
simplest cases, it's possible to do this transformation:

    f x y = ...
    =>
    f = {-# SCC f #-} \x y -> ...

However, it doesn't work when there's a `where` clause:

    f x y = <t is in scope>
      where t = ...
    =>
    f = {-# SCC f #-} \x y -> <t is out of scope>
      where t = ...

Or when we have a "equation style" definition:

    f (C1 ...) = ...
    f (C2 ...) = ...
    f (C3 ...) = ...
    ...

(usual solution is to rename `f` to `f'` and define a new `f` with a
`SCC`)

This patch implements support for SCC annotations in declaration
contexts. This is now a valid program:

    f x y = ...
      where
        g z = ...
        {-# SCC g #-}
    {-# SCC f #-}

Test Plan: This passes slow validate (no new failures added).

Reviewers: goldfire, mpickering, austin, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: simonmar, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2407

1 files changed, 27 insertions, 11 deletions

diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e8d60ec611..fea9203811 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -835,7 +835,7 @@ topdecl :: { LHsDecl RdrName }
         -- The $(..) form is one possible form of infixexp
         -- but we treat an arbitrary expression just as if
         -- it had a $(..) wrapped around it
-        | infixexp                              { sLL $1 $> $ mkSpliceDecl $1 }
+        | infixexp_top                          { sLL $1 $> $ mkSpliceDecl $1 }
 
 -- Type classes
 --
@@ -1989,7 +1989,7 @@ decl_no_th :: { LHsDecl RdrName }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
-        | infixexp opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
+        | infixexp_top opt_sig rhs  {% do { (ann,r) <- checkValDef empty $1 (snd $2) $3;
                                         let { l = comb2 $1 $> };
                                         case r of {
                                           (FunBind n _ _ _ _) ->
@@ -2029,7 +2029,7 @@ gdrh :: { LGRHS RdrName (LHsExpr RdrName) }
 sigdecl :: { LHsDecl RdrName }
         :
         -- See Note [Declaration/signature overlap] for why we need infixexp here
-          infixexp '::' sigtypedoc
+          infixexp_top '::' sigtypedoc
                         {% do v <- checkValSigLhs $1
                         ; _ <- ams (sLL $1 $> ()) [mu AnnDcolon $2]
                         ; return (sLL $1 $> $ SigD $
@@ -2056,6 +2056,16 @@ sigdecl :: { LHsDecl RdrName }
                                             (snd $2)))))
                        ((mo $1:fst $2) ++ [mc $4]) }
 
+        | '{-# SCC' qvar '#-}'
+          {% ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 Nothing)))
+                 [mo $1, mc $3] }
+
+        | '{-# SCC' qvar STRING '#-}'
+          {% do { scc <- getSCC $3
+                ; let str_lit = StringLiteral (getSTRINGs $3) scc
+                ; ams (sLL $1 $> (SigD (SCCFunSig (getSCC_PRAGs $1) $2 (Just str_lit))))
+                      [mo $1, mc $4] } }
+
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
              {% ams (
                  let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)
@@ -2121,14 +2131,18 @@ exp   :: { LHsExpr RdrName }
         | infixexp              { $1 }
 
 infixexp :: { LHsExpr RdrName }
-        : exp10                   { $1 }
-        | infixexp qop exp10      {% ams (sLL $1 $>
-                                             (OpApp $1 $2 placeHolderFixity $3))
-                                         [mj AnnVal $2] }
+        : exp10 { $1 }
+        | infixexp qop exp10  {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+                                     [mj AnnVal $2] }
                  -- AnnVal annotation for NPlusKPat, which discards the operator
 
+infixexp_top :: { LHsExpr RdrName }
+        : exp10_top               { $1 }
+        | infixexp_top qop exp10_top
+                                  {% ams (sLL $1 $> (OpApp $1 $2 placeHolderFixity $3))
+                                         [mj AnnVal $2] }
 
-exp10 :: { LHsExpr RdrName }
+exp10_top :: { LHsExpr RdrName }
         : '\\' apat apats opt_asig '->' exp
                    {% ams (sLL $1 $> $ HsLam (mkMatchGroup FromSource
                             [sLL $1 $> $ Match { m_ctxt = LambdaExpr
@@ -2170,9 +2184,6 @@ exp10 :: { LHsExpr RdrName }
                                               (mkHsDo MDoExpr (snd $ unLoc $2)))
                                            (mj AnnMdo $1:(fst $ unLoc $2)) }
 
-        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
-                                      (fst $ fst $ unLoc $1) }
-
         | hpc_annot exp        {% ams (sLL $1 $> $ HsTickPragma (snd $ fst $ fst $ unLoc $1)
                                                                 (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
                                       (fst $ fst $ fst $ unLoc $1) }
@@ -2191,6 +2202,11 @@ exp10 :: { LHsExpr RdrName }
                                           -- hdaume: core annotation
         | fexp                         { $1 }
 
+exp10 :: { LHsExpr RdrName }
+        : exp10_top            { $1 }
+        | scc_annot exp        {% ams (sLL $1 $> $ HsSCC (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
+                                      (fst $ fst $ unLoc $1) }
+
 optSemi :: { ([Located a],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }