Trees That Grow refactor for HsTick and HsBinTick

Move HsTick and HsBinTick to XExpr, the extension tree of HsExpr.

Part of #16830 .

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