Factor out HsSCC/HsCoreAnn/HsTickPragma into HsPragEwip/hs-prag

This is a refactoring with no user-visible changes (except for GHC API
users). Consider the HsExpr constructors that correspond to user-written
pragmas:

  HsSCC         representing  {-# SCC ... #-}
  HsCoreAnn     representing  {-# CORE ... #-}
  HsTickPragma  representing  {-# GENERATED ... #-}

We can factor them out into a separate datatype, HsPragE. It makes the
code a bit tidier, especially in the parser.

Before this patch:

  hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))),
                           ((SourceText,SourceText),(SourceText,SourceText))
                         ) }

After this patch:

  prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }

16 files changed, 169 insertions, 183 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 7921a61697..8a8eb775cd 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -431,19 +431,6 @@ data HsExpr p
                 (ArithSeqInfo p)
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsSCC       (XSCC p)
-                SourceText            -- Note [Pragma source text] in BasicTypes
-                StringLiteral         -- "set cost centre" SCC pragma
-                (LHsExpr p)           -- expr whose cost is to be measured
-
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsCoreAnn   (XCoreAnn p)
-                SourceText            -- Note [Pragma source text] in BasicTypes
-                StringLiteral         -- hdaume: core annotation
-                (LHsExpr p)
 
   -----------------------------------------------------------
   -- MetaHaskell Extensions
@@ -511,25 +498,9 @@ data HsExpr p
      Int                                -- module-local tick number for False
      (LHsExpr p)                        -- sub-expression
 
-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
-  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
-  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
-  --       'ApiAnnotation.AnnMinus',
-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
-  --       'ApiAnnotation.AnnVal',
-  --       'ApiAnnotation.AnnClose' @'\#-}'@
-
-  -- For details on above see note [Api annotations] in ApiAnnotation
-  | HsTickPragma                      -- A pragma introduced tick
-     (XTickPragma p)
-     SourceText                       -- Note [Pragma source text] in BasicTypes
-     (StringLiteral,(Int,Int),(Int,Int))
-                                      -- external span for this tick
-     ((SourceText,SourceText),(SourceText,SourceText))
-        -- Source text for the four integers used in the span.
-        -- See note [Pragma source text] in BasicTypes
-     (LHsExpr p)
+  ---------------------------------------
+  -- Expressions annotated with pragmas, written as {-# ... #-}
+  | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
 
   ---------------------------------------
   -- Finally, HsWrap appears only in typechecker output
@@ -625,8 +596,6 @@ type instance XArithSeq      GhcPs = NoExtField
 type instance XArithSeq      GhcRn = NoExtField
 type instance XArithSeq      GhcTc = PostTcExpr
 
-type instance XSCC           (GhcPass _) = NoExtField
-type instance XCoreAnn       (GhcPass _) = NoExtField
 type instance XBracket       (GhcPass _) = NoExtField
 
 type instance XRnBracketOut  (GhcPass _) = NoExtField
@@ -641,12 +610,54 @@ type instance XStatic        GhcTc = NameSet
 
 type instance XTick          (GhcPass _) = NoExtField
 type instance XBinTick       (GhcPass _) = NoExtField
-type instance XTickPragma    (GhcPass _) = NoExtField
+
+type instance XPragE         (GhcPass _) = NoExtField
+
 type instance XWrap          (GhcPass _) = NoExtField
 type instance XXExpr         (GhcPass _) = NoExtCon
 
 -- ---------------------------------------------------------------------
 
+-- | A pragma, written as {-# ... #-}, that may appear within an expression.
+data HsPragE p
+  = HsPragSCC   (XSCC p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
+                StringLiteral         -- "set cost centre" SCC pragma
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,
+  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsPragCore  (XCoreAnn p)
+                SourceText            -- Note [Pragma source text] in BasicTypes
+                StringLiteral         -- hdaume: core annotation
+
+  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
+  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnMinus',
+  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',
+  --       'ApiAnnotation.AnnVal',
+  --       'ApiAnnotation.AnnClose' @'\#-}'@
+
+  -- For details on above see note [Api annotations] in ApiAnnotation
+  | HsPragTick                        -- A pragma introduced tick
+     (XTickPragma p)
+     SourceText                       -- Note [Pragma source text] in BasicTypes
+     (StringLiteral,(Int,Int),(Int,Int))
+                                      -- external span for this tick
+     ((SourceText,SourceText),(SourceText,SourceText))
+        -- Source text for the four integers used in the span.
+        -- See note [Pragma source text] in BasicTypes
+
+  | XHsPragE (XXPragE p)
+
+type instance XSCC           (GhcPass _) = NoExtField
+type instance XCoreAnn       (GhcPass _) = NoExtField
+type instance XTickPragma    (GhcPass _) = NoExtField
+type instance XXPragE        (GhcPass _) = NoExtCon
+
 -- | Located Haskell Tuple Argument
 --
 -- 'HsTupArg' is used for tuple sections
@@ -857,10 +868,7 @@ ppr_expr (HsLit _ lit)      = ppr lit
 ppr_expr (HsOverLit _ lit)  = ppr lit
 ppr_expr (HsPar _ e)        = parens (ppr_lexpr e)
 
-ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)
-  = vcat [pprWithSourceText stc (text "{-# CORE")
-          <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
-         , ppr_lexpr e]
+ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]
 
 ppr_expr e@(HsApp {})        = ppr_apps e []
 ppr_expr e@(HsAppType {})    = ppr_apps e []
@@ -990,13 +998,6 @@ ppr_expr (ExprWithTySig _ expr sig)
 
 ppr_expr (ArithSeq _ _ info) = brackets (ppr info)
 
-ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)
-  = sep [ pprWithSourceText st (text "{-# SCC")
-         -- no doublequotes if stl empty, for the case where the SCC was written
-         -- without quotes.
-          <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",
-          ppr expr ]
-
 ppr_expr (HsWrap _ co_fn e)
   = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
                                              else pprExpr e)
@@ -1027,13 +1028,6 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
           ppr tickIdFalse,
           text ">(",
           ppr exp, text ")"]
-ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)
-  = pprTicks (ppr exp) $
-    hcat [text "tickpragma<",
-          pprExternalSrcLoc externalSrcLoc,
-          text ">(",
-          ppr exp,
-          text ")"]
 
 ppr_expr (HsRecFld _ f) = ppr f
 ppr_expr (XExpr x) = ppr x
@@ -1110,7 +1104,6 @@ hsExprNeedsParens p = go
     go (HsLit _ l)                    = hsLitNeedsParens p l
     go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol
     go (HsPar{})                      = False
-    go (HsCoreAnn _ _ _ (L _ e))      = go e
     go (HsApp{})                      = p >= appPrec
     go (HsAppType {})                 = p >= appPrec
     go (OpApp{})                      = p >= opPrec
@@ -1132,7 +1125,7 @@ hsExprNeedsParens p = go
     go (RecordUpd{})                  = False
     go (ExprWithTySig{})              = p >= sigPrec
     go (ArithSeq{})                   = False
-    go (HsSCC{})                      = p >= appPrec
+    go (HsPragE{})                    = p >= appPrec
     go (HsWrap _ _ e)                 = go e
     go (HsSpliceE{})                  = False
     go (HsBracket{})                  = False
@@ -1142,7 +1135,6 @@ hsExprNeedsParens p = go
     go (HsStatic{})                   = p >= appPrec
     go (HsTick _ _ (L _ e))           = go e
     go (HsBinTick _ _ _ (L _ e))      = go e
-    go (HsTickPragma _ _ _ _ (L _ e)) = go e
     go (RecordCon{})                  = False
     go (HsRecFld{})                   = False
     go (XExpr{})                      = True
@@ -1172,6 +1164,24 @@ isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr _                 = False
 
