Rewrite CallerCC parser using ReadP

This allows us to remove the dependency on parsec and hence transitively
on text.

Also added some simple unit tests for the parser and fixed two small
issues in the documentation.

Fixes #21033

6 files changed, 63 insertions, 14 deletions

diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs
index 8808296126..e8ac5a7cff 100644
--- a/compiler/GHC/Core/Opt/CallerCC.hs
+++ b/compiler/GHC/Core/Opt/CallerCC.hs
@@ -10,19 +10,19 @@
 -- flag.
 module GHC.Core.Opt.CallerCC
     ( addCallerCostCentres
-    , CallerCcFilter
+    , CallerCcFilter(..)
+    , NamePattern(..)
     , parseCallerCcFilter
     ) where
 
-import Data.Bifunctor
 import Data.Word (Word8)
 import Data.Maybe
-import qualified Text.Parsec as P
 
 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
@@ -42,6 +42,7 @@ import GHC.Core
 import GHC.Core.Opt.Monad
 import GHC.Utils.Panic
 import qualified GHC.Utils.Binary as B
+import Data.Char
 
 addCallerCostCentres :: ModGuts -> CoreM ModGuts
 addCallerCostCentres guts = do
@@ -171,17 +172,17 @@ occNameMatches pat = go pat . occNameString
       = go rest s || go (PWildcard rest) (tail s)
     go _ _  = False
 
-type Parser = P.Parsec String ()
+type Parser = P.ReadP
 
 parseNamePattern :: Parser NamePattern
 parseNamePattern = pattern
   where
-    pattern = star <|> wildcard <|> char <|> end
+    pattern = star P.<++ wildcard P.<++ char P.<++ end
     star = PChar '*' <$ P.string "\\*" <*> pattern
     wildcard = do
       void $ P.char '*'
       PWildcard <$> pattern
-    char = PChar <$> P.anyChar <*> pattern
+    char = PChar <$> P.get <*> pattern
     end = PEnd <$ P.eof
 
 data CallerCcFilter
@@ -200,8 +201,10 @@ instance B.Binary CallerCcFilter where
   put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y
 
 parseCallerCcFilter :: String -> Either String CallerCcFilter
-parseCallerCcFilter =
-    first show . P.parse parseCallerCcFilter' "caller-CC filter"
+parseCallerCcFilter inp =
+    case P.readP_to_S parseCallerCcFilter' inp of
+      ((result, ""):_) -> Right result
+      _ -> Left $ "parse error on " ++ inp
 
 parseCallerCcFilter' :: Parser CallerCcFilter
 parseCallerCcFilter' =
@@ -218,8 +221,8 @@ parseCallerCcFilter' =
 
     moduleName :: Parser String
     moduleName = do
-      c <- P.upper
-      cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_"
-      rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName
+      c <- P.satisfy isUpper
+      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')
+      rest <- optional $ P.char '.' >> fmap ('.':) moduleName
       return $ c : (cs ++ fromMaybe "" rest)
 
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index ff90538a0f..0f1abca002 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -74,7 +74,6 @@ Library
                    hpc        == 0.6.*,
                    transformers == 0.5.*,
                    exceptions == 0.10.*,
-                   parsec,
                    stm,
                    ghc-boot   == @ProjectVersionMunged@,
                    ghc-heap   == @ProjectVersionMunged@,
diff --git a/docs/users_guide/profiling.rst b/docs/users_guide/profiling.rst
index 0aa437a4dc..a1b1de819f 100644
--- a/docs/users_guide/profiling.rst
+++ b/docs/users_guide/profiling.rst
@@ -386,9 +386,9 @@ compiled program.
      * ``Data.List.map``
      * ``*.map``
      * ``*.parse*``
-     * ``*.<\\*>``
+     * ``*.<\*>``
 
-    The ``*`` character can be used literally by escaping (e.g. ``\\*``).
+    The ``*`` character can be used literally by escaping (e.g. ``\*``).
 
 .. ghc-flag:: -fprof-auto
     :shortdesc: Auto-add ``SCC``\\ s to all bindings not marked INLINE
diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs
new file mode 100644
index 0000000000..a6f160a5e3
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.hs
@@ -0,0 +1,38 @@
+-- Unit tests for the CallerCcParser
+{-# LANGUAGE StandaloneDeriving #-}
+module Main where
+
+import GHC.Core.Opt.CallerCC
+import GHC.Unit.Module.Name
+
+deriving instance Eq CallerCcFilter
+deriving instance Show CallerCcFilter
+deriving instance Eq NamePattern
+deriving instance Show NamePattern
+
+runTest :: String -> Maybe CallerCcFilter -> IO ()
+runTest filter exp = putStrLn $
+  case parseCallerCcFilter filter of
+    Left err -> case exp of
+                  Nothing -> "Expected failure: " ++ filter ++ " " ++ err
+                  Just exp -> "Unexpected failure: " ++ filter ++ " " ++ err
+    Right res ->
+      case exp of
+        Nothing -> "Unexpected parse: " ++ filter ++ " " ++ show res
+        Just exp | exp == res -> "Expected parse: " ++ filter ++ " " ++ show res
+                 | otherwise  -> "Unexpected parse: " ++ filter ++ show res ++ show exp
+
+mkPattern :: String -> NamePattern
+mkPattern s = foldr PChar PEnd s
+
+mkPattern_ :: String -> NamePattern -> NamePattern
+mkPattern_ s e = foldr PChar e s
+
+main = do
+  runTest "*.map" (Just (CallerCcFilter Nothing (mkPattern "map")))
+  runTest "*.parse*" (Just (CallerCcFilter Nothing (mkPattern_ "parse" (PWildcard PEnd))))
+  runTest "Data.List.map" (Just (CallerCcFilter (Just (mkModuleName "Data.List")) (mkPattern "map")))
+  runTest "*.<\\*>" (Just (CallerCcFilter Nothing (mkPattern "<*>")))
+  runTest "as.b" Nothing
+
+
diff --git a/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout
new file mode 100644
index 0000000000..4c60714103
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/caller-cc/CallerCcParser.stdout
@@ -0,0 +1,5 @@
+Expected parse: *.map CallerCcFilter {ccfModuleName = Nothing, ccfFuncName = PChar 'm' (PChar 'a' (PChar 'p' PEnd))}
+Expected parse: *.parse* CallerCcFilter {ccfModuleName = Nothing, ccfFuncName = PChar 'p' (PChar 'a' (PChar 'r' (PChar 's' (PChar 'e' (PWildcard PEnd)))))}
+Expected parse: Data.List.map CallerCcFilter {ccfModuleName = Just (ModuleName "Data.List"), ccfFuncName = PChar 'm' (PChar 'a' (PChar 'p' PEnd))}
+Expected parse: *.<\*> CallerCcFilter {ccfModuleName = Nothing, ccfFuncName = PChar '<' (PChar '*' (PChar '>' PEnd))}
+Expected failure: as.b parse error on as.b
diff --git a/testsuite/tests/profiling/should_run/caller-cc/all.T b/testsuite/tests/profiling/should_run/caller-cc/all.T
index 2b8837aa07..db9979b67d 100644
--- a/testsuite/tests/profiling/should_run/caller-cc/all.T
+++ b/testsuite/tests/profiling/should_run/caller-cc/all.T
@@ -1,3 +1,7 @@
+test('CallerCcParser', normal,
+     compile_and_run,
+     ['-package ghc'])
+
 setTestOpts(req_profiling)
 setTestOpts(extra_ways(['prof', 'ghci-ext-prof']))
 setTestOpts(only_ways(prof_ways))