summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs49
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs4
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs18
-rw-r--r--compiler/GHC/HsToCore/Expr.hs36
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs8
-rw-r--r--compiler/GHC/HsToCore/Quote.hs2
-rw-r--r--compiler/GHC/HsToCore/Utils.hs4
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs16
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs2
-rw-r--r--compiler/GHC/Tc/Types/Origin.hs2
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs15
-rw-r--r--utils/check-exact/ExactPrint.hs4
12 files changed, 74 insertions, 86 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 2bb6fc7d98..83e36edf54 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -51,6 +51,7 @@ import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Types.SrcLoc
+import GHC.Types.Tickish (CoreTickish)
import GHC.Types.Var( InvisTVBinder )
import GHC.Core.ConLike
import GHC.Unit.Module (ModuleName)
@@ -380,9 +381,6 @@ type instance XStatic GhcPs = EpAnn [AddEpAnn]
type instance XStatic GhcRn = NameSet
type instance XStatic GhcTc = NameSet
-type instance XTick (GhcPass _) = NoExtField
-type instance XBinTick (GhcPass _) = NoExtField
-
type instance XPragE (GhcPass _) = NoExtField
type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL
@@ -469,6 +467,18 @@ data XXExprGhcTc
-- the data constructor when desugaring
ConLike [InvisTVBinder] [Scaled TcType]
+ ---------------------------------------
+ -- Haskell program coverage (Hpc) Support
+
+ | HsTick
+ CoreTickish
+ (LHsExpr GhcTc) -- sub-expression
+
+ | HsBinTick
+ Int -- module-local tick number for True
+ Int -- module-local tick number for False
+ (LHsExpr GhcTc) -- sub-expression
+
{- *********************************************************************
* *
@@ -675,18 +685,6 @@ ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))
ppr_expr (HsStatic _ e)
= hsep [text "static", ppr e]
-ppr_expr (HsTick _ tickish exp)
- = pprTicks (ppr exp) $
- ppr tickish <+> ppr_lexpr exp
-ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)
- = pprTicks (ppr exp) $
- hcat [text "bintick<",
- ppr tickIdTrue,
- text ",",
- ppr tickIdFalse,
- text ">(",
- ppr exp, text ")"]
-
ppr_expr (XExpr x) = case ghcPass @p of
#if __GLASGOW_HASKELL__ < 811
GhcPs -> ppr x
@@ -707,6 +705,19 @@ instance Outputable XXExprGhcTc where
-- Used in error messages generated by
-- the pattern match overlap checker
+ ppr (HsTick tickish exp) =
+ pprTicks (ppr exp) $
+ ppr tickish <+> ppr_lexpr exp
+
+ ppr (HsBinTick tickIdTrue tickIdFalse exp) =
+ pprTicks (ppr exp) $
+ hcat [text "bintick<",
+ ppr tickIdTrue,
+ text ",",
+ ppr tickIdFalse,
+ text ">(",
+ ppr exp, text ")"]
+
ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc
ppr_infix_expr (HsVar _ (L _ v)) = Just (pprInfixOcc v)
ppr_infix_expr (HsRecSel _ f) = Just (pprInfixOcc f)
@@ -726,6 +737,8 @@ ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc
ppr_infix_expr_tc (WrapExpr (HsWrap _ e)) = ppr_infix_expr e
ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a
ppr_infix_expr_tc (ConLikeTc {}) = Nothing
+ppr_infix_expr_tc (HsTick {}) = Nothing
+ppr_infix_expr_tc (HsBinTick {}) = Nothing
ppr_apps :: (OutputableBndrId p)
=> HsExpr (GhcPass p)
@@ -809,8 +822,6 @@ hsExprNeedsParens prec = go
go (HsTcBracketOut{}) = False
go (HsProc{}) = prec > topPrec
go (HsStatic{}) = prec >= appPrec
- go (HsTick _ _ (L _ e)) = go e
- go (HsBinTick _ _ _ (L _ e)) = go e
go (RecordCon{}) = False
go (HsRecSel{}) = False
go (HsProjection{}) = True
@@ -826,6 +837,8 @@ hsExprNeedsParens prec = go
go_x_tc (WrapExpr (HsWrap _ e)) = hsExprNeedsParens prec e
go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a
go_x_tc (ConLikeTc {}) = False
+ go_x_tc (HsTick _ (L _ e)) = hsExprNeedsParens prec e
+ go_x_tc (HsBinTick _ _ (L _ e)) = hsExprNeedsParens prec e
go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool
go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a
@@ -866,6 +879,8 @@ isAtomicHsExpr (XExpr x)
go_x_tc (WrapExpr (HsWrap _ e)) = isAtomicHsExpr e
go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a
go_x_tc (ConLikeTc {}) = True
+ go_x_tc (HsTick {}) = False
+ go_x_tc (HsBinTick {}) = False
go_x_rn (HsExpanded a _) = isAtomicHsExpr a
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 58af03f481..f586d8176b 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -139,12 +139,12 @@ hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
-- than in the typechecked AST.
hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
hsExprType (HsStatic _ e) = lhsExprType e
-hsExprType (HsTick _ _ e) = lhsExprType e
-hsExprType (HsBinTick _ _ _ e) = lhsExprType e
hsExprType (HsPragE _ _ e) = lhsExprType e
hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
+hsExprType (XExpr (HsTick _ e)) = lhsExprType e
+hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
arithSeqInfoType asi = mkListTy $ case asi of
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 4320847663..77762c7d64 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -620,12 +620,6 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
return (Just fl')
--- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (HsTick x t e) =
- liftM (HsTick x t) (addTickLHsExprNever e)
-addTickHsExpr (HsBinTick x t0 t1 e) =
- liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
-
addTickHsExpr (HsPragE x p e) =
liftM (HsPragE x p) (addTickLHsExpr e)
addTickHsExpr e@(HsBracket {}) = return e
@@ -650,6 +644,12 @@ addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
-- such builders are never in the inScope env, which
-- doesn't include top level bindings
+-- We might encounter existing ticks (multiple Coverage passes)
+addTickHsExpr (XExpr (HsTick t e)) =
+ liftM (XExpr . HsTick t) (addTickLHsExprNever e)
+addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
+ liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
+
addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
addTickTupArg (Present x e) = do { e' <- addTickLHsExpr e
; return (Present x e') }
@@ -1193,7 +1193,7 @@ allocTickBox boxLabel countEntries topOnly pos m =
(fvs, e) <- getFreeVars m
env <- getEnv
tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
- return (L (noAnnSrcSpan pos) (HsTick noExtField tickish (L (noAnnSrcSpan pos) e)))
+ return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))
) (do
e <- m
return (L (noAnnSrcSpan pos) e)
@@ -1266,14 +1266,14 @@ mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
-> TM (LHsExpr GhcTc)
mkBinTickBoxHpc boxLabel pos e = do
env <- getEnv
- binTick <- HsBinTick noExtField
+ binTick <- HsBinTick
<$> addMixEntry (pos,declPath env, [],boxLabel True)
<*> addMixEntry (pos,declPath env, [],boxLabel False)
<*> pure e
tick <- HpcTick (this_mod env)
<$> addMixEntry (pos,declPath env, [],ExpBox False)
let pos' = noAnnSrcSpan pos
- return $ L pos' $ HsTick noExtField tick (L pos' binTick)
+ return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))
mkHpcPos :: SrcSpan -> HpcPos
mkHpcPos pos@(RealSrcSpan s _)
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 1208061735..c22bb5a135 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -280,6 +280,23 @@ dsExpr e@(XExpr ext_expr_tc)
ExpansionExpr (HsExpanded _ b) -> dsExpr b
WrapExpr {} -> dsHsWrapped e
ConLikeTc {} -> dsHsWrapped e
+ -- Hpc Support
+ HsTick tickish e -> do
+ e' <- dsLExpr e
+ return (Tick tickish e')
+
+ -- There is a problem here. The then and else branches
+ -- have no free variables, so they are open to lifting.
+ -- We need someway of stopping this.
+ -- This will make no difference to binary coverage
+ -- (did you go here: YES or NO), but will effect accurate
+ -- tick counting.
+
+ HsBinTick ixT ixF e -> do
+ e2 <- dsLExpr e
+ do { assert (exprType e2 `eqType` boolTy)
+ mkBinaryTickBox ixT ixF e2
+ }
dsExpr (NegApp _ (L loc
(HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
@@ -758,25 +775,6 @@ dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
-- Arrow notation extension
dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
--- Hpc Support
-
-dsExpr (HsTick _ tickish e) = do
- e' <- dsLExpr e
- return (Tick tickish e')
-
--- There is a problem here. The then and else branches
--- have no free variables, so they are open to lifting.
--- We need someway of stopping this.
--- This will make no difference to binary coverage
--- (did you go here: YES or NO), but will effect accurate
--- tick counting.
-
-dsExpr (HsBinTick _ ixT ixF e) = do
- e2 <- dsLExpr e
- do { assert (exprType e2 `eqType` boolTy)
- mkBinaryTickBox ixT ixF e2
- }
-
-- HsSyn constructs that just shouldn't be here, because
-- the renamer removed them. See GHC.Rename.Expr.
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index 95c4285422..9694256e18 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -429,8 +429,8 @@ getLHsIntegralLit (L _ e) = go e
go (HsLit _ lit) = getSimpleIntegralLit lit
-- Remember to look through automatically-added tick-boxes! (#8384)
- go (HsTick _ _ e) = getLHsIntegralLit e
- go (HsBinTick _ _ _ e) = getLHsIntegralLit e
+ go (XExpr (HsTick _ e)) = getLHsIntegralLit e
+ go (XExpr (HsBinTick _ _ e)) = getLHsIntegralLit e
-- The literal might be wrapped in a case with -XOverloadedLists
go (XExpr (WrapExpr (HsWrap _ e))) = go e
@@ -456,9 +456,9 @@ getSimpleIntegralLit _ = Nothing
-- | Extract the Char if the expression is a Char literal.
getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
getLHsCharLit (L _ (HsPar _ _ e _)) = getLHsCharLit e
-getLHsCharLit (L _ (HsTick _ _ e)) = getLHsCharLit e
-getLHsCharLit (L _ (HsBinTick _ _ _ e)) = getLHsCharLit e
getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c
+getLHsCharLit (L _ (XExpr (HsTick _ e))) = getLHsCharLit e
+getLHsCharLit (L _ (XExpr (HsBinTick _ _ e))) = getLHsCharLit e
getLHsCharLit _ = Nothing
-- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 032c003c6a..3f47b61375 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1639,8 +1639,6 @@ repE e@(HsBracket{}) = notHandled (ThExpressionForm e)
repE e@(HsRnBracketOut{}) = notHandled (ThExpressionForm e)
repE e@(HsTcBracketOut{}) = notHandled (ThExpressionForm e)
repE e@(HsProc{}) = notHandled (ThExpressionForm e)
-repE e@(HsTick{}) = notHandled (ThExpressionForm e)
-repE e@(HsBinTick{}) = notHandled (ThExpressionForm e)
{- Note [Quotation and rebindable syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index c1426474be..8572a23c39 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -1137,13 +1137,13 @@ isTrueLHsExpr (L _ (HsVar _ (L _ v)))
-- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _)))
| con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (HsTick _ tickish e))
+isTrueLHsExpr (L _ (XExpr (HsTick tickish e)))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
+isTrueLHsExpr (L _ (XExpr (HsBinTick ixT _ e)))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index d20a7bb77f..90afbd9605 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -739,10 +739,10 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsStatic _ e -> computeLType e
- HsTick _ _ e -> computeLType e
- HsBinTick _ _ _ e -> computeLType e
HsPragE _ _ e -> computeLType e
XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
+ XExpr (HsTick _ e) -> computeLType e
+ XExpr (HsBinTick _ _ e) -> computeLType e
e -> Just (hsExprType e)
computeLType :: LHsExpr GhcTc -> Maybe Type
@@ -1190,12 +1190,6 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
HsStatic _ expr ->
[ toHie expr
]
- HsTick _ _ expr ->
- [ toHie expr
- ]
- HsBinTick _ _ _ expr ->
- [ toHie expr
- ]
HsBracket _ b ->
[ toHie b
]
@@ -1222,6 +1216,12 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
-> [ toHie (L mspan b) ]
ConLikeTc con _ _
-> [ toHie $ C Use $ L mspan $ conLikeName con ]
+ HsTick _ expr
+ -> [ toHie expr
+ ]
+ HsBinTick _ _ expr
+ -> [ toHie expr
+ ]
| otherwise -> []
-- NOTE: no longer have the location
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index b768df9e48..d61bbbe694 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -871,8 +871,6 @@ tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty)
tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut" (ppr ty)
-tcExpr (HsTick {}) ty = pprPanic "tcExpr:HsTick" (ppr ty)
-tcExpr (HsBinTick {}) ty = pprPanic "tcExpr:HsBinTick" (ppr ty)
{-
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index 8c37480297..3d55427ae6 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -540,8 +540,6 @@ exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice"
exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc"
exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression"
-exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e
-exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e
exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a
-- | Extract a suitable CtOrigin from a MatchGroup
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index 29769b6e93..563505e373 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -40,7 +40,6 @@ import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Types.SourceText
import GHC.Types.SrcLoc
-import GHC.Types.Tickish
import GHC.Unit.Module (ModuleName)
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -638,20 +637,6 @@ data HsExpr p
(LHsExpr p) -- Body
---------------------------------------
- -- Haskell program coverage (Hpc) Support
-
- | HsTick
- (XTick p)
- CoreTickish
- (LHsExpr p) -- sub-expression
-
- | HsBinTick
- (XBinTick p)
- Int -- module-local tick number for True
- Int -- module-local tick number for False
- (LHsExpr p) -- sub-expression
-
- ---------------------------------------
-- Expressions annotated with pragmas, written as {-# ... #-}
| HsPragE (XPragE p) (HsPragE p) (LHsExpr p)
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 29512e84b5..16631d0bd2 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -1846,8 +1846,6 @@ instance ExactPrint (HsExpr GhcPs) where
getAnnotationEntry (HsSpliceE an _) = fromAnn an
getAnnotationEntry (HsProc an _ _) = fromAnn an
getAnnotationEntry (HsStatic an _) = fromAnn an
- getAnnotationEntry (HsTick {}) = NoEntryVal
- getAnnotationEntry (HsBinTick {}) = NoEntryVal
getAnnotationEntry (HsPragE{}) = NoEntryVal
@@ -2083,8 +2081,6 @@ instance ExactPrint (HsExpr GhcPs) where
markEpAnn an AnnStatic
markAnnotated e
- -- exact x@(HsTick {}) = withPpr x
- -- exact x@(HsBinTick {}) = withPpr x
exact (HsPragE _ prag e) = do
markAnnotated prag
markAnnotated e
View Lorry Controller Status