+instance Outputable (HsPragE (GhcPass p)) where
+  ppr (HsPragCore _ stc (StringLiteral sta s)) =
+    pprWithSourceText stc (text "{-# CORE")
+    <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
+  ppr (HsPragSCC _ st (StringLiteral stl lbl)) =
+    pprWithSourceText st (text "{-# SCC")
+     -- no doublequotes if stl empty, for the case where the SCC was written
+     -- without quotes.
+    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"
+  ppr (HsPragTick _ st (StringLiteral sta s, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) =
+    pprWithSourceText st (text "{-# GENERATED")
+    <+> pprWithSourceText sta (doubleQuotes $ ftext s)
+    <+> pprWithSourceText s1 (ppr v1) <+> char ':' <+> pprWithSourceText s2 (ppr v2)
+    <+> char '-'
+    <+> pprWithSourceText s3 (ppr v3) <+> char ':' <+> pprWithSourceText s4 (ppr v4)
+    <+> text "#-}"
+  ppr (XHsPragE x) = noExtCon x
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 6b1042700a..be0333933a 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -606,8 +606,6 @@ type family XRecordCon      x
 type family XRecordUpd      x
 type family XExprWithTySig  x
 type family XArithSeq       x
-type family XSCC            x
-type family XCoreAnn        x
 type family XBracket        x
 type family XRnBracketOut   x
 type family XTcBracketOut   x
@@ -616,10 +614,15 @@ type family XProc           x
 type family XStatic         x
 type family XTick           x
 type family XBinTick        x
-type family XTickPragma     x
+type family XPragE          x
 type family XWrap           x
 type family XXExpr          x
 
+type family XSCC            x
+type family XCoreAnn        x
+type family XTickPragma     x
+type family XXPragE         x
+
 type ForallXExpr (c :: * -> Constraint) (x :: *) =
        ( c (XVar            x)
        , c (XUnboundVar     x)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index b3a33df43c..5f6fae2cb2 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -247,6 +247,11 @@ deriving instance Data (SyntaxExpr GhcPs)
 deriving instance Data (SyntaxExpr GhcRn)
 deriving instance Data (SyntaxExpr GhcTc)
 
+-- deriving instance (DataIdLR p p) => Data (HsPragE p)
+deriving instance Data (HsPragE GhcPs)
+deriving instance Data (HsPragE GhcRn)
+deriving instance Data (HsPragE GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (HsExpr p)
 deriving instance Data (HsExpr GhcPs)
 deriving instance Data (HsExpr GhcRn)
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 6dd6d37a9a..cfff423037 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -606,20 +606,12 @@ addTickHsExpr (HsTick x t e) =
 addTickHsExpr (HsBinTick x t0 t1 e) =
         liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
 
-addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do
+addTickHsExpr (HsPragE _ HsPragTick{} (dL->L pos e0)) = do
     e2 <- allocTickBox (ExpBox False) False False pos $
                 addTickHsExpr e0
     return $ unLoc e2
-addTickHsExpr (HsSCC x src nm e) =
-        liftM3 (HsSCC x)
-                (return src)
-                (return nm)
-                (addTickLHsExpr e)
-addTickHsExpr (HsCoreAnn x src nm e) =
-        liftM3 (HsCoreAnn x)
-                (return src)
-                (return nm)
-                (addTickLHsExpr e)
+addTickHsExpr (HsPragE x p e) =
+        liftM (HsPragE x p) (addTickLHsExpr e)
 addTickHsExpr e@(HsBracket     {})   = return e
 addTickHsExpr e@(HsTcBracketOut  {}) = return e
 addTickHsExpr e@(HsRnBracketOut  {}) = return e
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index d0409ffd71..e0bb58bd49 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -402,20 +402,8 @@ ds_expr _ (ExplicitSum types alt arity expr)
                                       map Type types ++
                                       [core_expr]) ) }
 
-ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do
-    dflags <- getDynFlags
-    if gopt Opt_SccProfilingOn dflags
-      then do
-        mod_name <- getModule
-        count <- goptM Opt_ProfCountEntries
-        let nm = sl_fs cc
-        flavour <- ExprCC <$> getCCIndexM nm
-        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
-               <$> dsLExpr expr
-      else dsLExpr expr
-
-ds_expr _ (HsCoreAnn _ _ _ expr)
-  = dsLExpr expr
+ds_expr _ (HsPragE _ prag expr) =
+  ds_prag_expr prag expr
 
 ds_expr _ (HsCase _ discrim matches)
   = do { core_discrim <- dsLExpr discrim
@@ -745,18 +733,32 @@ ds_expr _ (HsBinTick _ ixT ixF e) = do
        mkBinaryTickBox ixT ixF e2
      }
 
-ds_expr _ (HsTickPragma _ _ _ _ expr) = do
-  dflags <- getDynFlags
-  if gopt Opt_Hpc dflags
-    then panic "dsExpr:HsTickPragma"
-    else dsLExpr expr
-
 -- HsSyn constructs that just shouldn't be here:
 ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
 ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
 ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
 ds_expr _ (XExpr nec)         = noExtCon nec
 
+ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
+ds_prag_expr (HsPragSCC _ _ cc) expr = do
+    dflags <- getDynFlags
+    if gopt Opt_SccProfilingOn dflags
+      then do
+        mod_name <- getModule
+        count <- goptM Opt_ProfCountEntries
+        let nm = sl_fs cc
+        flavour <- ExprCC <$> getCCIndexM nm
+        Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True)
+               <$> dsLExpr expr
+      else dsLExpr expr
+ds_prag_expr (HsPragCore _ _ _) expr
+  = dsLExpr expr
+ds_prag_expr (HsPragTick _ _ _ _) expr = do
+  dflags <- getDynFlags
+  if gopt Opt_Hpc dflags
+    then panic "dsExpr:HsPragTick"
+    else dsLExpr expr
+ds_prag_expr (XHsPragE x) _ = noExtCon x
 
 ------------------------------
 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index c69b1da6e8..4c38212648 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1398,9 +1398,9 @@ repE (HsUnboundVar _ uv)   = do
                                sname <- repNameS occ
                                repUnboundVar sname
 
-repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
-repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
-repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)
+repE e@(HsPragE _ HsPragCore {} _)   = notHandled "Core annotations" (ppr e)
+repE e@(HsPragE _ HsPragSCC  {} _)   = notHandled "Cost centres" (ppr e)
+repE e@(HsPragE _ HsPragTick {} _)   = notHandled "Tick Pragma" (ppr e)
 repE e                     = notHandled "Expression form" (ppr e)
 
 -----------------------------------------------------------------------------
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index c62ab0ae83..40bb914d31 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -978,10 +978,7 @@ instance ( a ~ GhcPass p
       ArithSeq _ _ info ->
         [ toHie info
         ]
-      HsSCC _ _ _ expr ->
-        [ toHie expr
-        ]
-      HsCoreAnn _ _ _ expr ->
+      HsPragE _ _ expr ->
         [ toHie expr
         ]
       HsProc _ pat cmdtop ->
@@ -997,9 +994,6 @@ instance ( a ~ GhcPass p
       HsBinTick _ _ _ expr ->
         [ toHie expr
         ]
-      HsTickPragma _ _ _ _ expr ->
-        [ toHie expr
-        ]
       HsWrap _ _ a ->
         [ toHie $ L mspan a
         ]
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index b91e1681c5..01d2424a08 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2629,66 +2629,57 @@ exp10_top :: { ECP }
                                            amms (mkHsNegAppPV (comb2 $1 $>) $2)
                                                [mj AnnMinus $1] }
 
-
-        | hpc_annot exp        {% runECP_P $2 >>= \ $2 ->
-                                  fmap ecpFromExp $
-                                  ams (sLL $1 $> $ HsTickPragma noExtField (snd $ fst $ fst $ unLoc $1)
-                                                                (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
-                                      (fst $ fst $ fst $ unLoc $1) }
-
-        | '{-# CORE' STRING '#-}' exp  {% runECP_P $4 >>= \ $4 ->
-                                          fmap ecpFromExp $
-                                          ams (sLL $1 $> $ HsCoreAnn noExtField (getCORE_PRAGs $1) (getStringLiteral $2) $4)
-                                              [mo $1,mj AnnVal $2
-                                              ,mc $3] }
-                                          -- hdaume: core annotation
+        | exp_annot (prag_hpc)         { $1 }
+        | exp_annot (prag_core)        { $1 }
         | fexp                         { $1 }
 
 exp10 :: { ECP }
         : exp10_top            { $1 }
-        | scc_annot exp        {% runECP_P $2 >>= \ $2 ->
-                                  fmap ecpFromExp $
-                                  ams (sLL $1 $> $ HsSCC noExtField (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
-                                      (fst $ fst $ unLoc $1) }
+        | exp_annot(prag_scc)  { $1 }
 
 optSemi :: { ([Located Token],Bool) }
         : ';'         { ([$1],True) }
         | {- empty -} { ([],False) }
 
-scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) }
+prag_scc :: { Located ([AddAnn], HsPragE GhcPs) }
         : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2
                                             ; return $ sLL $1 $>
-                                               (([mo $1,mj AnnValStr $2
-                                                ,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) }
-        | '{-# SCC' VARID  '#-}'      { sLL $1 $> (([mo $1,mj AnnVal $2
-                                         ,mc $3],getSCC_PRAGs $1)
-                                        ,(StringLiteral NoSourceText (getVARID $2))) }
-
-hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))),
-                         ((SourceText,SourceText),(SourceText,SourceText))
-                       ) }
+                                               ([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 '#-}'
-                                      { sLL $1 $> $ ((([mo $1,mj AnnVal $2
+                                      { let getINT = fromInteger . il_value . getINTEGER in
+                                        sLL $1 $> $ ([mo $1,mj AnnVal $2
                                               ,mj AnnVal $3,mj AnnColon $4
                                               ,mj AnnVal $5,mj AnnMinus $6
                                               ,mj AnnVal $7,mj AnnColon $8
                                               ,mj AnnVal $9,mc $10],
-                                                getGENERATED_PRAGs $1)
-                                              ,((getStringLiteral $2)
-                                               ,( fromInteger $ il_value $ getINTEGER $3
-                                                , fromInteger $ il_value $ getINTEGER $5
-                                                )
-                                               ,( fromInteger $ il_value $ getINTEGER $7
-                                                , fromInteger $ il_value $ getINTEGER $9
-                                                )
-                                               ))
-                                             , (( getINTEGERs $3
-                                                , getINTEGERs $5
-                                                )
-                                               ,( getINTEGERs $7
-                                                , getINTEGERs $9
-                                                )))
-                                         }
+                                              HsPragTick noExtField
+                                                (getGENERATED_PRAGs $1)
+                                                (getStringLiteral $2,
+                                                 (getINT $3, getINT $5),
+                                                 (getINT $7, getINT $9))
+                                                ((getINTEGERs $3, getINTEGERs $5),
+                                                 (getINTEGERs $7, getINTEGERs $9) )) }
+
+prag_core :: { Located ([AddAnn], HsPragE GhcPs) }
+      : '{-# 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 $
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index d3f72fff47..59ca753ae4 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -232,16 +232,15 @@ rnExpr expr@(SectionR {})
   = do  { addErr (sectionErr expr); rnSection expr }
 
 ---------------------------------------------
-rnExpr (HsCoreAnn x src ann expr)
+rnExpr (HsPragE x prag expr)
   = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsCoreAnn x src ann expr', fvs_expr) }
-
-rnExpr (HsSCC x src lbl expr)
-  = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsSCC x src lbl expr', fvs_expr) }
-rnExpr (HsTickPragma x src info srcInfo expr)
-  = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
+       ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
+  where
+    rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
+    rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
+    rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl
+    rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
+    rn_prag (XHsPragE x) = noExtCon x
 
 rnExpr (HsLam x matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 712668f372..5560b219ba 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -181,17 +181,15 @@ tcExpr e@(HsLit x lit) res_ty
 tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
                                   ; return (HsPar x expr') }
 
-tcExpr (HsSCC x src lbl expr) res_ty
+tcExpr (HsPragE x prag expr) res_ty
   = do { expr' <- tcMonoExpr expr res_ty
-       ; return (HsSCC x src lbl expr') }
-
-tcExpr (HsTickPragma x src info srcInfo expr) res_ty
-  = do { expr' <- tcMonoExpr expr res_ty
-       ; return (HsTickPragma x src info srcInfo expr') }
-
-tcExpr (HsCoreAnn x src lbl expr) res_ty
-  = do  { expr' <- tcMonoExpr expr res_ty
-        ; return (HsCoreAnn x src lbl expr') }
+       ; return (HsPragE x (tc_prag prag) expr') }
+  where
+    tc_prag :: HsPragE GhcRn -> HsPragE GhcTc
+    tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
+    tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl
+    tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
+    tc_prag (XHsPragE x) = noExtCon x
 
 tcExpr (HsOverLit x lit) res_ty
   = do  { lit' <- newOverloadedLit lit res_ty
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 2f5382d581..d1f894e14c 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -936,18 +936,9 @@ zonkExpr env (ArithSeq expr wit info)
    where zonkWit env Nothing    = return (env, Nothing)
          zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
 
-zonkExpr env (HsSCC x src lbl expr)
+zonkExpr env (HsPragE x prag expr)
   = do new_expr <- zonkLExpr env expr
-       return (HsSCC x src lbl new_expr)
-
-zonkExpr env (HsTickPragma x src info srcInfo expr)
-  = do new_expr <- zonkLExpr env expr
-       return (HsTickPragma x src info srcInfo new_expr)
-
--- hdaume: core annotations
-zonkExpr env (HsCoreAnn x src lbl expr)
-  = do new_expr <- zonkLExpr env expr
-       return (HsCoreAnn x src lbl new_expr)
+       return (HsPragE x prag new_expr)
 
 -- arrow notation extensions
 zonkExpr env (HsProc x pat body)
diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs
index 5a33300918..e1cf64f731 100644
--- a/compiler/typecheck/TcOrigin.hs
+++ b/compiler/typecheck/TcOrigin.hs
@@ -504,8 +504,7 @@ exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction"
 exprCtOrigin (RecordUpd {})      = Shouldn'tHappenOrigin "record update"
 exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin
 exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence"
-exprCtOrigin (HsSCC _ _ _ e)     = lexprCtOrigin e
-exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e
+exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e
 exprCtOrigin (HsBracket {})      = Shouldn'tHappenOrigin "TH bracket"
 exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
 exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
@@ -514,7 +513,6 @@ exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
 exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
 exprCtOrigin (HsTick _ _ e)           = lexprCtOrigin e
 exprCtOrigin (HsBinTick _ _ _ e)      = lexprCtOrigin e
-exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e
 exprCtOrigin (HsWrap {})        = panic "exprCtOrigin HsWrap"
 exprCtOrigin (XExpr nec)        = noExtCon nec
 
diff --git a/testsuite/tests/ghc-api/annotations/stringSource.hs b/testsuite/tests/ghc-api/annotations/stringSource.hs
index 8bae838672..3d053a3d7c 100644
--- a/testsuite/tests/ghc-api/annotations/stringSource.hs
+++ b/testsuite/tests/ghc-api/annotations/stringSource.hs
@@ -80,11 +80,15 @@ testOneFile libdir fileName = do
      doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])]
 
      doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])]
-     doHsExpr (HsCoreAnn _ src ss _) = [("co",[conv (noLoc ss)])]
-     doHsExpr (HsSCC     _ src ss _) = [("sc",[conv (noLoc ss)])]
-     doHsExpr (HsTickPragma _ src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])]
+     doHsExpr (HsPragE _ prag _) = doPragE prag
      doHsExpr _ = []
 
+     doPragE :: HsPragE GhcPs -> [(String,[Located (SourceText,FastString)])]
+     doPragE (HsPragCore _ src ss) = [("co",[conv (noLoc ss)])]
+     doPragE (HsPragSCC  _ src ss) = [("sc",[conv (noLoc ss)])]
+     doPragE (HsPragTick _ src (ss,_,_) _ss2) = [("tp",[conv (noLoc ss)])]
+     doPragE (XHsPragE x) = noExtCon x
+
      conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)
 
 showAnns anns = "[\n" ++ (intercalate "\n"
diff --git a/testsuite/tests/ghc-api/annotations/t11430.hs b/testsuite/tests/ghc-api/annotations/t11430.hs
index f161e601ce..4b60097a69 100644
--- a/testsuite/tests/ghc-api/annotations/t11430.hs
+++ b/testsuite/tests/ghc-api/annotations/t11430.hs
@@ -67,7 +67,7 @@ testOneFile libdir fileName = do
      doRuleDecl (HsRule _ _ _ _ _ _ _) = []
 
      doHsExpr :: HsExpr GhcPs -> [(String,[String])]
-     doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])]
+     doHsExpr (HsPragE _ (HsPragTick _ src (_,_,_) ss) _) = [("tp",[show ss])]
      doHsExpr _ = []
 
      doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _)
diff --git a/testsuite/tests/printer/Ppr047.hs b/testsuite/tests/printer/Ppr047.hs
index 3ef54c4b38..e7f36850b0 100644
--- a/testsuite/tests/printer/Ppr047.hs
+++ b/testsuite/tests/printer/Ppr047.hs
@@ -1,4 +1,3 @@
 module ExprPragmas where
 
--- Should it be possible to ppr the following annotation?
 c = {-# GENERATED "foobar" 1 : 2  -  3 :   4 #-} 0.00
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 3440f57458..83bfd234fc 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -44,7 +44,7 @@ test('Ppr043', [ignore_stderr, req_rts_linker], makefile_test, ['ppr043'])
 test('Ppr044', ignore_stderr, makefile_test, ['ppr044'])
 test('Ppr045', ignore_stderr, makefile_test, ['ppr045'])
 test('Ppr046', ignore_stderr, makefile_test, ['ppr046'])
-test('Ppr047', expect_fail, makefile_test, ['ppr047'])
+test('Ppr047', ignore_stderr, makefile_test, ['ppr047'])
 test('Ppr048', ignore_stderr, makefile_test, ['ppr048'])
 test('T13199', [ignore_stderr, req_rts_linker], makefile_test, ['T13199'])
 test('T13050p', ignore_stderr, makefile_test, ['T13050p'])