+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

+                            tcg_inst_meths   = inst_meths,

+                                       export_set (typeEnvTyCons type_env)

+                                       insts inst_meths binds

+import GHC.Core.InstEnv

+import GHC.Core.Class

+        -> [ClsInst]

+        -> IdEnv DFunId

+                mod mod_loc exports tyCons insts inst_meths binds

+                      , instMeths    = inst_meths

+                      , instTicks    = emptyVarEnv

+                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 <- [lookupVarEnv (instMeths env) abe_poly] ] }

+

+  env <- getEnv

+                 || id `elemVarSet` inlines env

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

+

+  instTick <- instMethTick id

+  let generatedInstMeth = id `elemVarEnv` instMeths env

+        && isGenerated (mg_origin (mg_ext matches))

+

+  tick <- if not generatedInstMeth

+               && not blackListed

+               && shouldTickBind density toplev exported simple inline

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

+                                              (fun_ext funBind) }

+                        , instMeths    :: IdEnv DFunId

+                        , instTicks    :: IdEnv CoreTickish

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

+allocInstTicks insts =

+    ifDensity TickForCoverage (mkVarEnv . catMaybes <$> mapM alloc insts) (pure emptyVarEnv)

+  where

+    alloc inst

+      | null (classMethods (is_cls inst)) = pure Nothing

+      | otherwise = do

+        let dfun = is_dfun inst

+        fmap (dfun,) <$> allocATickBox (TopLevelBox [getOccString dfun])

+                                       False True (getSrcSpan dfun) noFVs

+

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

+instMethTick id = getEnv >>= \e ->

+  pure $ lookupVarEnv (instMeths e) id >>= lookupVarEnv (instTicks e)

+

+        (inst_binds, inst_meths) <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;

+                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs

+                                 , tcg_inst_meths = tcg_inst_meths tcg_env `plusVarEnv` inst_meths } } ;

+             -> TcM (LHsBinds GhcTc, IdEnv DFunId)

+        ; (inst_binds_s, inst_meths_s) <- unzip <$> (tcExtendGlobalValEnv dm_ids $

+                                                     mapM tcInstDecl2 inst_decls)

+        ; return (dm_binds ++ concat inst_binds_s, plusVarEnvList inst_meths_s) }

+tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc, IdEnv DFunId)

+  = recoverM (return (emptyLHsBinds, emptyVarEnv)) $

+    setSrcSpan loc                                 $

+    addErrCtxt (instDeclCtxt2 dfun_ty)             $

+       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics, meth_ids))

+                            , sc_implics `unionBags` meth_implics

+                            , meth_ids ) }

+       ; return (L loc' main_bind : sc_meth_binds, mkVarEnv $ (,dfun_id) <$> meth_ids)

+import GHC.Types.Var.Env

+        tcg_inst_meths   :: IdEnv DFunId,

+          , tcg_inst_meths         = emptyVarEnv

+import Data.Bifunctor

+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" `isSubsequenceOf`)

+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 (\(_, _, s) -> s) 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'])