    module GHC.Core.Opt.CallerCC.Types ( NamePattern(..)
                                       , CallerCcFilter(..)
                                       , occNameMatches
                                       , parseCallerCcFilter
                                       , parseNamePattern
                                       ) where

    import Data.Word (Word8)
    import Data.Maybe

    import Control.Applicative
    import Data.Either
    import Control.Monad
    import qualified Text.ParserCombinators.ReadP as P

    import GHC.Prelude
    import GHC.Utils.Outputable as Outputable
    import GHC.Types.Name hiding (varName)
    import GHC.Utils.Panic
    import qualified GHC.Utils.Binary as B
    import Data.Char

    import Language.Haskell.Syntax.Module.Name

    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 :: ReadBinHandle -> IO NamePattern
    get ReadBinHandle
    bh = do
        tag <- ReadBinHandle -> IO Word8
    forall a. Binary a => ReadBinHandle -> IO a
    B.get ReadBinHandle
    bh
        case 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
    <$> ReadBinHandle -> IO Char
    forall a. Binary a => ReadBinHandle -> IO a
    B.get ReadBinHandle
    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
    <*> ReadBinHandle -> IO NamePattern
    forall a. Binary a => ReadBinHandle -> IO a
    B.get ReadBinHandle
    bh
          Word8
    1 -> NamePattern -> NamePattern
    PWildcard (NamePattern -> NamePattern) -> IO NamePattern -> IO NamePattern
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ReadBinHandle -> IO NamePattern
    forall a. Binary a => ReadBinHandle -> IO a
    B.get ReadBinHandle
    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_ :: WriteBinHandle -> NamePattern -> IO ()
    put_ WriteBinHandle
    bh (PChar Char
    x NamePattern
    y) = WriteBinHandle -> Word8 -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    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
    >> WriteBinHandle -> Char -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    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
    >> WriteBinHandle -> NamePattern -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    bh NamePattern
    y
      put_ WriteBinHandle
    bh (PWildcard NamePattern
    x) = WriteBinHandle -> Word8 -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    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
    >> WriteBinHandle -> NamePattern -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    bh NamePattern
    x
      put_ WriteBinHandle
    bh NamePattern
    PEnd = WriteBinHandle -> Word8 -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    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
    namePattern
      where
        namePattern :: Parser NamePattern
    namePattern = 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
    namePattern
        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
    namePattern
        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
    namePattern
        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 :: ReadBinHandle -> IO CallerCcFilter
    get ReadBinHandle
    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
    <$> ReadBinHandle -> IO (Maybe ModuleName)
    forall a. Binary a => ReadBinHandle -> IO a
    B.get ReadBinHandle
    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
    <*> ReadBinHandle -> IO NamePattern
    forall a. Binary a => ReadBinHandle -> IO a
    B.get ReadBinHandle
    bh
      put_ :: WriteBinHandle -> CallerCcFilter -> IO ()
    put_ WriteBinHandle
    bh (CallerCcFilter Maybe ModuleName
    x NamePattern
    y) = WriteBinHandle -> Maybe ModuleName -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    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
    >> WriteBinHandle -> NamePattern -> IO ()
    forall a. Binary a => WriteBinHandle -> a -> IO ()
    B.put_ WriteBinHandle
    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
          c <- (Char -> Bool) -> ReadP Char
    P.satisfy Char -> Bool
    isUpper
          cs <- 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
    '_')
          rest <- optional $ P.char '.' >> fmap ('.':) moduleName
          return $ c : (cs ++ fromMaybe "" rest)