slightly better named cost-centres for simple pattern bindings #17006

```
main = do
  print $ g [1..100] a
  where g xs x   = map (`mod` x) xs
        a :: Int = 324
```

The above program previously attributed the cost of computing 324 to a cost
centre named `(...)`, with this change the cost is attributed to `a` instead.

This change only affects simple pattern bindings (decorated variables: type
signatures, parens, ~ annotations and ! annotations).

2 files changed, 40 insertions, 9 deletions

diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 945c2c195f..9812fe2c44 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -31,6 +31,7 @@ module GHC.Hs.Pat (
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
+        isSimplePat,
         looksLazyPatBind,
         isBangedLPat,
         patNeedsParens, parenthesizePat,
@@ -274,6 +275,7 @@ data Pat p
   | XPat
       (XXPat p)
 
+
 -- ---------------------------------------------------------------------
 
 data ListPatTc
@@ -730,6 +732,23 @@ isIrrefutableHsPat
 
     go (XPat {})           = False
 
+-- | Is the pattern any of combination of:
+--
+-- - (pat)
+-- - pat :: Type
+-- - ~pat
+-- - !pat
+-- - x (variable)
+isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x))
+isSimplePat p = case unLoc p of
+  ParPat _ x -> isSimplePat x
+  SigPat _ x _ -> isSimplePat x
+  LazyPat _ x -> isSimplePat x
+  BangPat _ x -> isSimplePat x
+  VarPat _ x -> Just (unLoc x)
+  _ -> Nothing
+
+
 {- Note [Unboxed sum patterns aren't irrefutable]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 178372a567..6f9fe36141 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -336,7 +336,12 @@ addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
 -- TODO: Revisit this
 addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
                                     , pat_rhs = rhs }))) = do
-  let name = "(...)"
+
+  let simplePatId = isSimplePat lhs
+
+  -- TODO: better name for rhs's for non-simple patterns?
+  let name = maybe "(...)" getOccString simplePatId
+
   (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
   let pat' = pat { pat_rhs = rhs'}
 
@@ -348,16 +353,24 @@ addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
     then return (L pos pat')
     else do
 
+    let mbCons = maybe id (:)
+
+    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'
+
     -- Allocate the ticks
+
     rhs_tick <- bindTick density name pos fvs
-    let patvars = map getOccString (collectPatBinders lhs)
-    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
+    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
+
+    patvar_tickss <- case simplePatId of
+      Just{} -> return initial_patvar_tickss
+      Nothing -> do
+        let patvars = map getOccString (collectPatBinders lhs)
+        patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
+        return
+          (zipWith mbCons patvar_ticks
+                          (initial_patvar_tickss ++ repeat []))
 
-    -- Add to pattern
-    let mbCons = maybe id (:)
-        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
-        patvar_tickss = zipWith mbCons patvar_ticks
-                        (snd (pat_ticks pat') ++ repeat [])
     return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
 
 -- Only internal stuff, not from source, uses VarBind, so we ignore it.
@@ -365,7 +378,6 @@ addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
 addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
 addTickLHsBind bind@(L _ (XHsBindsLR {})) = return bind
 
-
 bindTick
   :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
 bindTick density name pos fvs = do