summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Hs/Expr.hs122
-rw-r--r--compiler/GHC/Hs/Extension.hs9
-rw-r--r--compiler/GHC/Hs/Instances.hs5
-rw-r--r--compiler/deSugar/Coverage.hs14
-rw-r--r--compiler/deSugar/DsExpr.hs42
-rw-r--r--compiler/deSugar/DsMeta.hs6
-rw-r--r--compiler/hieFile/HieAst.hs8
-rw-r--r--compiler/parser/Parser.y79
-rw-r--r--compiler/rename/RnExpr.hs17
-rw-r--r--compiler/typecheck/TcExpr.hs18
-rw-r--r--compiler/typecheck/TcHsSyn.hs13
-rw-r--r--compiler/typecheck/TcOrigin.hs4
12 files changed, 160 insertions, 177 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
View Lorry Controller Status