Support regexes via regex-pcre

hxtools.cabal

@@ -34,7 +34,9 @@ executable hxbrief
                       transformers >=0.5.6.2 &&<0.6,
                       clock >=0.8 &&<0.9,
                       pretty >=1.1.3.6 && <1.2,
-                      text >=1.2.4
+                      text >=1.2.4,
+                      regex-base >=0.94 && <0.95,
+                      regex-pcre-builtin >=0.95 && < 0.96
   hs-source-dirs:     src-hxbrief
   default-language:   Haskell2010
   ghc-options:        -rtsopts -threaded -Wall

src-hxbrief/Main.hs

@@ -20,6 +20,7 @@ import           Control.Exception              ( AsyncException(UserInterrupt)
                                                 )
 import           Control.Monad                  ( forM_
                                                 , forever
+                                                , join
                                                 , replicateM
                                                 , unless
                                                 , when
@@ -81,6 +82,8 @@ import qualified System.Process                as P
 import qualified Text.PrettyPrint.HughesPJ     as PP
 import           Text.Printf                    ( printf )
 import           Text.Read                      ( readMaybe )
+import qualified Text.Regex.Base.RegexLike     as Regex
+import qualified Text.Regex.PCRE.Text          as PCRE
 import qualified UI.Butcher.Monadic            as B
 
 import           Util
@@ -111,7 +114,7 @@ data Config = Config
   , c_lines       :: Int
   , c_keepStdout  :: KeepMode
   , c_keepStderr  :: KeepMode
-  , c_summarize   :: [(JoinMode, Text)]
+  , c_summarize   :: [(JoinMode, Text, PCRE.Regex)]
   , c_outFile     :: Maybe Handle
   , c_errFile     :: Maybe Handle
   , c_sectionChar :: Maybe Char
@@ -164,16 +167,6 @@ stateLine updateCur showCur = do
 firstJust :: (a -> Maybe b) -> [a] -> Maybe b
 firstJust f = listToMaybe . mapMaybe f
 
-matchPattern :: Text -> Text -> Bool
-matchPattern pat s = case Text.split (== '*') pat of
-  []                      -> False
-  [exact]                 -> exact == s
-  [t1, t2] | Text.null t1 -> t2 `Text.isSuffixOf` s -- *foo
-  [t1, t2] | Text.null t2 -> t1 `Text.isPrefixOf` s -- foo*
-  [t1, t2]                -> t1 `Text.isPrefixOf` s && t2 `Text.isSuffixOf` s -- foo*bar
-  [t1, t2, t3] | Text.null t1 && Text.null t3 -> t2 `Text.isInfixOf` s -- *foo*
-  _                       -> undefined
-
 dispatchLine :: (StreamKind, Text) -> StateT State IO ()
 dispatchLine line@(kind, str) = do
   conf <- gets s_config
@@ -192,11 +185,7 @@ dispatchYielded line@(kind, str) = do
   modify $ \s -> s { s_history = line : s_history s }
 
 showPattern :: Text -> Text
-showPattern = Text.concatMap
-  (\case
-    '*' -> setFGColorVivid Ansi.Yellow <> t "…" <> fReset
-    x   -> Text.singleton x
-  )
+showPattern p = setFGColorVivid Ansi.Yellow <> p <> fReset
 
 dispatchPat :: StreamKind -> Int -> Text -> [Text] -> StateT State IO ()
 dispatchPat oldKind i pat prefix = do
@@ -253,14 +242,21 @@ summarizeLines :: (StreamKind, Text) -> StateT State IO ()
 summarizeLines cur@(kind, line) = do
   s <- get
   let conf = s_config s
-  let match = firstJust
-        (\joiner@(_, pat) ->
-          if matchPattern pat line then Just joiner else Nothing
-        )
-        (c_summarize conf ++ case kind of
-          StdOut -> [ (JoinAll, t "*") | c_keepStdout conf == Conflate ]
-          StdErr -> [ (JoinAll, t "*") | c_keepStderr conf == Conflate ]
+  let match :: Maybe (JoinMode, Text) =
+        case
+            firstJust
+              (\(mode, pat, regex) -> if Regex.matchTest regex line
+                then Just (mode, pat)
+                else Nothing
               )
+              (c_summarize conf)
+          of
+            j@Just{} -> j
+            Nothing | kind == StdOut && c_keepStdout conf == Conflate ->
+              Just (JoinAll, t "*")
+            Nothing | kind == StdErr && c_keepStderr conf == Conflate ->
+              Just (JoinAll, t "*")
+            Nothing -> Nothing
   case (s_summary s, match) of
     (Nothing, _) -> put s
       { s_summary = Just
@@ -570,6 +566,19 @@ main = B.mainFromCmdParser $ do
             ++ " lines!\n"
           pure actual
         _ -> pure numLines
+      let compiler joinMode x = do
+            let tx = t x
+            regexE <- PCRE.compile PCRE.compBlank PCRE.execBlank tx
+            case regexE of
+              Left  err   -> error $ show err
+              Right regex -> pure (joinMode, tx, regex)
+      compiled_summarize <-
+        sequence
+        $ join
+        $ [ yield <&> compiler JoinYield
+          , summarize <&> compiler JoinSpecific
+          , skip <&> compiler JoinAll
+          ]
       (lastLine, ecMay) <- displayConsoleRegions $ do
         initialState <- do
           startTime <- getTime RealtimeCoarse
@@ -599,9 +608,7 @@ main = B.mainFromCmdParser $ do
                                   | conflateStderr || conflateBoth -> Conflate
                                   | dropStderr || dropBoth -> Drop
                                   | otherwise -> Keep
-              , c_summarize   = (yield <&> \x -> (JoinYield, t x))
-                                ++ (summarize <&> \x -> (JoinSpecific, t x))
-                                ++ (skip <&> \x -> (JoinAll, t x))
+              , c_summarize   = compiled_summarize
               , c_outFile     = Nothing
               , c_errFile     = Nothing
               , c_sectionChar = Nothing -- if section then Just '#' else Nothing