From c3cc2e817004936932dae65d9f558e84957b5e4b Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 7 Dec 2022 16:46:58 +0100 Subject: [PATCH] Refactor from String to Text --- hxtools.cabal | 3 +- src-hxbrief/Main.hs | 330 ++++++++++++++++++++++---------------------- src-hxbrief/Util.hs | 41 +++--- 3 files changed, 192 insertions(+), 182 deletions(-) diff --git a/hxtools.cabal b/hxtools.cabal index 23344fc..444936b 100644 --- a/hxtools.cabal +++ b/hxtools.cabal @@ -33,7 +33,8 @@ executable hxbrief async >=2.2.3 && <2.3, transformers >=0.5.6.2 &&<0.6, clock >=0.8 &&<0.9, - pretty >=1.1.3.6 && <1.2 + pretty >=1.1.3.6 && <1.2, + text >=1.2.4 hs-source-dirs: src-hxbrief default-language: Haskell2010 ghc-options: -rtsopts -threaded -Wall diff --git a/src-hxbrief/Main.hs b/src-hxbrief/Main.hs index 345fa63..cdab5c0 100644 --- a/src-hxbrief/Main.hs +++ b/src-hxbrief/Main.hs @@ -45,6 +45,9 @@ import Data.List ( isInfixOf import Data.Maybe ( listToMaybe , mapMaybe ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO import qualified GHC.IO.Encoding import Lens.Micro ( (<&>) ) import System.Clock ( Clock(RealtimeCoarse) @@ -95,7 +98,7 @@ data JoinedInfo = JoinedNot -- Line did not match any pattern | JoinedYield -- Line matched a yield pattern, must be forwarded as-is | JoinedAll Int - | Joined Int String [String] -- pattern, prefix + | Joined Int Text [Text] -- pattern, prefix data KeepMode = Drop -- dont forward @@ -104,11 +107,11 @@ data KeepMode deriving (Eq, Show) data Config = Config - { c_label :: String + { c_label :: Text , c_lines :: Int , c_keepStdout :: KeepMode , c_keepStderr :: KeepMode - , c_summarize :: [(JoinMode, String)] + , c_summarize :: [(JoinMode, Text)] , c_outFile :: Maybe Handle , c_errFile :: Maybe Handle , c_sectionChar :: Maybe Char @@ -118,13 +121,13 @@ data Config = Config data State = State { s_config :: Config , s_regions :: [ConsoleRegion] - , s_history :: [(StreamKind, String)] - , s_lines :: [(StreamKind, String)] + , s_history :: [(StreamKind, Text)] + , s_lines :: [(StreamKind, Text)] , s_countOut :: Int , s_countErr :: Int , s_globalStart :: TimeSpec , s_lastLineTime :: TimeSpec - , s_summary :: Maybe ((StreamKind, String), JoinedInfo) + , s_summary :: Maybe ((StreamKind, Text), JoinedInfo) } @@ -141,88 +144,86 @@ getTimeDiff updateCur = do ) -stateLine :: Bool -> Bool -> StateT State IO String +stateLine :: Bool -> Bool -> StateT State IO Text stateLine updateCur showCur = do (diffFloat1, diffFloat2) <- getTimeDiff updateCur s <- get let outStr = if showCur && diffFloat2 > 1.0 - then printf + then t $ printf "waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr" diffFloat2 diffFloat1 (s_countOut s) (s_countErr s) - else printf "%0.3fs total, %i lines stdout %i lines stderr" - diffFloat1 - (s_countOut s) - (s_countErr s) + else t $ printf "%0.3fs total, %i lines stdout %i lines stderr" + diffFloat1 + (s_countOut s) + (s_countErr s) pure $ outStr firstJust :: (a -> Maybe b) -> [a] -> Maybe b firstJust f = listToMaybe . mapMaybe f -matchPattern :: String -> String -> Bool -matchPattern pat s = case break (== '*') pat of - ("", "*" ) -> True - ("", '*' : rest) -> case break (== '*') rest of - (start, "*") -> start `isInfixOf` s - (_ , "" ) -> rest `isSuffixOf` s - _ -> error $ "too many globs in pattern " ++ pat ++ "!" - (start, '*' : rest) -> if any (== '*') rest - then error "only one glob supported in patterns!" - else start `isPrefixOf` s && rest `isSuffixOf` s - ("" , "") -> error "empty pattern" - (exact, "") -> exact == s - _ -> undefined +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, String) -> StateT State IO () +dispatchLine :: (StreamKind, Text) -> StateT State IO () dispatchLine line@(kind, str) = do conf <- gets s_config liftIO $ case kind of StdOut -> when (c_keepStdout conf /= Drop) - $ outputConcurrent (fReset ++ str ++ "\n") - StdErr -> - when (c_keepStderr conf /= Drop) $ errorConcurrent (fReset ++ str ++ "\n") + $ outputConcurrent (fReset <> str <> t "\n") + StdErr -> when (c_keepStderr conf /= Drop) + $ errorConcurrent (fReset <> str <> t "\n") modify $ \s -> s { s_history = line : s_history s } -dispatchYielded :: (StreamKind, String) -> StateT State IO () +dispatchYielded :: (StreamKind, Text) -> StateT State IO () dispatchYielded line@(kind, str) = do liftIO $ case kind of - StdOut -> outputConcurrent (fReset ++ str ++ "\n") - StdErr -> errorConcurrent (fReset ++ str ++ "\n") + StdOut -> outputConcurrent (fReset <> str <> t "\n") + StdErr -> errorConcurrent (fReset <> str <> t "\n") modify $ \s -> s { s_history = line : s_history s } -showPattern :: String -> String -showPattern p = p >>= \case - '*' -> setFGColorVivid Ansi.Yellow ++ "…" ++ fReset - x -> [x] +showPattern :: Text -> Text +showPattern = Text.concatMap + (\case + '*' -> setFGColorVivid Ansi.Yellow <> t "…" <> fReset + x -> Text.singleton x + ) -dispatchPat :: StreamKind -> Int -> String -> [String] -> StateT State IO () +dispatchPat :: StreamKind -> Int -> Text -> [Text] -> StateT State IO () dispatchPat oldKind i pat prefix = do let kindStr = case oldKind of - StdOut -> "stdout" - StdErr -> "stderr" + StdOut -> t "stdout" + StdErr -> t "stderr" let betterName = - let a = unwords prefix - la = length a + let a = Text.unwords prefix + la = Text.length a in if | i == 1 && la < 70 -> a - | la > length pat && la < 70 - -> a ++ setFGColorVivid Ansi.Yellow ++ " …" ++ fReset + | la > Text.length pat && la < 70 + -> a <> setFGColorVivid Ansi.Yellow <> t " …" <> fReset | otherwise -> showPattern pat let prettyPat = fGrey - ++ "(" - ++ show i - ++ " lines " - ++ kindStr - ++ ")" - ++ fReset - ++ " " - ++ betterName - ++ "\n" + <> t "(" + <> t (show i) + <> t " lines " + <> kindStr + <> t ")" + <> fReset + <> t " " + <> betterName + <> t "\n" conf <- gets s_config liftIO $ case oldKind of StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat @@ -231,24 +232,24 @@ dispatchPat oldKind i pat prefix = do dispatchSkipped :: StreamKind -> Int -> StateT State IO () dispatchSkipped oldKind i = do let kindStr = case oldKind of - StdOut -> "stdout" - StdErr -> "stderr" - let prettyPat = + StdOut -> t "stdout" + StdErr -> t "stderr" + let prettyPat :: Text = fGrey - ++ "(" - ++ show i - ++ " lines " - ++ kindStr - ++ ") …skipped…" - ++ fReset - ++ "\n" + <> t "(" + <> t (show i) + <> t " lines " + <> kindStr + <> t ") …skipped…" + <> fReset + <> t "\n" conf <- gets s_config liftIO $ case oldKind of StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat -summarizeLines :: (StreamKind, String) -> StateT State IO () +summarizeLines :: (StreamKind, Text) -> StateT State IO () summarizeLines cur@(kind, line) = do s <- get let conf = s_config s @@ -257,31 +258,31 @@ summarizeLines cur@(kind, line) = do if matchPattern pat line then Just joiner else Nothing ) (c_summarize conf ++ case kind of - StdOut -> [ (JoinAll, "*") | c_keepStdout conf == Conflate ] - StdErr -> [ (JoinAll, "*") | c_keepStderr conf == Conflate ] + StdOut -> [ (JoinAll, t "*") | c_keepStdout conf == Conflate ] + StdErr -> [ (JoinAll, t "*") | c_keepStderr conf == Conflate ] ) case (s_summary s, match) of (Nothing, _) -> put s { s_summary = Just - ( cur - , case match of - Nothing -> JoinedNot - Just (JoinYield , _ ) -> JoinedYield - Just (JoinAll , _ ) -> JoinedAll 1 - Just (JoinSpecific, pat) -> Joined 1 pat (words line) - ) + ( cur + , case match of + Nothing -> JoinedNot + Just (JoinYield , _ ) -> JoinedYield + Just (JoinAll , _ ) -> JoinedAll 1 + Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + ) } (Just (oldLine, JoinedNot), _) -> do dispatchLine oldLine put s { s_summary = Just - ( cur - , case match of - Nothing -> JoinedNot - Just (JoinYield , _ ) -> JoinedYield - Just (JoinAll , _ ) -> JoinedAll 1 - Just (JoinSpecific, pat) -> Joined 1 pat (words line) - ) + ( cur + , case match of + Nothing -> JoinedNot + Just (JoinYield , _ ) -> JoinedYield + Just (JoinAll , _ ) -> JoinedAll 1 + Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + ) } (Just (oldLine, JoinedYield), Nothing) -> do dispatchYielded oldLine @@ -290,13 +291,13 @@ summarizeLines cur@(kind, line) = do dispatchYielded oldLine put s { s_summary = Just - ( cur - , case match of - Nothing -> JoinedNot - Just (JoinAll , _ ) -> JoinedAll 1 - Just (JoinSpecific, pat) -> Joined 1 pat (words line) - Just (JoinYield , _ ) -> JoinedYield - ) + ( cur + , case match of + Nothing -> JoinedNot + Just (JoinAll , _ ) -> JoinedAll 1 + Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + Just (JoinYield , _ ) -> JoinedYield + ) } (Just ((oldKind, _), JoinedAll i), Nothing) -> do dispatchSkipped oldKind i @@ -316,7 +317,7 @@ summarizeLines cur@(kind, line) = do put s { s_summary = Just (cur, JoinedAll 1) } (JoinSpecific, pat) -> do dispatchSkipped oldKind i - put s { s_summary = Just (cur, Joined 1 pat (words line)) } + put s { s_summary = Just (cur, Joined 1 pat (Text.words line)) } (Just ((oldKind, _), Joined i oldPat oldPrefix), Just joiner) -> case joiner of (JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do @@ -324,22 +325,22 @@ summarizeLines cur@(kind, line) = do let go [] = [] go ((a, b) : rest) | a == b = a : go rest | otherwise = [] - in go $ zip oldPrefix (words line) + in go $ zip oldPrefix (Text.words line) put s { s_summary = Just (cur, Joined (i + 1) pat newPrefix) } _ -> do dispatchPat oldKind i oldPat oldPrefix put s { s_summary = Just - ( cur - , case joiner of - (JoinYield , _ ) -> JoinedYield - (JoinAll , _ ) -> JoinedAll 1 - (JoinSpecific, pat) -> Joined 1 pat (words line) - ) + ( cur + , case joiner of + (JoinYield , _ ) -> JoinedYield + (JoinAll , _ ) -> JoinedAll 1 + (JoinSpecific, pat) -> Joined 1 pat (Text.words line) + ) } -processLine :: (StreamKind, String) -> State -> IO State +processLine :: (StreamKind, Text) -> State -> IO State processLine newPair@(kind, _) = execStateT $ do conf <- gets s_config modify $ \s -> s { s_lines = newPair : s_lines s } @@ -353,77 +354,78 @@ processLine newPair@(kind, _) = execStateT $ do StdErr -> modify $ \s -> s { s_countErr = s_countErr s + 1 } curLines <- gets s_lines prettyLinesWithSummary <- do - let ellipse = - let go _ "" = "" - go 0 _ = "…" - go n (x : xs) = x : go (n - 1) xs + let ellipse :: Text -> Text + ellipse input = + let inputLength = Text.length input in case c_termSize conf of - Nothing -> id - Just (_, w) -> go (w - 3) + Nothing -> input + Just (_, w) -> if inputLength <= w - 2 + then input + else Text.take (w - 3) input <> t "…" let prettyLines = reverse $ take (c_lines conf) curLines <&> \case - (StdOut, line) -> fWhiteDis ++ "│ " ++ fReset ++ ellipse line - (StdErr, line) -> fRedDis ++ "│ " ++ fReset ++ ellipse line + (StdOut, line) -> fWhiteDis <> t "│ " <> fReset <> ellipse line + (StdErr, line) -> fRedDis <> t "│ " <> fReset <> ellipse line summary <- gets s_summary pure $ case summary of Nothing -> prettyLines Just ((StdOut, line), JoinedNot) -> - (fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdOut, line), JoinedAll 1) -> - (fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdOut, _line), JoinedAll i) -> ( fWhiteDis - ++ "│ " - ++ fGrey - ++ "…skipped… (" - ++ show i - ++ " lines)" - ++ fReset + <> t "│ " + <> fGrey + <> t "…skipped… (" + <> t (show i) + <> t " lines)" + <> fReset ) : prettyLines Just ((StdOut, line), Joined 1 _ _) -> - (fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdOut, _), Joined i pat _) -> ( fWhiteDis - ++ "│ " - ++ fReset - ++ showPattern pat - ++ fGrey - ++ " (" - ++ show i - ++ " lines)" - ++ fReset + <> t "│ " + <> fReset + <> showPattern pat + <> fGrey + <> t " (" + <> t (show i) + <> t " lines)" + <> fReset ) : prettyLines Just ((StdOut, line), JoinedYield) -> - (fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdErr, line), JoinedNot) -> - (fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdErr, line), JoinedYield) -> - (fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdErr, line), JoinedAll 1) -> - (fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdErr, _line), JoinedAll i) -> ( fRedDis - ++ "│ " - ++ fGrey - ++ "…skipped… (" - ++ show i - ++ " lines)" - ++ fReset + <> t "│ " + <> fGrey + <> t "…skipped… (" + <> t (show i) + <> t " lines)" + <> fReset ) : prettyLines Just ((StdErr, line), Joined 1 _ _) -> - (fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines + (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines Just ((StdErr, _), Joined i pat _) -> ( fRedDis - ++ "│ " - ++ fReset - ++ showPattern pat - ++ fGrey - ++ " (" - ++ show i - ++ " lines)" - ++ fReset + <> t "│ " + <> fReset + <> showPattern pat + <> fGrey + <> t " (" + <> t (show i) + <> t " lines)" + <> fReset ) : prettyLines let showCount = min (c_lines conf) (length prettyLinesWithSummary) @@ -450,12 +452,12 @@ updateStateLine updateCur = do liftIO $ setConsoleRegion (last $ s_regions s) ( fGrey - ++ "╰─ … " - ++ line - ++ ", " - ++ setFGColorVivid Ansi.Blue - ++ (c_label $ s_config s) - ++ fReset + <> t "╰─ … " + <> line + <> t ", " + <> setFGColorVivid Ansi.Blue + <> (c_label $ s_config s) + <> fReset ) quoteIfSpaces :: String -> String @@ -575,11 +577,11 @@ main = B.mainFromCmdParser $ do pure State { s_config = Config { c_label = case label of - [] -> - let full = unwords $ map quoteIfSpaces rest - in if length full < 80 then full else head rest - [labelStr] -> labelStr - _ -> error "too many labels!" + [] -> + let full = unwords $ map quoteIfSpaces rest + in t $ if length full < 80 then full else head rest + [labelStr] -> t labelStr + _ -> error "too many labels!" , c_lines = adjustedNumLines , c_keepStdout = if | stdoutCheckCount > 1 -> error @@ -597,9 +599,9 @@ main = B.mainFromCmdParser $ do | conflateStderr || conflateBoth -> Conflate | dropStderr || dropBoth -> Drop | otherwise -> Keep - , c_summarize = (yield <&> \x -> (JoinYield, x)) - ++ (summarize <&> \x -> (JoinSpecific, x)) - ++ (skip <&> \x -> (JoinAll, x)) + , c_summarize = (yield <&> \x -> (JoinYield, t x)) + ++ (summarize <&> \x -> (JoinSpecific, t x)) + ++ (skip <&> \x -> (JoinAll, t x)) , c_outFile = Nothing , c_errFile = Nothing , c_sectionChar = Nothing -- if section then Just '#' else Nothing @@ -627,12 +629,12 @@ main = B.mainFromCmdParser $ do go in go let outHandler out = forever $ do - x <- filter (/= '\r') <$> System.IO.hGetLine out - fst teeHandles `forM_` \h -> System.IO.hPutStrLn h x + x <- Text.filter (/= '\r') <$> Text.IO.hGetLine out + fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h x modifyMVar_ stateVar (processLine (StdOut, x)) let errHandler err = forever $ do - x <- filter (/= '\r') <$> System.IO.hGetLine err - snd teeHandles `forM_` \h -> System.IO.hPutStrLn h x + x <- Text.filter (/= '\r') <$> Text.IO.hGetLine err + snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h x modifyMVar_ stateVar (processLine (StdErr, x)) let tickHandler = forever $ do threadDelay 333333 @@ -684,14 +686,14 @@ main = B.mainFromCmdParser $ do s_regions finalState `forM_` \r -> closeConsoleRegion r let prefix = fGrey - ++ line - ++ ", " - ++ setFGColorVivid Ansi.Blue - ++ (c_label $ s_config finalState) - ++ fGrey + <> line + <> t ", " + <> setFGColorVivid Ansi.Blue + <> (c_label $ s_config finalState) + <> fGrey let lastLine = case ecMay of - Nothing -> prefix ++ ", UserInterrupt\n" ++ fReset - Just ec -> prefix ++ ", ec=" ++ showEC ec ++ "\n" + Nothing -> prefix <> t ", UserInterrupt\n" <> fReset + Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n" pure (lastLine, ecMay) flushConcurrentOutput diff --git a/src-hxbrief/Util.hs b/src-hxbrief/Util.hs index 67aad46..4c99422 100644 --- a/src-hxbrief/Util.hs +++ b/src-hxbrief/Util.hs @@ -3,6 +3,8 @@ module Util where +import Data.Text ( Text ) +import qualified Data.Text as Text import qualified System.Console.ANSI as Ansi import System.Exit ( ExitCode ( ExitFailure @@ -11,27 +13,32 @@ import System.Exit ( ExitCode ) +t :: String -> Text +t = Text.pack -fGrey :: String -fGrey = Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.White] -fWhite :: String -fWhite = Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.White] -fWhiteDis :: String -fWhiteDis = "" -fRedDis :: String -fRedDis = "" -- TODO disabled until the bug is fixed. +fGrey :: Text +fGrey = + t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.White] +fWhite :: Text +fWhite = + t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.White] +fWhiteDis :: Text +fWhiteDis = t "" +fRedDis :: Text +fRedDis = t "" -- TODO disabled until the bug is fixed. -- setFGColorDull Ansi.Red -fReset :: String -fReset = Ansi.setSGRCode [Ansi.Reset] +fReset :: Text +fReset = t $ Ansi.setSGRCode [Ansi.Reset] -setFGColorVivid :: Ansi.Color -> String +setFGColorVivid :: Ansi.Color -> Text setFGColorVivid c = - Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid c] -setFGColorDull :: Ansi.Color -> String -setFGColorDull c = Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull c] + t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid c] +setFGColorDull :: Ansi.Color -> Text +setFGColorDull c = + t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull c] -showEC :: ExitCode -> String +showEC :: ExitCode -> Text showEC = \case - ExitSuccess -> setFGColorVivid Ansi.Green ++ "0" ++ fReset - ExitFailure i -> setFGColorVivid Ansi.Red ++ show i ++ fReset + ExitSuccess -> setFGColorVivid Ansi.Green <> t "0" <> fReset + ExitFailure i -> setFGColorVivid Ansi.Red <> t (show i) <> fReset