{-# 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)