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).

1 files changed, 21 insertions, 9 deletions

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