+section: compiler

+synopsis: Improve coverage reporting for class instances and their methods

+description:

+

+  Coverage reporting (:ghc-flag:`-fhpc`) now treats class instances more

+  naturally.

+

+  Compiler-generated instance methods, such as inherited default methods, no

+  longer receive separate top-level coverage boxes. Explicitly implemented

+  instance methods retain their own declaration coverage.

+

+  This means that it is no longer necessary to exercise all of a class' methods

+  in order for it to appear "covered".

+

+  Additionally, top-level coverage boxes are now created for all instances of

+  classes with methods, and ticked by the use of *any* of the class' methods.

+  This indicates that an instance was in fact used at run-time.

+

+  Note that classes without any instance methods are currently excluded from

+  this, and won't have any coverage boxes created.

+

+mrs: !16632

+issues: #17155 #15932

+      InstMethId {}    -> True

+toIfaceIdDetails _ (InstMethId {})                = IfVanillaId

+                                       export_set (typeEnvTyCons type_env)

+                                       insts binds

+{-# LANGUAGE NondecreasingIndentation, DataKinds, ViewPatterns #-}

+(c) Florian Ragwitz, 2025-2026

+import GHC.Core.InstEnv

+import GHC.Core.Class

+import GHC.Types.Name.Env

+import Data.Functor

+        -> [ClsInst]            -- ^ Class instances in this module

+                mod mod_loc exports tyCons insts binds

+                      , instMeths    = emptyVarEnv

+                      , instTicks    = emptyNameEnv

+                addTick = do

+                  instTicks <- allocInstTicks insts

+                  withEnv (\e -> e{ instTicks }) $ addTickLHsBinds binds

+                (binds',_,st') = unTM addTick env st

+  withEnv (add_inst_meths . add_rec_sels . add_inlines . add_exports) $ do

+   add_inst_meths env =

+     env{ instMeths = instMeths env `extendVarEnvList`

+                        [ (abe_mono, dfun)

+                        | ABE{ abe_poly, abe_mono } <- abs_exports

+                        , Just dfun <- [instMeth abe_poly] ] }

+     where instMeth (idDetails -> InstMethId dfun) = Just dfun

+           instMeth id = lookupVarEnv (instMeths env) id

+

+  env <- getEnv

+                 || id `elemVarSet` inlines env

+  case tickishType env of { ProfNotes | inline -> return (L pos funBind); _ -> do

+  -- See Note [Instance Method Coverage].

+  -- We only exclude generated instance methods for now, not generated code in

+  -- general, whose coverage semantics may need to be considered separately.

+  let generatedInstMeth = tickishType env == HpcTicks

+        && id `elemVarEnv` instMeths env

+        && isGenerated (mg_origin (mg_ext matches))

+

+  tick <- if not generatedInstMeth

+               && not blackListed

+               && shouldTickBind density toplev exported simple inline

+  -- See Note [Instance Method Coverage].

+  instTick <- instMethTick id

+

+                           , fun_ext = second ((instTick `mbCons`) . (tick `mbCons`))

+                                              (fun_ext funBind) }

+-- Note [Instance Method Coverage]

+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+-- Users expect source-level semantics for coverage reports (see #17155,

+-- #15932). That is, code they've written themselves should be marked as covered

+-- iff it is evaluated at run-time. Given that the implementation of class

+-- instances creates top-level bindings for all methods of an instance,

+-- inherited and hand-written, we need to go out of our way to create top-level

+-- tick boxes only for methods which correspond to user-written code.

+--

+-- Instance method 'Id's carry the name of the 'DFunId' of the instance they

+-- belong to. When creating tick boxes for top-level bindings, we can use this

+-- information to skip creating boxes for inherited/generated instance methods.

+--

+-- Additionally, we also want to inform the user whether or not their class

+-- instance as a whole has been used at run-time. To do so, we create a single

+-- tick box at the instance head and tick that box when any method of that

+-- instance is evaluated.

+--

+-- As marker/tag-like class instances without any methods would always appear

+-- as uncovered using the above mechanism, we exclude them when creating

+-- instance tick boxes. This could potentially be improved in the future by

+-- tracking if any functions requiring an instance of an empty class have been

+-- evaluated.

+

+                        , instMeths    :: IdEnv Name

+                        , instTicks    :: NameEnv CoreTickish

+ifTickish :: TickishType -> TM a -> TM a -> TM a

+ifTickish want th el = tickishType <$> getEnv >>= \got -> if want == got then th else el

+

+-- See Note [Instance Method Coverage].

+allocInstTicks :: [ClsInst] -> TM (NameEnv CoreTickish)

+allocInstTicks insts =

+    ifTickish HpcTicks (mkNameEnv . catMaybes <$> mapM alloc insts) (pure emptyNameEnv)

+  where

+    alloc ClsInst{ is_dfun, is_cls }

+      | null (classMethods is_cls) = pure Nothing

+      | otherwise = fmap (idName is_dfun,) <$> allocATickBox (TopLevelBox [getOccString is_dfun])

+                                                             False True (getSrcSpan is_dfun) noFVs

+

+-- See Note [Instance Method Coverage].

+instMethTick :: Id -> TM (Maybe CoreTickish)

+instMethTick id = getEnv <&> \e -> lookupVarEnv (instMeths e) id >>= lookupNameEnv (instTicks e)

+

+recSelTick id = ifTickish HpcTicks maybe_tick (pure Nothing)

+import GHC.Core.Predicate( classMethodInstTy, isCoVarType )

+import GHC.Types.Id.Info

+      = tcMethodBody False dfun_id clas tyvars dfun_ev_vars inst_tys

+        -> do { (meth_id, _) <- mkMethIds dfun_id clas tyvars dfun_ev_vars

+                          dfun_id clas tyvars dfun_ev_vars inst_tys

+           ; (meth_id, _) <- mkMethIds dfun_id clas tyvars dfun_ev_vars

+             -> DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]

+tcMethodBody is_vanilla_dm dfun_id clas tyvars dfun_ev_vars inst_tys

+                                            mkMethIds dfun_id clas tyvars dfun_ev_vars

+mkMethIds :: DFunId -> Class -> [TcTyVar] -> [EvVar]

+mkMethIds dfun_id clas tyvars dfun_ev_vars inst_tys sel_id

+        ; let poly_meth_id =

+                assert (not (isCoVarType poly_meth_ty)) $

+                Var.mkLocalVar (InstMethId (idName dfun_id))

+                               poly_meth_name ManyTy poly_meth_ty vanillaIdInfo

+  | InstMethId

+        -- ^ An instance method.

+      Name

+        -- ^ 'Name' of the dictionary function the instance method belongs to.

+   pp (InstMethId name)       = text "InstMethId" <> parens (ppr name)

+import Data.List

+import Data.Maybe

+import Trace.Hpc.Mix

+import Trace.Hpc.Reflect

+import Trace.Hpc.Tix

+import Trace.Hpc.Util

+

+class Foo a where

+  defMeth, defMeth', reqMeth :: a -> String

+  defMeth = const "class default"

+  defMeth' = const "class default"

+

+newtype T a = T a deriving (Show, Eq, Functor)

+instance Foo (T a) where

+  reqMeth = const "Foo (T a) instance"

+

+newtype T' a = T' a

+

+instance Foo (T' a) where

+  reqMeth = const "Foo (T' a) instance"

+  defMeth = const "Foo (T' a) instance"

+

+-- no method use could "cover" this instance, so we (for now) omit the top-level box for it

+class Marker a

+instance Marker (T Bool)

+

+interesting :: (Int, MixEntry) -> Maybe (Int, HpcPos, String)

+interesting (n, (pos, TopLevelBox [name])) | isInteresting name = Just (n, pos, name)

+  where isInteresting = (||) <$> isInst <*> isMeth

+        isInst = ("$f" `isPrefixOf`)

+        isMeth = (||) <$> (`elem` ["(==)", "(/=)", "show", "showList", "showsPrec", "fmap", "(<$)"])

+                      <*> ("Meth" `isInfixOf`)

+interesting _ = Nothing

+

+-- candidate for HPC.Utils, maybe?

+sourceAt :: String -> HpcPos -> String

+sourceAt src pos

+  | l1 == l2 = take (c2 - c1 + 1) . drop (c1 - 1) $ ls !! (l1 - 1)

+  | otherwise = intercalate "\n" $ first : (middle ++ [last])

+  where

+    (l1, c1, l2, c2) = fromHpcPos pos

+    ls = lines src

+    first = drop (c1 - 1) $ ls !! (l1 - 1)

+    middle = take (l2 - l1 - 1) $ drop l1 ls

+    last = take c2 $ ls !! (l2 - 1)

+

+main :: IO ()

+main = do

+  print (T 23 == (succ <$> T 22)) -- tick Eq and Functor by using any of their methods

+  print (reqMeth (T' 1)) -- tick `Foo (T' a)` and that instance's `reqMeth`

+

+  Mix source _ _ _ mixEntries <- readMix [".hpc"] (Left "Main")

+  src <- readFileUtf8 source

+  let boxes = mapMaybe interesting $ zip [0 ..] mixEntries

+  Tix [TixModule "Main" _ _ counts] <- examineTix

+  mapM_ print [ (counts !! n, path, sourceAt src pos)

+              | (n, pos, path) <- sortOn (\(_, l, p) -> (p, l)) boxes ]

+True

+"Foo (T' a) instance"

+(1,"$fEqT","Eq")

+(0,"$fFooT","Foo (T a)")

+(1,"$fFooT'","Foo (T' a)")

+(1,"$fFunctorT","Functor")

+(0,"$fShowT","Show")

+(0,"defMeth","defMeth = const \"class default\"")

+(0,"defMeth","defMeth = const \"Foo (T' a) instance\"")

+(0,"defMeth'","defMeth' = const \"class default\"")

+(0,"reqMeth","reqMeth = const \"Foo (T a) instance\"")

+(1,"reqMeth","reqMeth = const \"Foo (T' a) instance\"")

+setTestOpts([omit_ghci, when(fast(), skip), js_skip])

+

+test('instmeths',

+     [ignore_extension],

+     compile_and_run, ['-fhpc'])

+[GblId[InstMethId(T22375.$fEqX)],

+[GblId[InstMethId(T22375.$fEqX)],

+[GblId[InstMethId(T22375DataFamily.$fEqX)],

+[GblId[InstMethId(T22375DataFamily.$fEqX)],