Generalized Coverage pass to allow adding multiple types of Tickishs

This allows having, say, HPC ticks, automatic cost centres and source
notes active at the same time. We especially take care to un-tangle the
infrastructure involved in generating them.

(From Phabricator D169)

compiler/deSugar/Desugar.hs

@@ -103,16 +103,9 @@ deSugar hsc_env
         ; let export_set = availsToNameSet exports
               target     = hscTarget dflags
               hpcInfo    = emptyHpcInfo other_hpc_info
-              want_ticks = gopt Opt_Hpc dflags
-                        || gopt Opt_Debug dflags
-                        || target == HscInterpreted
-                        || (gopt Opt_SccProfilingOn dflags
-                            && case profAuto dflags of
-                                 NoProfAuto -> False
-                                 _          -> True)
 
         ; (binds_cvr, ds_hpc_info, modBreaks)
-                         <- if want_ticks && not (isHsBootOrSig hsc_src)
+                         <- if not (isHsBootOrSig hsc_src)
                               then addTicksToBinds dflags mod mod_loc export_set
                                           (typeEnvTyCons type_env) binds
                               else return (binds, hpcInfo, emptyModBreaks)

compiler/deSugar/DsUtils.hs

@@ -599,7 +599,7 @@ cases like
      (p,q) = e
 -}
 
-mkSelectorBinds :: [Maybe (Tickish Id)]  -- ticks to add, possibly
+mkSelectorBinds :: [[Tickish Id]] -- ticks to add, possibly
                 -> LPat Id      -- The pattern
                 -> CoreExpr     -- Expression to which the pattern is bound
                 -> DsM [(Id,CoreExpr)]
@@ -650,7 +650,7 @@ mkSelectorBinds ticks pat val_expr
        ; return ( (tuple_var, tuple_expr) : zipWith mk_tup_bind ticks' binders ) }
   where
     binders       = collectPatBinders pat
-    ticks'        = ticks ++ repeat Nothing
+    ticks'        = ticks ++ repeat []
 
     local_binders = map localiseId binders      -- See Note [Localise pattern binders]
     local_tuple   = mkBigCoreVarTup binders
@@ -807,9 +807,8 @@ CPR-friendly.  This matters a lot: if you don't get it right, you lose
 the tail call property.  For example, see Trac #3403.
 -}
 
-mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr
-mkOptTickBox Nothing e        = e
-mkOptTickBox (Just tickish) e = Tick tickish e
+mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
+mkOptTickBox = flip (foldr Tick)
 
 mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
 mkBinaryTickBox ixT ixF e = do

compiler/hsSyn/Convert.hs

@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
         ; returnJustL $ Hs.ValD $
           PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
                   , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
-                  , pat_ticks = (Nothing,[]) } }
+                  , pat_ticks = ([],[]) } }
 
 cvtDec (TH.FunD nm cls)
   | null cls

compiler/hsSyn/HsBinds.hs

@@ -154,7 +154,7 @@ data HsBindLR idL idR
                                 -- See Note [Bind free vars]
 
 
-        fun_tick :: Maybe (Tickish Id)  -- ^ Tick to put on the rhs, if any
+        fun_tick :: [Tickish Id]  -- ^ Ticks to put on the rhs, if any
     }
 
   -- | The pattern is never a simple variable;
@@ -168,8 +168,8 @@ data HsBindLR idL idR
         pat_rhs    :: GRHSs idR (LHsExpr idR),
         pat_rhs_ty :: PostTc idR Type,      -- ^ Type of the GRHSs
         bind_fvs   :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
-        pat_ticks  :: (Maybe (Tickish Id), [Maybe (Tickish Id)])
-               -- ^ Tick to put on the rhs, if any, and ticks to put on
+        pat_ticks  :: ([Tickish Id], [[Tickish Id]])
+               -- ^ Ticks to put on the rhs, if any, and ticks to put on
                -- the bound variables.
     }
 
@@ -465,10 +465,9 @@ ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
 ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
                         fun_co_fn = wrap,
                         fun_matches = matches,
-                        fun_tick = tick })
-  = pprTicks empty (case tick of
-                        Nothing -> empty
-                        Just t  -> text "-- tick id = " <> ppr t)
+                        fun_tick = ticks })
+  = pprTicks empty (if null ticks then empty
+                    else text "-- ticks = " <> ppr ticks)
     $$  ifPprDebug (pprBndr LetBind (unLoc fun))
     $$  pprFunBind (unLoc fun) inf matches
     $$  ifPprDebug (ppr wrap)

