Commit 6985e0fc authored by Vladislav Zavialov's avatar Vladislav Zavialov

Factor out HsSCC/HsCoreAnn/HsTickPragma into HsPragE

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) }
parent 6c59cc71
Pipeline #13303 passed with stages
in 464 minutes and 7 seconds
...@@ -431,19 +431,6 @@ data HsExpr p ...@@ -431,19 +431,6 @@ data HsExpr p
(ArithSeqInfo p) (ArithSeqInfo p)
-- For details on above see note [Api annotations] in ApiAnnotation -- 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 -- MetaHaskell Extensions
...@@ -511,25 +498,9 @@ data HsExpr p ...@@ -511,25 +498,9 @@ data HsExpr p
Int -- module-local tick number for False Int -- module-local tick number for False
(LHsExpr p) -- sub-expression (LHsExpr p) -- sub-expression
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', ---------------------------------------
-- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, -- Expressions annotated with pragmas, written as {-# ... #-}
-- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
-- '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)
--------------------------------------- ---------------------------------------
-- Finally, HsWrap appears only in typechecker output -- Finally, HsWrap appears only in typechecker output
...@@ -625,8 +596,6 @@ type instance XArithSeq GhcPs = NoExtField ...@@ -625,8 +596,6 @@ type instance XArithSeq GhcPs = NoExtField
type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcRn = NoExtField
type instance XArithSeq GhcTc = PostTcExpr type instance XArithSeq GhcTc = PostTcExpr
type instance XSCC (GhcPass _) = NoExtField
type instance XCoreAnn (GhcPass _) = NoExtField
type instance XBracket (GhcPass _) = NoExtField type instance XBracket (GhcPass _) = NoExtField
type instance XRnBracketOut (GhcPass _) = NoExtField type instance XRnBracketOut (GhcPass _) = NoExtField
...@@ -641,12 +610,54 @@ type instance XStatic GhcTc = NameSet ...@@ -641,12 +610,54 @@ type instance XStatic GhcTc = NameSet
type instance XTick (GhcPass _) = NoExtField type instance XTick (GhcPass _) = NoExtField
type instance XBinTick (GhcPass _) = NoExtField type instance XBinTick (GhcPass _) = NoExtField
type instance XTickPragma (GhcPass _) = NoExtField
type instance XPragE (GhcPass _) = NoExtField
type instance XWrap (GhcPass _) = NoExtField type instance XWrap (GhcPass _) = NoExtField
type instance XXExpr (GhcPass _) = NoExtCon 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 -- | Located Haskell Tuple Argument
-- --
-- 'HsTupArg' is used for tuple sections -- 'HsTupArg' is used for tuple sections
...@@ -857,10 +868,7 @@ ppr_expr (HsLit _ lit) = ppr lit ...@@ -857,10 +868,7 @@ ppr_expr (HsLit _ lit) = ppr lit
ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit
ppr_expr (HsPar _ e) = parens (ppr_lexpr e) ppr_expr (HsPar _ e) = parens (ppr_lexpr e)
ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]
= vcat [pprWithSourceText stc (text "{-# CORE")
<+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"
, ppr_lexpr e]
ppr_expr e@(HsApp {}) = ppr_apps e [] ppr_expr e@(HsApp {}) = ppr_apps e []
ppr_expr e@(HsAppType {}) = ppr_apps e [] ppr_expr e@(HsAppType {}) = ppr_apps e []
...@@ -990,13 +998,6 @@ ppr_expr (ExprWithTySig _ expr sig) ...@@ -990,13 +998,6 @@ ppr_expr (ExprWithTySig _ expr sig)
ppr_expr (ArithSeq _ _ info) = brackets (ppr info) 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) ppr_expr (HsWrap _ co_fn e)
= pprHsWrapper co_fn (\parens -> if parens then pprExpr e = pprHsWrapper co_fn (\parens -> if parens then pprExpr e
else pprExpr e) else pprExpr e)
...@@ -1027,13 +1028,6 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) ...@@ -1027,13 +1028,6 @@ ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
ppr tickIdFalse, ppr tickIdFalse,
text ">(", text ">(",
ppr exp, 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 (HsRecFld _ f) = ppr f
ppr_expr (XExpr x) = ppr x ppr_expr (XExpr x) = ppr x
...@@ -1110,7 +1104,6 @@ hsExprNeedsParens p = go ...@@ -1110,7 +1104,6 @@ hsExprNeedsParens p = go
go (HsLit _ l) = hsLitNeedsParens p l go (HsLit _ l) = hsLitNeedsParens p l
go (HsOverLit _ ol) = hsOverLitNeedsParens p ol go (HsOverLit _ ol) = hsOverLitNeedsParens p ol
go (HsPar{}) = False go (HsPar{}) = False
go (HsCoreAnn _ _ _ (L _ e)) = go e
go (HsApp{}) = p >= appPrec go (HsApp{}) = p >= appPrec
go (HsAppType {}) = p >= appPrec go (HsAppType {}) = p >= appPrec
go (OpApp{}) = p >= opPrec go (OpApp{}) = p >= opPrec
...@@ -1132,7 +1125,7 @@ hsExprNeedsParens p = go ...@@ -1132,7 +1125,7 @@ hsExprNeedsParens p = go
go (RecordUpd{}) = False go (RecordUpd{}) = False
go (ExprWithTySig{}) = p >= sigPrec go (ExprWithTySig{}) = p >= sigPrec
go (ArithSeq{}) = False go (ArithSeq{}) = False
go (HsSCC{}) = p >= appPrec go (HsPragE{}) = p >= appPrec
go (HsWrap _ _ e) = go e go (HsWrap _ _ e) = go e
go (HsSpliceE{}) = False go (HsSpliceE{}) = False
go (HsBracket{}) = False go (HsBracket{}) = False
...@@ -1142,7 +1135,6 @@ hsExprNeedsParens p = go ...@@ -1142,7 +1135,6 @@ hsExprNeedsParens p = go
go (HsStatic{}) = p >= appPrec go (HsStatic{}) = p >= appPrec
go (HsTick _ _ (L _ e)) = go e go (HsTick _ _ (L _ e)) = go e
go (HsBinTick _ _ _ (L _ e)) = go e go (HsBinTick _ _ _ (L _ e)) = go e
go (HsTickPragma _ _ _ _ (L _ e)) = go e
go (RecordCon{}) = False go (RecordCon{}) = False
go (HsRecFld{}) = False go (HsRecFld{}) = False
go (XExpr{}) = True go (XExpr{}) = True
...@@ -1172,6 +1164,24 @@ isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) ...@@ -1172,6 +1164,24 @@ isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e)
isAtomicHsExpr (HsRecFld{}) = True isAtomicHsExpr (HsRecFld{}) = True
isAtomicHsExpr _ = False 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
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -606,8 +606,6 @@ type family XRecordCon x ...@@ -606,8 +606,6 @@ type family XRecordCon x
type family XRecordUpd x type family XRecordUpd x
type family XExprWithTySig x type family XExprWithTySig x
type family XArithSeq x type family XArithSeq x
type family XSCC x
type family XCoreAnn x
type family XBracket x type family XBracket x
type family XRnBracketOut x type family XRnBracketOut x
type family XTcBracketOut x type family XTcBracketOut x
...@@ -616,10 +614,15 @@ type family XProc x ...@@ -616,10 +614,15 @@ type family XProc x
type family XStatic x type family XStatic x
type family XTick x type family XTick x
type family XBinTick x type family XBinTick x
type family XTickPragma x type family XPragE x
type family XWrap x type family XWrap x
type family XXExpr 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 :: *) = type ForallXExpr (c :: * -> Constraint) (x :: *) =
( c (XVar x) ( c (XVar x)
, c (XUnboundVar x) , c (XUnboundVar x)
......
...@@ -247,6 +247,11 @@ deriving instance Data (SyntaxExpr GhcPs) ...@@ -247,6 +247,11 @@ deriving instance Data (SyntaxExpr GhcPs)
deriving instance Data (SyntaxExpr GhcRn) deriving instance Data (SyntaxExpr GhcRn)
deriving instance Data (SyntaxExpr GhcTc) 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 (DataIdLR p p) => Data (HsExpr p)
deriving instance Data (HsExpr GhcPs) deriving instance Data (HsExpr GhcPs)
deriving instance Data (HsExpr GhcRn) deriving instance Data (HsExpr GhcRn)
......
...@@ -606,20 +606,12 @@ addTickHsExpr (HsTick x t e) = ...@@ -606,20 +606,12 @@ addTickHsExpr (HsTick x t e) =
addTickHsExpr (HsBinTick x t0 t1 e) = addTickHsExpr (HsBinTick x t0 t1 e) =
liftM (HsBinTick x t0 t1) (addTickLHsExprNever 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 $ e2 <- allocTickBox (ExpBox False) False False pos $
addTickHsExpr e0 addTickHsExpr e0
return $ unLoc e2 return $ unLoc e2
addTickHsExpr (HsSCC x src nm e) = addTickHsExpr (HsPragE x p e) =
liftM3 (HsSCC x) liftM (HsPragE x p) (addTickLHsExpr e)
(return src)
(return nm)
(addTickLHsExpr e)
addTickHsExpr (HsCoreAnn x src nm e) =
liftM3 (HsCoreAnn x)
(return src)
(return nm)
(addTickLHsExpr e)
addTickHsExpr e@(HsBracket {}) = return e addTickHsExpr e@(HsBracket {}) = return e
addTickHsExpr e@(HsTcBracketOut {}) = return e addTickHsExpr e@(HsTcBracketOut {}) = return e
addTickHsExpr e@(HsRnBracketOut {}) = return e addTickHsExpr e@(HsRnBracketOut {}) = return e
......
...@@ -402,20 +402,8 @@ ds_expr _ (ExplicitSum types alt arity expr) ...@@ -402,20 +402,8 @@ ds_expr _ (ExplicitSum types alt arity expr)
map Type types ++ map Type types ++
[core_expr]) ) } [core_expr]) ) }
ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do ds_expr _ (HsPragE _ prag expr) =
dflags <- getDynFlags ds_prag_expr prag expr
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 _ (HsCase _ discrim matches) ds_expr _ (HsCase _ discrim matches)
= do { core_discrim <- dsLExpr discrim = do { core_discrim <- dsLExpr discrim
...@@ -745,18 +733,32 @@ ds_expr _ (HsBinTick _ ixT ixF e) = do ...@@ -745,18 +733,32 @@ ds_expr _ (HsBinTick _ ixT ixF e) = do
mkBinaryTickBox ixT ixF e2 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: -- HsSyn constructs that just shouldn't be here:
ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket" ds_expr _ (HsBracket {}) = panic "dsExpr:HsBracket"
ds_expr _ (HsDo {}) = panic "dsExpr:HsDo" ds_expr _ (HsDo {}) = panic "dsExpr:HsDo"
ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_expr _ (HsRecFld {}) = panic "dsExpr:HsRecFld"
ds_expr _ (XExpr nec) = noExtCon nec 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 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
......
...@@ -1398,9 +1398,9 @@ repE (HsUnboundVar _ uv) = do ...@@ -1398,9 +1398,9 @@ repE (HsUnboundVar _ uv) = do
sname <- repNameS occ sname <- repNameS occ
repUnboundVar sname repUnboundVar sname
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsPragE _ HsPragCore {} _) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e)
repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e) repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e)
repE e = notHandled "Expression form" (ppr e) repE e = notHandled "Expression form" (ppr e)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -978,10 +978,7 @@ instance ( a ~ GhcPass p ...@@ -978,10 +978,7 @@ instance ( a ~ GhcPass p
ArithSeq _ _ info -> ArithSeq _ _ info ->
[ toHie info [ toHie info
] ]
HsSCC _ _ _ expr -> HsPragE _ _ expr ->
[ toHie expr
]
HsCoreAnn _ _ _ expr ->
[ toHie expr [ toHie expr
] ]
HsProc _ pat cmdtop -> HsProc _ pat cmdtop ->
...@@ -997,9 +994,6 @@ instance ( a ~ GhcPass p ...@@ -997,9 +994,6 @@ instance ( a ~ GhcPass p
HsBinTick _ _ _ expr -> HsBinTick _ _ _ expr ->
[ toHie expr [ toHie expr
] ]
HsTickPragma _ _ _ _ expr ->
[ toHie expr
]
HsWrap _ _ a -> HsWrap _ _ a ->
[ toHie $ L mspan a [ toHie $ L mspan a
] ]
......
...@@ -2629,66 +2629,57 @@ exp10_top :: { ECP } ...@@ -2629,66 +2629,57 @@ exp10_top :: { ECP }
amms (mkHsNegAppPV (comb2 $1 $>) $2) amms (mkHsNegAppPV (comb2 $1 $>) $2)
[mj AnnMinus $1] } [mj AnnMinus $1] }
| exp_annot (prag_hpc) { $1 }
| hpc_annot exp {% runECP_P $2 >>= \ $2 -> | exp_annot (prag_core) { $1 }
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
| fexp { $1 } | fexp { $1 }
exp10 :: { ECP } exp10 :: { ECP }
: exp10_top { $1 } : exp10_top { $1 }
| scc_annot exp {% runECP_P $2 >>= \ $2 -> | exp_annot(prag_scc) { $1 }
fmap ecpFromExp $
ams (sLL $1 $> $ HsSCC noExtField (snd $ fst $ unLoc $1) (snd $ unLoc $1) $2)
(fst $ fst $ unLoc $1) }
optSemi :: { ([Located Token],Bool) } optSemi :: { ([Located Token],Bool) }
: ';' { ([$1],True) } : ';' { ([$1],True) }
| {- empty -} { ([],False) } | {- empty -} { ([],False) }
scc_annot :: { Located (([AddAnn],SourceText),StringLiteral) } prag_scc :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# SCC' STRING '#-}' {% do scc <- getSCC $2 : '{-# SCC' STRING '#-}' {% do scc <- getSCC $2
; return $ sLL $1 $> ; return $ sLL $1 $>
(([mo $1,mj AnnValStr $2 ([mo $1,mj AnnValStr $2,mc $3],
,mc $3],getSCC_PRAGs $1),(StringLiteral (getSTRINGs $2) scc)) } HsPragSCC noExtField
| '{-# SCC' VARID '#-}' { sLL $1 $> (([mo $1,mj AnnVal $2 (getSCC_PRAGs $1)
,mc $3],getSCC_PRAGs $1) (StringLiteral (getSTRINGs $2) scc)) }
,(StringLiteral NoSourceText (getVARID $2))) } | '{-# SCC' VARID '#-}' { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],
HsPragSCC noExtField
hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), (getSCC_PRAGs $1)
((SourceText,SourceText),(SourceText,SourceText)) (StringLiteral NoSourceText (getVARID $2))) }
) }
prag_hpc :: { Located ([AddAnn], HsPragE GhcPs) }
: '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' : '{-# 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 $3,mj AnnColon $4
,mj AnnVal $5,mj AnnMinus $6 ,mj AnnVal $5,mj AnnMinus $6
,mj AnnVal $7,mj AnnColon $8 ,mj AnnVal $7,mj AnnColon $8
,mj AnnVal $9,mc $10], ,mj AnnVal $9,mc $10],
getGENERATED_PRAGs $1) HsPragTick noExtField
,((getStringLiteral $2) (getGENERATED_PRAGs $1)
,( fromInteger $ il_value $ getINTEGER $3 (getStringLiteral $2,
, fromInteger $ il_value $ getINTEGER $5 (getINT $3, getINT $5),
) (getINT $7, getINT $9))
,( fromInteger $ il_value $ getINTEGER $7 ((getINTEGERs $3, getINTEGERs $5),
, fromInteger $ il_value $ getINTEGER $9 (getINTEGERs $7, getINTEGERs $9) )) }
)
)) prag_core :: { Located ([AddAnn], HsPragE GhcPs) }
, (( getINTEGERs $3 : '{-# CORE' STRING '#-}'
, getINTEGERs $5 { sLL $1 $> $
) ([mo $1,mj AnnVal $2,mc $3],
,( getINTEGERs $7 HsPragCore noExtField (getCORE_PRAGs $1) (getStringLiteral $2)) }
, getINTEGERs $9
))) 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 :: { ECP }
: fexp aexp { ECP $ : fexp aexp { ECP $
......
...@@ -232,16 +232,15 @@ rnExpr expr@(SectionR {}) ...@@ -232,16 +232,15 @@ rnExpr expr@(SectionR {})
= do { addErr (sectionErr expr); rnSection expr } = do { addErr (sectionErr expr); rnSection expr }
--------------------------------------------- ---------------------------------------------
rnExpr (HsCoreAnn x src ann expr) rnExpr (HsPragE x prag expr)
= do { (expr', fvs_expr) <- rnLExpr expr = do { (expr', fvs_expr) <- rnLExpr expr
; return (HsCoreAnn x src ann expr', fvs_expr) } ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
where
rnExpr (HsSCC x src lbl expr) rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
= do { (expr', fvs_expr) <- rnLExpr expr rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
; return (HsSCC x src lbl expr', fvs_expr) } rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl
rnExpr (HsTickPragma x src info srcInfo expr) rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
= do { (expr', fvs_expr) <- rnLExpr expr rn_prag (XHsPragE x) = noExtCon x
; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
rnExpr (HsLam x matches) rnExpr (HsLam x matches)
= do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
......
...@@ -181,17 +181,15 @@ tcExpr e@(HsLit x lit) res_ty ...@@ -181,17 +181,15 @@ tcExpr e@(HsLit x lit) res_ty
tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar x expr') } ; 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 = do { expr' <- tcMonoExpr expr res_ty
; return (HsSCC x src lbl expr') } ; return (HsPragE x (tc_prag prag) expr') }
where
tcExpr (HsTickPragma x src info srcInfo expr) res_ty tc_prag :: HsPragE GhcRn -> HsPragE GhcTc
= do { expr' <- tcMonoExpr expr res_ty tc_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann
; return (HsTickPragma x src info srcInfo expr') } tc_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl
tc_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo
tcExpr (HsCoreAnn x src lbl expr) res_ty tc_prag (XHsPragE x) = noExtCon x
= do { expr' <- tcMonoExpr expr res_ty
; return (HsCoreAnn x src lbl expr') }
tcExpr (HsOverLit x lit) res_ty tcExpr (HsOverLit x lit) res_ty
= do { lit' <- newOverloadedLit lit res_ty = do { lit' <- newOverloadedLit lit res_ty
......
...@@ -936,18 +936,9 @@ zonkExpr env (ArithSeq expr wit info) ...@@ -936,18 +936,9 @@ zonkExpr env (ArithSeq expr wit info)
where zonkWit env Nothing = return (env, Nothing) where zonkWit env Nothing = return (env, Nothing)
zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln 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 = do new_expr <- zonkLExpr env expr
return (HsSCC x src lbl new_expr) return (HsPragE x prag 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)
-- arrow notation extensions -- arrow notation extensions
zonkExpr env (HsProc x pat body) zonkExpr env (HsProc x pat body)
......
...@@ -504,8 +504,7 @@ exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" ...@@ -504,8 +504,7 @@ exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction"
exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update"
exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin
exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence"
exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e
exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e
exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket"