[Git][ghc/ghc][wip/rafl/hpc-pragma] 2 commits: Add a NOCOVER expression pragma

30 Sep 2026


      Florian Ragwitz pushed to branch wip/rafl/hpc-pragma at Glasgow Haskell Compiler / GHC


Commits:
21db608e by Florian Ragwitz at 2026-09-30T15:19:00-07:00
Add a NOCOVER expression pragma

This is working towards #27870.

- - - - -
92c7351c by Florian Ragwitz at 2026-09-30T15:19:00-07:00
hpc: Don't tick NOCOVER expressions for coverage

- - - - -


13 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/Lexer.x
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -618,6 +618,7 @@ instance NoAnn AnnFunRhs where
 -- ---------------------------------------------------------------------
 
 type instance XSCC           (GhcPass _) = (AnnPragSCC, SourceText)
+type instance XNoCover       (GhcPass _) = (AnnPragNoCover, SourceText)
 type instance XXPragE        (GhcPass _) = DataConCantHappen
 
 type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel
@@ -1258,6 +1259,9 @@ instance Outputable (HsPragE (GhcPass p)) where
      -- no doublequotes if stl empty, for the case where the SCC was written
      -- without quotes.
     <+> pprWithSourceText (stringLitSourceText sl) (ppr lbl) <+> text "#-}"
+  ppr (HsPragNoCover (_, st) sl@(StringLiteral _ lbl)) =
+    pprWithSourceText st (text "{-# NOCOVER")
+    <+> pprWithSourceText (stringLitSourceText sl) (ppr lbl) <+> text "#-}"
 
 
 {- *********************************************************************


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -422,6 +422,8 @@ dsExpr (HsPragE _ (HsPragSCC _ cc) expr)
                  <$> dsLExpr expr
          else dsLExpr expr }
 
+dsExpr (HsPragE _ (HsPragNoCover _ _) expr) = dsLExpr expr
+
 dsExpr (HsCase ctxt discrim matches)
   = do { core_discrim <- dsLExpr discrim
        ; ([discrim_var], matching_code) <- matchWrapper ctxt (Just [core_discrim]) matches


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -1763,6 +1763,7 @@ repE e@(XExpr (ExpandedThingRn (HSE o x)))
   = notHandled (ThExpressionForm e)
 repE (XExpr (HsRecSelRn (FieldOcc _ (L _ x)))) = repE (mkHsVar (noLocA x))
 repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
+repE e@(HsPragE _ (HsPragNoCover{}) _) = notHandled (ThExpressionForm e)
 repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e)
 repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
 repE e@(HsProc{}) = notHandled (ThExpressionForm e)


=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -5,7 +5,7 @@
 {-
 (c) Galois, 2006
 (c) University of Glasgow, 2007
-(c) Florian Ragwitz, 2025
+(c) Florian Ragwitz, 2025-2026
 -}
 
 module GHC.HsToCore.Ticks
@@ -420,7 +420,7 @@ addTickLHsExpr e@(L pos e0) = do
     TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
     TickForCoverage    | XExpr (ExpandedThingTc (HSE StmtErrCtxt{} _)) <- e0 -- expansion ticks are handled separately
                        -> dont_tick_it
-                       | otherwise -> tick_it
+                       | otherwise -> ifCoverageSuppressed e0 dont_tick_it tick_it
     TickCallSites      | isCallSite e0      -> tick_it
     _other             -> dont_tick_it
  where
@@ -428,6 +428,17 @@ addTickLHsExpr e@(L pos e0) = do
                   $ addTickHsExpr e0
    dont_tick_it = addTickLHsExprNever e
 
+ifCoverageSuppressed :: HsExpr GhcTc -> TM a -> TM a -> TM a
+ifCoverageSuppressed e noCover cover
+    | isNoCoverExpr e = do
+        hpc <- (== HpcTicks) . tickishType <$> getEnv
+        if hpc then noCover else cover
+    | otherwise = cover
+  where
+    isNoCoverExpr (HsPragE _ (HsPragNoCover{}) _) = True
+    isNoCoverExpr (HsPar _ e) = isNoCoverExpr (unLoc e)
+    isNoCoverExpr _ = False
+
 -- Add a tick to an expression which is the RHS of an equation or a binding.
 -- We always consider these to be breakpoints, unless the expression is a 'let'
 -- (because the body will definitely have a tick somewhere).  ToDo: perhaps
@@ -438,7 +449,7 @@ addTickLHsExprRHS e@(L pos e0) = do
   case d of
      TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
                         | otherwise     -> tick_it
-     TickForCoverage -> tick_it
+     TickForCoverage -> ifCoverageSuppressed e0 dont_tick_it tick_it
      TickCallSites   | isCallSite e0 -> tick_it
      _other          -> dont_tick_it
  where
@@ -503,14 +514,17 @@ isCallSite _           = False
 addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addTickLHsExprOptAlt oneOfMany e@(L pos e0)
   = ifDensity TickForCoverage
-        (allocTickBox (ExpBox oneOfMany) False False (locA pos)
-                           $ addTickHsExpr e0)
+        (ifCoverageSuppressed e0
+          (addTickLHsExprNever e)
+          (allocTickBox (ExpBox oneOfMany) False False (locA pos) $ addTickHsExpr e0))
         (addTickLHsExpr e)
 
 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
 addBinTickLHsExpr boxLabel e@(L pos e0)
   = ifDensity TickForCoverage
-        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)
+        (ifCoverageSuppressed e0
+          (addTickLHsExpr e)
+          (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0))
         (addTickLHsExpr e)
 
 
@@ -625,8 +639,8 @@ addTickHsExpr (ArithSeq ty wit arith_seq) =
                    addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
                                              return (Just fl')
 
-addTickHsExpr (HsPragE x p e) =
-        liftM (HsPragE x p) (addTickLHsExpr e)
+addTickHsExpr e@(HsPragE x p e') =
+  ifCoverageSuppressed e (pure e) (HsPragE x p <$> addTickLHsExpr e')
 addTickHsExpr e@(HsTypedBracket {})  = return e
 addTickHsExpr e@(HsUntypedBracket{}) = return e
 addTickHsExpr e@(HsTypedSplice{})    = return e


=====================================
compiler/GHC/Parser.y
=====================================
@@ -655,6 +655,7 @@ are the most common patterns, rewritten as regular expressions for clarity:
  '{-# SOURCE'             { L _ (ITsource_prag _) }
  '{-# RULES'              { L _ (ITrules_prag _) }
  '{-# SCC'                { L _ (ITscc_prag _)}
+ '{-# NOCOVER'            { L _ (ITnocover_prag _)}
  '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }
  '{-# WARNING'            { L _ (ITwarning_prag _) }
  '{-# UNPACK'             { L _ (ITunpack_prag _) }
@@ -3062,6 +3063,11 @@ prag_e :: { Located (HsPragE GhcPs) }
                                                (AnnPragSCC (glR $1) (epTok $3) (glR $2),
                                                (getSCC_PRAGs $1))
                                                (StringLiteral NoSourceText (fastStringToShortText $ getVARID $2))) }
+      | '{-# NOCOVER' STRING '#-}'  { sLL $1 $>
+                                             (HsPragNoCover
+                                               (AnnPragNoCover (glR $1) (epTok $3) (glR $2),
+                                               (getNOCOVER_PRAGs $1))
+                                               (StringLiteral (getSTRINGs $2) (getSTRING $2))) }
 
 fexp    :: { ECP }
         : fexp aexp                  { ECP $
@@ -4335,6 +4341,7 @@ getRULES_PRAGs        (L _ (ITrules_prag        src)) = src
 getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src
 getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src
 getSCC_PRAGs          (L _ (ITscc_prag          src)) = src
+getNOCOVER_PRAGs      (L _ (ITnocover_prag          src)) = src
 getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src
 getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src
 getANN_PRAGs          (L _ (ITann_prag          src)) = src


=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -43,7 +43,7 @@ module GHC.Parser.Annotation (
 
   AnnList(..), AnnListBrackets(..), AnnListLayout(..),
   AnnParen(..),
-  AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..),
+  AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..),AnnPragNoCover(..),
 
   -- ** Utilities for converting between different 'GenLocated' when
   -- ** we do not care about the annotations.
@@ -653,6 +653,13 @@ data AnnPragSCC
       aps_loc1      :: EpaLocation
       } deriving (Data,Eq)
 
+data AnnPragNoCover
+  = AnnPragNoCover {
+      apnc_open      :: EpaLocation,
+      apnc_close     :: EpToken "#-}",
+      apnc_loc1      :: EpaLocation
+      } deriving (Data,Eq)
+
 -- ---------------------------------------------------------------------
 
 -- | Helper function used in the parser to add a 'TrailingAnn' items
@@ -1030,6 +1037,9 @@ instance NoAnn AnnAnnDecl where
 instance NoAnn AnnPragSCC where
   noAnn = AnnPragSCC noAnn noAnn noAnn
 
+instance NoAnn AnnPragNoCover where
+  noAnn = AnnPragNoCover noAnn noAnn noAnn
+
 instance NoAnn AnnParen where
   noAnn = AnnParens noAnn noAnn
 
@@ -1136,3 +1146,7 @@ instance Outputable AnnAnnDecl where
 instance Outputable AnnPragSCC where
   ppr (AnnPragSCC o c l)
     = text "AnnPragSCC" <+> ppr o <+> ppr c <+> ppr l
+
+instance Outputable AnnPragNoCover where
+  ppr (AnnPragNoCover o c l)
+    = text "AnnPragNoCover" <+> ppr o <+> ppr c <+> ppr l


=====================================
compiler/GHC/Parser/Lexer.x
=====================================
@@ -852,6 +852,7 @@ data Token
   | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'
   | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'
   | ITscc_prag          SourceText
+  | ITnocover_prag      SourceText
   | ITunpack_prag       SourceText
   | ITnounpack_prag     SourceText
   | ITann_prag          SourceText
@@ -3535,6 +3536,7 @@ oneWordPrags = Map.fromList [
      ("warning", fstrtoken (\s -> ITwarning_prag (SourceText s))),
      ("deprecated", fstrtoken (\s -> ITdeprecated_prag (SourceText s))),
      ("scc", fstrtoken (\s -> ITscc_prag (SourceText s))),
+     ("nocover", fstrtoken (\s -> ITnocover_prag (SourceText s))),
      ("unpack", fstrtoken (\s -> ITunpack_prag (SourceText s))),
      ("nounpack", fstrtoken (\s -> ITnounpack_prag (SourceText s))),
      ("ann", fstrtoken (\s -> ITann_prag (SourceText s))),


=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -469,6 +469,7 @@ rnExpr (HsPragE x prag expr)
   where
     rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
     rn_prag (HsPragSCC x ann) = HsPragSCC x $ rnStringLit ann
+    rn_prag (HsPragNoCover x ann) = HsPragNoCover x $ rnStringLit ann
 
 rnExpr (HsLam x lam_variant matches)
   = do { (matches', fvs_ms) <- rnMatchGroup (LamAlt lam_variant) rnLExpr matches


=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -2445,3 +2445,4 @@ tcTagToEnum tc_fun tc_args res_ty
 
 tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
 tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 (tcStringLit ann)
+tcExprPrag (HsPragNoCover x1 ann) = HsPragNoCover x1 (tcStringLit ann)


=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -558,7 +558,7 @@ data DotFieldOcc p
 data HsPragE p
   = HsPragSCC   (XSCC p)
                 (StringLiteral p) -- "set cost centre" SCC pragma
-
+  | HsPragNoCover (XNoCover p) (StringLiteral p)
   | XHsPragE !(XXPragE p)
 
 -- | Located Haskell Tuple Argument


=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -544,6 +544,7 @@ type family XXDotFieldOcc  x
 -- -------------------------------------
 -- HsPragE type families
 type family XSCC            x
+type family XNoCover        x
 type family XXPragE         x
 
 -- -------------------------------------


=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -3346,7 +3346,7 @@ notDodgyE anc =
 
 -- ---------------------------------------------------------------------
 instance ExactPrint (HsPragE GhcPs) where
-  getAnnotationEntry HsPragSCC{}  = NoEntryVal
+  getAnnotationEntry _ = NoEntryVal
   setAnnotationAnchor a _ _ _ = a
 
   exact (HsPragSCC (AnnPragSCC o c l1,st) sl) = do
@@ -3355,6 +3355,12 @@ instance ExactPrint (HsPragE GhcPs) where
     c' <- markEpToken c
     return (HsPragSCC (AnnPragSCC o' c' l1',st) sl)
 
+  exact (HsPragNoCover (AnnPragNoCover o c l1,st) sl) = do
+    o' <- markAnnOpen'' o st  "{-# NOCOVER"
+    l1' <- printStringAtAA l1 (sourceTextToString (stringLitSourceText sl) (unpackHText $ sl_fs sl))
+    c' <- markEpToken c
+    return (HsPragSCC (AnnPragSCC o' c' l1',st) sl)
+
 instance ExactPrint (HsTypedSplice GhcPs) where
   getAnnotationEntry _ = NoEntryVal
 


=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs
=====================================
@@ -251,6 +251,7 @@ classify tok =
     ITline_prag{} -> TkPragma
     ITcolumn_prag{} -> TkPragma
     ITscc_prag{} -> TkPragma
+    ITnocover_prag{} -> TkPragma
     ITunpack_prag{} -> TkPragma
     ITnounpack_prag{} -> TkPragma
     ITann_prag{} -> TkPragma
@@ -392,6 +393,7 @@ inPragma False tok =
     ITline_prag{} -> True
     ITcolumn_prag{} -> True
     ITscc_prag{} -> True
+    ITnocover_prag{} -> True
     ITunpack_prag{} -> True
     ITnounpack_prag{} -> True
     ITann_prag{} -> True



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dad22d337db971252f34814c3a2208b...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dad22d337db971252f34814c3a2208b...
You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help

    

Florian Ragwitz (＠rafl)

tags

participants (1)