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)