    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE TypeApplications #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE DeriveAnyClass #-}
    {-# LANGUAGE DerivingStrategies #-}
    {-# LANGUAGE TupleSections #-}

    -- | Adds cost-centers to call sites selected with the @-fprof-caller=...@
    -- flag.
    module GHC.Core.Opt.CallerCC
        ( addCallerCostCentres
        , CallerCcFilter(..)
        , NamePattern(..)
        , parseCallerCcFilter
        ) where

    import Data.Word (Word8)
    import Data.Maybe

    import Control.Applicative
    import GHC.Utils.Monad.State.Strict
    import Data.Either
    import Control.Monad
    import qualified Text.ParserCombinators.ReadP as P

    import GHC.Prelude
    import GHC.Utils.Outputable as Outputable
    import GHC.Driver.Session
    import GHC.Types.CostCentre
    import GHC.Types.CostCentre.State
    import GHC.Types.Name hiding (varName)
    import GHC.Types.Tickish
    import GHC.Unit.Module.ModGuts
    import GHC.Types.SrcLoc
    import GHC.Types.Var
    import GHC.Unit.Types
    import GHC.Data.FastString
    import GHC.Core
    import GHC.Core.Opt.Monad
    import GHC.Utils.Panic
    import qualified GHC.Utils.Binary as B
    import Data.Char

    import Language.Haskell.Syntax.Module.Name

    addCallerCostCentres :: ModGuts -> CoreM ModGuts
    addCallerCostCentres :: ModGuts -> CoreM ModGuts
    addCallerCostCentres ModGuts
    guts = do
      DynFlags
    dflags <- CoreM DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
      let filters :: [CallerCcFilter]
    filters = DynFlags -> [CallerCcFilter]
    callerCcFilters DynFlags
    dflags
      let env :: Env
          env :: Env
    env = Env
            { thisModule :: Module
    thisModule = ModGuts -> Module
    mg_module ModGuts
    guts
            , ccState :: CostCentreState
    ccState = CostCentreState
    newCostCentreState
            , countEntries :: Bool
    countEntries = GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_ProfCountEntries DynFlags
    dflags
            , revParents :: [Id]
    revParents = []
            , filters :: [CallerCcFilter]
    filters = [CallerCcFilter]
    filters
            }
      let guts' :: ModGuts
    guts' = ModGuts
    guts { mg_binds = doCoreProgram env (mg_binds guts)
                       }
      ModGuts -> CoreM ModGuts
    forall a. a -> CoreM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ModGuts
    guts'

    doCoreProgram :: Env -> CoreProgram -> CoreProgram
    doCoreProgram :: Env -> CoreProgram -> CoreProgram
    doCoreProgram Env
    env CoreProgram
    binds = (State CostCentreState CoreProgram
     -> CostCentreState -> CoreProgram)
    -> CostCentreState
    -> State CostCentreState CoreProgram
    -> CoreProgram
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip State CostCentreState CoreProgram -> CostCentreState -> CoreProgram
    forall s a. State s a -> s -> a
    evalState CostCentreState
    newCostCentreState (State CostCentreState CoreProgram -> CoreProgram)
    -> State CostCentreState CoreProgram -> CoreProgram
    forall a b. (a -> b) -> a -> b
    $ do
        (CoreBind -> State CostCentreState CoreBind)
    -> CoreProgram -> State CostCentreState CoreProgram
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Env -> CoreBind -> State CostCentreState CoreBind
    doBind Env
    env) CoreProgram
    binds

    doBind :: Env -> CoreBind -> M CoreBind
    doBind :: Env -> CoreBind -> State CostCentreState CoreBind
    doBind Env
    env (NonRec Id
    b Expr Id
    rhs) = Id -> Expr Id -> CoreBind
    forall b. b -> Expr b -> Bind b
    NonRec Id
    b (Expr Id -> CoreBind)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState CoreBind
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr (Id -> Env -> Env
    addParent Id
    b Env
    env) Expr Id
    rhs
    doBind Env
    env (Rec [(Id, Expr Id)]
    bs) = [(Id, Expr Id)] -> CoreBind
    forall b. [(b, Expr b)] -> Bind b
    Rec ([(Id, Expr Id)] -> CoreBind)
    -> State CostCentreState [(Id, Expr Id)]
    -> State CostCentreState CoreBind
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ((Id, Expr Id) -> State CostCentreState (Id, Expr Id))
    -> [(Id, Expr Id)] -> State CostCentreState [(Id, Expr Id)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Id, Expr Id) -> State CostCentreState (Id, Expr Id)
    doPair [(Id, Expr Id)]
    bs
      where
        doPair :: (Id, Expr Id) -> State CostCentreState (Id, Expr Id)
    doPair (Id
    b,Expr Id
    rhs) = (Id
    b,) (Expr Id -> (Id, Expr Id))
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Id, Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr (Id -> Env -> Env
    addParent Id
    b Env
    env) Expr Id
    rhs

    doExpr :: Env -> CoreExpr -> M CoreExpr
    doExpr :: Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env e :: Expr Id
    e@(Var Id
    v)
      | Env -> Id -> Bool
    needsCallSiteCostCentre Env
    env Id
    v = do
        let nameDoc :: SDoc
            nameDoc :: SDoc
    nameDoc = NamePprCtx -> Depth -> SDoc -> SDoc
    withUserStyle NamePprCtx
    alwaysQualify Depth
    DefaultDepth (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
              [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hcat (SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    dot ((Id -> SDoc) -> [Id] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Env -> [Id]
    parents Env
    env))) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "calling:" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    v)

            ccName :: CcName
            ccName :: CcName
    ccName = String -> CcName
    mkFastString (String -> CcName) -> String -> CcName
    forall a b. (a -> b) -> a -> b
    $ SDocContext -> SDoc -> String
    renderWithContext SDocContext
    defaultSDocContext SDoc
    nameDoc
        CostCentreIndex
    ccIdx <- CcName -> M CostCentreIndex
    getCCIndex' CcName
    ccName
        let count :: Bool
    count = Env -> Bool
    countEntries Env
    env
            span :: SrcSpan
    span = case Env -> [Id]
    revParents Env
    env of
              Id
    top:[Id]
    _ -> Name -> SrcSpan
    nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
    forall a b. (a -> b) -> a -> b
    $ Id -> Name
    varName Id
    top
              [Id]
    _     -> SrcSpan
    noSrcSpan
            cc :: CostCentre
    cc = CCFlavour -> CcName -> Module -> SrcSpan -> CostCentre
    NormalCC (CostCentreIndex -> CCFlavour
    mkExprCCFlavour CostCentreIndex
    ccIdx) CcName
    ccName (Env -> Module
    thisModule Env
    env) SrcSpan
    span
            tick :: CoreTickish
            tick :: CoreTickish
    tick = CostCentre -> Bool -> Bool -> CoreTickish
    forall (pass :: TickishPass).
    CostCentre -> Bool -> Bool -> GenTickish pass
    ProfNote CostCentre
    cc Bool
    count Bool
    True
        Expr Id -> State CostCentreState (Expr Id)
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Expr Id -> State CostCentreState (Expr Id))
    -> Expr Id -> State CostCentreState (Expr Id)
    forall a b. (a -> b) -> a -> b
    $ CoreTickish -> Expr Id -> Expr Id
    forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    tick Expr Id
    e
      | Bool
    otherwise = Expr Id -> State CostCentreState (Expr Id)
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Expr Id
    e
    doExpr Env
    _env e :: Expr Id
    e@(Lit Literal
    _)       = Expr Id -> State CostCentreState (Expr Id)
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Expr Id
    e
    doExpr Env
    env (Expr Id
    f `App` Expr Id
    x)      = Expr Id -> Expr Id -> Expr Id
    forall b. Expr b -> Expr b -> Expr b
    App (Expr Id -> Expr Id -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Expr Id -> Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    f State CostCentreState (Expr Id -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Expr Id)
    forall a b.
    State CostCentreState (a -> b)
    -> State CostCentreState a -> State CostCentreState b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    x
    doExpr Env
    env (Lam Id
    b Expr Id
    x)        = Id -> Expr Id -> Expr Id
    forall b. b -> Expr b -> Expr b
    Lam Id
    b (Expr Id -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    x
    doExpr Env
    env (Let CoreBind
    b Expr Id
    rhs)      = CoreBind -> Expr Id -> Expr Id
    forall b. Bind b -> Expr b -> Expr b
    Let (CoreBind -> Expr Id -> Expr Id)
    -> State CostCentreState CoreBind
    -> State CostCentreState (Expr Id -> Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> CoreBind -> State CostCentreState CoreBind
    doBind Env
    env CoreBind
    b State CostCentreState (Expr Id -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Expr Id)
    forall a b.
    State CostCentreState (a -> b)
    -> State CostCentreState a -> State CostCentreState b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    rhs
    doExpr Env
    env (Case Expr Id
    scrut Id
    b Type
    ty [Alt Id]
    alts) =
        Expr Id -> Id -> Type -> [Alt Id] -> Expr Id
    forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
    Case (Expr Id -> Id -> Type -> [Alt Id] -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Id -> Type -> [Alt Id] -> Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    scrut State CostCentreState (Id -> Type -> [Alt Id] -> Expr Id)
    -> State CostCentreState Id
    -> State CostCentreState (Type -> [Alt Id] -> Expr Id)
    forall a b.
    State CostCentreState (a -> b)
    -> State CostCentreState a -> State CostCentreState b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Id -> State CostCentreState Id
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Id
    b State CostCentreState (Type -> [Alt Id] -> Expr Id)
    -> State CostCentreState Type
    -> State CostCentreState ([Alt Id] -> Expr Id)
    forall a b.
    State CostCentreState (a -> b)
    -> State CostCentreState a -> State CostCentreState b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Type -> State CostCentreState Type
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Type
    ty State CostCentreState ([Alt Id] -> Expr Id)
    -> State CostCentreState [Alt Id]
    -> State CostCentreState (Expr Id)
    forall a b.
    State CostCentreState (a -> b)
    -> State CostCentreState a -> State CostCentreState b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> (Alt Id -> State CostCentreState (Alt Id))
    -> [Alt Id] -> State CostCentreState [Alt Id]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Alt Id -> State CostCentreState (Alt Id)
    doAlt [Alt Id]
    alts
      where
        doAlt :: Alt Id -> State CostCentreState (Alt Id)
    doAlt (Alt AltCon
    con [Id]
    bs Expr Id
    rhs)  = AltCon -> [Id] -> Expr Id -> Alt Id
    forall b. AltCon -> [b] -> Expr b -> Alt b
    Alt AltCon
    con [Id]
    bs (Expr Id -> Alt Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Alt Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    rhs
    doExpr Env
    env (Cast Expr Id
    expr CoercionR
    co)   = Expr Id -> CoercionR -> Expr Id
    forall b. Expr b -> CoercionR -> Expr b
    Cast (Expr Id -> CoercionR -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (CoercionR -> Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    expr State CostCentreState (CoercionR -> Expr Id)
    -> State CostCentreState CoercionR
    -> State CostCentreState (Expr Id)
    forall a b.
    State CostCentreState (a -> b)
    -> State CostCentreState a -> State CostCentreState b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> CoercionR -> State CostCentreState CoercionR
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure CoercionR
    co
    doExpr Env
    env (Tick CoreTickish
    t Expr Id
    e)       = CoreTickish -> Expr Id -> Expr Id
    forall b. CoreTickish -> Expr b -> Expr b
    Tick CoreTickish
    t (Expr Id -> Expr Id)
    -> State CostCentreState (Expr Id)
    -> State CostCentreState (Expr Id)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Env -> Expr Id -> State CostCentreState (Expr Id)
    doExpr Env
    env Expr Id
    e
    doExpr Env
    _env e :: Expr Id
    e@(Type Type
    _)      = Expr Id -> State CostCentreState (Expr Id)
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Expr Id
    e
    doExpr Env
    _env e :: Expr Id
    e@(Coercion CoercionR
    _)  = Expr Id -> State CostCentreState (Expr Id)
    forall a. a -> State CostCentreState a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure Expr Id
    e

    type M = State CostCentreState

    getCCIndex' :: FastString -> M CostCentreIndex
    getCCIndex' :: CcName -> M CostCentreIndex
    getCCIndex' CcName
    name = (CostCentreState -> (CostCentreIndex, CostCentreState))
    -> M CostCentreIndex
    forall s a. (s -> (a, s)) -> State s a
    state (CcName -> CostCentreState -> (CostCentreIndex, CostCentreState)
    getCCIndex CcName
    name)

    data Env = Env
      { Env -> Module
    thisModule  :: Module
      , Env -> Bool
    countEntries :: !Bool
      , Env -> CostCentreState
    ccState     :: CostCentreState
      , Env -> [Id]
    revParents  :: [Id]
      , Env -> [CallerCcFilter]
    filters     :: [CallerCcFilter]
      }

    addParent :: Id -> Env -> Env
    addParent :: Id -> Env -> Env
    addParent Id
    i Env
    env = Env
    env { revParents = i : revParents env }

    parents :: Env -> [Id]
    parents :: Env -> [Id]
    parents Env
    env = [Id] -> [Id]
    forall a. [a] -> [a]
    reverse (Env -> [Id]
    revParents Env
    env)

    needsCallSiteCostCentre :: Env -> Id -> Bool
    needsCallSiteCostCentre :: Env -> Id -> Bool
    needsCallSiteCostCentre Env
    env Id
    i =
        (CallerCcFilter -> Bool) -> [CallerCcFilter] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any CallerCcFilter -> Bool
    matches (Env -> [CallerCcFilter]
    filters Env
    env)
      where
        matches :: CallerCcFilter -> Bool
        matches :: CallerCcFilter -> Bool
    matches CallerCcFilter
    ccf =
            Bool
    checkModule Bool -> Bool -> Bool
    && Bool
    checkFunc
          where
            checkModule :: Bool
    checkModule =
              case CallerCcFilter -> Maybe ModuleName
    ccfModuleName CallerCcFilter
    ccf of
                Just ModuleName
    modFilt
                  | Just Module
    iMod <- Name -> Maybe Module
    nameModule_maybe (Id -> Name
    varName Id
    i)
                  -> Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    iMod ModuleName -> ModuleName -> Bool
    forall a. Eq a => a -> a -> Bool
    == ModuleName
    modFilt
                  | Bool
    otherwise -> Bool
    False
                Maybe ModuleName
    Nothing -> Bool
    True
            checkFunc :: Bool
    checkFunc =
                NamePattern -> OccName -> Bool
    occNameMatches (CallerCcFilter -> NamePattern
    ccfFuncName CallerCcFilter
    ccf) (Id -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName Id
    i)

    data NamePattern
        = PChar Char NamePattern
        | PWildcard NamePattern
        | PEnd

    instance Outputable NamePattern where
      ppr :: NamePattern -> SDoc
    ppr (PChar Char
    c NamePattern
    rest) = Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    c SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> NamePattern -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr NamePattern
    rest
      ppr (PWildcard NamePattern
    rest) = Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '*' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> NamePattern -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr NamePattern
    rest
      ppr NamePattern
    PEnd = SDoc
    forall doc. IsOutput doc => doc
    Outputable.empty

    instance B.Binary NamePattern where
      get :: BinHandle -> IO NamePattern
    get BinHandle
    bh = do
        Word8
    tag <- BinHandle -> IO Word8
    forall a. Binary a => BinHandle -> IO a
    B.get BinHandle
    bh
        case Word8
    tag :: Word8 of
          Word8
    0 -> Char -> NamePattern -> NamePattern
    PChar (Char -> NamePattern -> NamePattern)
    -> IO Char -> IO (NamePattern -> NamePattern)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BinHandle -> IO Char
    forall a. Binary a => BinHandle -> IO a
    B.get BinHandle
    bh IO (NamePattern -> NamePattern) -> IO NamePattern -> IO NamePattern
    forall a b. IO (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> BinHandle -> IO NamePattern
    forall a. Binary a => BinHandle -> IO a
    B.get BinHandle
    bh
          Word8
    1 -> NamePattern -> NamePattern
    PWildcard (NamePattern -> NamePattern) -> IO NamePattern -> IO NamePattern
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BinHandle -> IO NamePattern
    forall a. Binary a => BinHandle -> IO a
    B.get BinHandle
    bh
          Word8
    2 -> NamePattern -> IO NamePattern
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure NamePattern
    PEnd
          Word8
    _ -> String -> IO NamePattern
    forall a. HasCallStack => String -> a
    panic String
    "Binary(NamePattern): Invalid tag"
      put_ :: BinHandle -> NamePattern -> IO ()
    put_ BinHandle
    bh (PChar Char
    x NamePattern
    y) = BinHandle -> Word8 -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh (Word8
    0 :: Word8) IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> BinHandle -> Char -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh Char
    x IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> BinHandle -> NamePattern -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh NamePattern
    y
      put_ BinHandle
    bh (PWildcard NamePattern
    x) = BinHandle -> Word8 -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh (Word8
    1 :: Word8) IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> BinHandle -> NamePattern -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh NamePattern
    x
      put_ BinHandle
    bh NamePattern
    PEnd = BinHandle -> Word8 -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh (Word8
    2 :: Word8)

    occNameMatches :: NamePattern -> OccName -> Bool
    occNameMatches :: NamePattern -> OccName -> Bool
    occNameMatches NamePattern
    pat = NamePattern -> String -> Bool
    go NamePattern
    pat (String -> Bool) -> (OccName -> String) -> OccName -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . OccName -> String
    occNameString
      where
        go :: NamePattern -> String -> Bool
        go :: NamePattern -> String -> Bool
    go NamePattern
    PEnd String
    "" = Bool
    True
        go (PChar Char
    c NamePattern
    rest) (Char
    d:String
    s)
          = Char
    d Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    c Bool -> Bool -> Bool
    && NamePattern -> String -> Bool
    go NamePattern
    rest String
    s
        go (PWildcard NamePattern
    rest) String
    s
          = NamePattern -> String -> Bool
    go NamePattern
    rest String
    s Bool -> Bool -> Bool
    || NamePattern -> String -> Bool
    go (NamePattern -> NamePattern
    PWildcard NamePattern
    rest) (String -> String
    forall a. HasCallStack => [a] -> [a]
    tail String
    s)
        go NamePattern
    _ String
    _  = Bool
    False

    type Parser = P.ReadP

    parseNamePattern :: Parser NamePattern
    parseNamePattern :: Parser NamePattern
    parseNamePattern = Parser NamePattern
    pattern
      where
        pattern :: Parser NamePattern
    pattern = Parser NamePattern
    star Parser NamePattern -> Parser NamePattern -> Parser NamePattern
    forall a. ReadP a -> ReadP a -> ReadP a
    P.<++ Parser NamePattern
    wildcard Parser NamePattern -> Parser NamePattern -> Parser NamePattern
    forall a. ReadP a -> ReadP a -> ReadP a
    P.<++ Parser NamePattern
    char Parser NamePattern -> Parser NamePattern -> Parser NamePattern
    forall a. ReadP a -> ReadP a -> ReadP a
    P.<++ Parser NamePattern
    end
        star :: Parser NamePattern
    star = Char -> NamePattern -> NamePattern
    PChar Char
    '*' (NamePattern -> NamePattern)
    -> ReadP String -> ReadP (NamePattern -> NamePattern)
    forall a b. a -> ReadP b -> ReadP a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ String -> ReadP String
    P.string String
    "\\*" ReadP (NamePattern -> NamePattern)
    -> Parser NamePattern -> Parser NamePattern
    forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Parser NamePattern
    pattern
        wildcard :: Parser NamePattern
    wildcard = do
          ReadP Char -> ReadP ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
    forall a b. (a -> b) -> a -> b
    $ Char -> ReadP Char
    P.char Char
    '*'
          NamePattern -> NamePattern
    PWildcard (NamePattern -> NamePattern)
    -> Parser NamePattern -> Parser NamePattern
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser NamePattern
    pattern
        char :: Parser NamePattern
    char = Char -> NamePattern -> NamePattern
    PChar (Char -> NamePattern -> NamePattern)
    -> ReadP Char -> ReadP (NamePattern -> NamePattern)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadP Char
    P.get ReadP (NamePattern -> NamePattern)
    -> Parser NamePattern -> Parser NamePattern
    forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Parser NamePattern
    pattern
        end :: Parser NamePattern
    end = NamePattern
    PEnd NamePattern -> ReadP () -> Parser NamePattern
    forall a b. a -> ReadP b -> ReadP a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ ReadP ()
    P.eof

    data CallerCcFilter
        = CallerCcFilter { CallerCcFilter -> Maybe ModuleName
    ccfModuleName  :: Maybe ModuleName
                         , CallerCcFilter -> NamePattern
    ccfFuncName    :: NamePattern
                         }

    instance Outputable CallerCcFilter where
      ppr :: CallerCcFilter -> SDoc
    ppr CallerCcFilter
    ccf =
        SDoc -> (ModuleName -> SDoc) -> Maybe ModuleName -> SDoc
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '*') ModuleName -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CallerCcFilter -> Maybe ModuleName
    ccfModuleName CallerCcFilter
    ccf)
        SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '.'
        SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> NamePattern -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (CallerCcFilter -> NamePattern
    ccfFuncName CallerCcFilter
    ccf)

    instance B.Binary CallerCcFilter where
      get :: BinHandle -> IO CallerCcFilter
    get BinHandle
    bh = Maybe ModuleName -> NamePattern -> CallerCcFilter
    CallerCcFilter (Maybe ModuleName -> NamePattern -> CallerCcFilter)
    -> IO (Maybe ModuleName) -> IO (NamePattern -> CallerCcFilter)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> BinHandle -> IO (Maybe ModuleName)
    forall a. Binary a => BinHandle -> IO a
    B.get BinHandle
    bh IO (NamePattern -> CallerCcFilter)
    -> IO NamePattern -> IO CallerCcFilter
    forall a b. IO (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> BinHandle -> IO NamePattern
    forall a. Binary a => BinHandle -> IO a
    B.get BinHandle
    bh
      put_ :: BinHandle -> CallerCcFilter -> IO ()
    put_ BinHandle
    bh (CallerCcFilter Maybe ModuleName
    x NamePattern
    y) = BinHandle -> Maybe ModuleName -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh Maybe ModuleName
    x IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> BinHandle -> NamePattern -> IO ()
    forall a. Binary a => BinHandle -> a -> IO ()
    B.put_ BinHandle
    bh NamePattern
    y

    parseCallerCcFilter :: String -> Either String CallerCcFilter
    parseCallerCcFilter :: String -> Either String CallerCcFilter
    parseCallerCcFilter String
    inp =
        case ReadP CallerCcFilter -> ReadS CallerCcFilter
    forall a. ReadP a -> ReadS a
    P.readP_to_S ReadP CallerCcFilter
    parseCallerCcFilter' String
    inp of
          ((CallerCcFilter
    result, String
    ""):[(CallerCcFilter, String)]
    _) -> CallerCcFilter -> Either String CallerCcFilter
    forall a b. b -> Either a b
    Right CallerCcFilter
    result
          [(CallerCcFilter, String)]
    _ -> String -> Either String CallerCcFilter
    forall a b. a -> Either a b
    Left (String -> Either String CallerCcFilter)
    -> String -> Either String CallerCcFilter
    forall a b. (a -> b) -> a -> b
    $ String
    "parse error on " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    inp

    parseCallerCcFilter' :: Parser CallerCcFilter
    parseCallerCcFilter' :: ReadP CallerCcFilter
    parseCallerCcFilter' =
      Maybe ModuleName -> NamePattern -> CallerCcFilter
    CallerCcFilter
        (Maybe ModuleName -> NamePattern -> CallerCcFilter)
    -> ReadP (Maybe ModuleName)
    -> ReadP (NamePattern -> CallerCcFilter)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadP (Maybe ModuleName)
    moduleFilter
        ReadP (NamePattern -> CallerCcFilter)
    -> ReadP Char -> ReadP (NamePattern -> CallerCcFilter)
    forall a b. ReadP a -> ReadP b -> ReadP a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <*  Char -> ReadP Char
    P.char Char
    '.'
        ReadP (NamePattern -> CallerCcFilter)
    -> Parser NamePattern -> ReadP CallerCcFilter
    forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Parser NamePattern
    parseNamePattern
      where
        moduleFilter :: Parser (Maybe ModuleName)
        moduleFilter :: ReadP (Maybe ModuleName)
    moduleFilter =
          (ModuleName -> Maybe ModuleName
    forall a. a -> Maybe a
    Just (ModuleName -> Maybe ModuleName)
    -> (String -> ModuleName) -> String -> Maybe ModuleName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ModuleName
    mkModuleName (String -> Maybe ModuleName)
    -> ReadP String -> ReadP (Maybe ModuleName)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadP String
    moduleName)
          ReadP (Maybe ModuleName)
    -> ReadP (Maybe ModuleName) -> ReadP (Maybe ModuleName)
    forall a. ReadP a -> ReadP a -> ReadP a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|>
          (Maybe ModuleName
    forall a. Maybe a
    Nothing Maybe ModuleName -> ReadP Char -> ReadP (Maybe ModuleName)
    forall a b. a -> ReadP b -> ReadP a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Char -> ReadP Char
    P.char Char
    '*')

        moduleName :: Parser String
        moduleName :: ReadP String
    moduleName = do
          Char
    c <- (Char -> Bool) -> ReadP Char
    P.satisfy Char -> Bool
    isUpper
          String
    cs <- (Char -> Bool) -> ReadP String
    P.munch1 (\Char
    c -> Char -> Bool
    isUpper Char
    c Bool -> Bool -> Bool
    || Char -> Bool
    isLower Char
    c Bool -> Bool -> Bool
    || Char -> Bool
    isDigit Char
    c Bool -> Bool -> Bool
    || Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_')
          Maybe String
    rest <- ReadP String -> ReadP (Maybe String)
    forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
    optional (ReadP String -> ReadP (Maybe String))
    -> ReadP String -> ReadP (Maybe String)
    forall a b. (a -> b) -> a -> b
    $ Char -> ReadP Char
    P.char Char
    '.' ReadP Char -> ReadP String -> ReadP String
    forall a b. ReadP a -> ReadP b -> ReadP b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (String -> String) -> ReadP String -> ReadP String
    forall a b. (a -> b) -> ReadP a -> ReadP b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Char
    '.'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) ReadP String
    moduleName
          String -> ReadP String
    forall a. a -> ReadP a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> ReadP String) -> String -> ReadP String
    forall a b. (a -> b) -> a -> b
    $ Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    : (String
    cs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    "" Maybe String
    rest)