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)