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
(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
{-
************************************************************************
* *
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)
-----------------------------------------------------------------------------
......
......@@ -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
]
......
......@@ -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 $
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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"
......
......@@ -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) _) _)
......
module ExprPragmas where
-- Should it be possible to ppr the following annotation?
c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00
......@@ -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'])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment