summaryrefslogtreecommitdiff
path: root/compiler/GHC/HsToCore
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/HsToCore')
-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
5 files changed, 32 insertions, 36 deletions
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
View Lorry Controller Status