compiler/hsSyn/HsUtils.hs

@@ -525,7 +525,7 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
                           , fun_matches = mkMatchGroup Generated ms
                           , fun_co_fn = idHsWrapper
                           , bind_fvs = placeHolderNames
-                          , fun_tick = Nothing }
+                          , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
              -> HsBind Name
@@ -535,7 +535,7 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
                                     , fun_co_fn = idHsWrapper
                                     , bind_fvs = emptyNameSet -- NB: closed
                                                               --     binding
-                                    , fun_tick = Nothing }
+                                    , fun_tick = [] }
 
 mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs

compiler/parser/Parser.y

@@ -1768,7 +1768,7 @@ decl_no_th :: { Located (OrdList (LHsDecl RdrName)) }
                                             PatBind pat (snd $ unLoc $3)
                                                     placeHolderType
                                                     placeHolderNames
-                                                    (Nothing,[]) } }
+                                                    ([],[]) } }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 

compiler/parser/RdrHsSyn.hs

@@ -927,8 +927,11 @@ makeFunBind :: Located RdrName -> Bool -> [LMatch RdrName (LHsExpr RdrName)]
             -> HsBind RdrName
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
 makeFunBind fn is_infix ms
-  = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms,
-              fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
+  = FunBind { fun_id = fn, fun_infix = is_infix,
+              fun_matches = mkMatchGroup FromSource ms,
+              fun_co_fn = idHsWrapper,
+              bind_fvs = placeHolderNames,
+              fun_tick = [] }
 
 checkPatBind :: SDoc
              -> LHsExpr RdrName
@@ -937,7 +940,7 @@ checkPatBind :: SDoc
 checkPatBind msg lhs (L _ (_,grhss))
   = do  { lhs <- checkPattern msg lhs
         ; return (PatBind lhs grhss placeHolderType placeHolderNames
-                    (Nothing,[])) }
+                    ([],[])) }
 
 checkValSig
         :: LHsExpr RdrName

compiler/typecheck/TcBinds.hs

@@ -1146,9 +1146,10 @@ tcMonoBinds is_rec sig_fn no_gen
                                  -- type of the thing whose rhs we are type checking
                                tcMatchesFun name inf matches rhs_ty
 
-        ; return (unitBag $ L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
-                                               fun_matches = matches', bind_fvs = fvs,
-                                               fun_co_fn = co_fn, fun_tick = Nothing }),
+        ; return (unitBag $ L b_loc $
+                     FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+                               fun_matches = matches', bind_fvs = fvs,
+                               fun_co_fn = co_fn, fun_tick = [] },
                   [(name, Nothing, mono_id)]) }
 
 tcMonoBinds _ sig_fn no_gen binds
@@ -1244,7 +1245,7 @@ tcRhs (TcFunBind (_, mb_sig, mono_id) loc inf matches)
                           , fun_matches = matches'
                           , fun_co_fn = co_fn
                           , bind_fvs = placeHolderNamesTc
-                          , fun_tick = Nothing }) }
+                          , fun_tick = [] }) }
     where
       tvsAndNwcs = maybe [] (\sig -> [(n, tv) | (Just n, tv) <- sig_tvs sig]
                                      ++ sig_nwcs sig) mb_sig
@@ -1257,7 +1258,7 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
                     tcGRHSsPat grhss pat_ty
         ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
                           , bind_fvs = placeHolderNamesTc
-                          , pat_ticks = (Nothing,[]) }) }
+                          , pat_ticks = ([],[]) }) }
 
 
 ---------------------

compiler/typecheck/TcPatSyn.hs

@@ -297,7 +297,7 @@ tcPatSynMatcher (L loc name) lpat
                            , fun_matches = mg
                            , fun_co_fn = idHsWrapper
                            , bind_fvs = emptyNameSet
-                           , fun_tick = Nothing }
+                           , fun_tick = [] }
              matcher_bind = unitBag (noLoc bind)
 
        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
@@ -364,7 +364,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat
                             , fun_matches = mg'
                             , fun_co_fn = idHsWrapper
                             , bind_fvs = placeHolderNamesTc
-                            , fun_tick = Nothing }
+                            , fun_tick = [] }
 
              sig = TcSigInfo{ sig_id = worker_id
                             , sig_tvs = map (\tv -> (Nothing, tv)) worker_tvs