hexagoxel
/
hxtools
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Refactor from String to Text

master
Lennart Spitzner 2022-12-07 16:46:58 +01:00
parent 118b8ddef2
commit c3cc2e8170
3 changed files with 192 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hxtools.cabal
View File

@ -33,7 +33,8 @@ executable hxbrief
async >=2.2.3 && <2.3, async >=2.2.3 && <2.3,
transformers >=0.5.6.2 &&<0.6, transformers >=0.5.6.2 &&<0.6,
clock >=0.8 &&<0.9, 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 hs-source-dirs: src-hxbrief
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -rtsopts -threaded -Wall ghc-options: -rtsopts -threaded -Wall

330
src-hxbrief/Main.hs
View File

@ -45,6 +45,9 @@ import Data.List ( isInfixOf
import Data.Maybe ( listToMaybe import Data.Maybe ( listToMaybe
, mapMaybe , 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 qualified GHC.IO.Encoding
import Lens.Micro ( (<&>) ) import Lens.Micro ( (<&>) )
import System.Clock ( Clock(RealtimeCoarse) import System.Clock ( Clock(RealtimeCoarse)
@ -95,7 +98,7 @@ data JoinedInfo
= JoinedNot -- Line did not match any pattern = JoinedNot -- Line did not match any pattern
| JoinedYield -- Line matched a yield pattern, must be forwarded as-is | JoinedYield -- Line matched a yield pattern, must be forwarded as-is
| JoinedAll Int | JoinedAll Int
| Joined Int String [String] -- pattern, prefix | Joined Int Text [Text] -- pattern, prefix
data KeepMode data KeepMode
= Drop -- dont forward = Drop -- dont forward
@ -104,11 +107,11 @@ data KeepMode
deriving (Eq, Show) deriving (Eq, Show)
data Config = Config data Config = Config
{ c_label :: String { c_label :: Text
, c_lines :: Int , c_lines :: Int
, c_keepStdout :: KeepMode , c_keepStdout :: KeepMode
, c_keepStderr :: KeepMode , c_keepStderr :: KeepMode
, c_summarize :: [(JoinMode, String)] , c_summarize :: [(JoinMode, Text)]
, c_outFile :: Maybe Handle , c_outFile :: Maybe Handle
, c_errFile :: Maybe Handle , c_errFile :: Maybe Handle
, c_sectionChar :: Maybe Char , c_sectionChar :: Maybe Char
@ -118,13 +121,13 @@ data Config = Config
data State = State data State = State
{ s_config :: Config { s_config :: Config
, s_regions :: [ConsoleRegion] , s_regions :: [ConsoleRegion]
, s_history :: [(StreamKind, String)] , s_history :: [(StreamKind, Text)]
, s_lines :: [(StreamKind, String)] , s_lines :: [(StreamKind, Text)]
, s_countOut :: Int , s_countOut :: Int
, s_countErr :: Int , s_countErr :: Int
, s_globalStart :: TimeSpec , s_globalStart :: TimeSpec
, s_lastLineTime :: 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 stateLine updateCur showCur = do
(diffFloat1, diffFloat2) <- getTimeDiff updateCur (diffFloat1, diffFloat2) <- getTimeDiff updateCur
s <- get s <- get
let outStr = if showCur && diffFloat2 > 1.0 let outStr = if showCur && diffFloat2 > 1.0
then printf then t $ printf
"waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr" "waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr"
diffFloat2 diffFloat2
diffFloat1 diffFloat1
(s_countOut s) (s_countOut s)
(s_countErr s) (s_countErr s)
else printf "%0.3fs total, %i lines stdout %i lines stderr" else t $ printf "%0.3fs total, %i lines stdout %i lines stderr"
diffFloat1 diffFloat1
(s_countOut s) (s_countOut s)
(s_countErr s) (s_countErr s)
pure $ outStr pure $ outStr
firstJust :: (a -> Maybe b) -> [a] -> Maybe b firstJust :: (a -> Maybe b) -> [a] -> Maybe b
firstJust f = listToMaybe . mapMaybe f firstJust f = listToMaybe . mapMaybe f
matchPattern :: String -> String -> Bool matchPattern :: Text -> Text -> Bool
matchPattern pat s = case break (== '*') pat of matchPattern pat s = case Text.split (== '*') pat of
("", "*" ) -> True [] -> False
("", '*' : rest) -> case break (== '*') rest of [exact] -> exact == s
(start, "*") -> start `isInfixOf` s [t1, t2] | Text.null t1 -> t2 `Text.isSuffixOf` s -- *foo
(_ , "" ) -> rest `isSuffixOf` s [t1, t2] | Text.null t2 -> t1 `Text.isPrefixOf` s -- foo*
_ -> error $ "too many globs in pattern " ++ pat ++ "!" [t1, t2] -> t1 `Text.isPrefixOf` s && t2 `Text.isSuffixOf` s -- foo*bar
(start, '*' : rest) -> if any (== '*') rest [t1, t2, t3] | Text.null t1 && Text.null t3 -> t2 `Text.isInfixOf` s -- *foo*
then error "only one glob supported in patterns!" _ -> undefined
else start `isPrefixOf` s && rest `isSuffixOf` s
("" , "") -> error "empty pattern"
(exact, "") -> exact == s
_ -> undefined
dispatchLine :: (StreamKind, String) -> StateT State IO () dispatchLine :: (StreamKind, Text) -> StateT State IO ()
dispatchLine line@(kind, str) = do dispatchLine line@(kind, str) = do
conf <- gets s_config conf <- gets s_config
liftIO $ case kind of liftIO $ case kind of
StdOut -> when (c_keepStdout conf /= Drop) StdOut -> when (c_keepStdout conf /= Drop)
$ outputConcurrent (fReset ++ str ++ "\n") $ outputConcurrent (fReset <> str <> t "\n")
StdErr -> StdErr -> when (c_keepStderr conf /= Drop)
when (c_keepStderr conf /= Drop) $ errorConcurrent (fReset ++ str ++ "\n") $ errorConcurrent (fReset <> str <> t "\n")
modify $ \s -> s { s_history = line : s_history s } 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 dispatchYielded line@(kind, str) = do
liftIO $ case kind of liftIO $ case kind of
StdOut -> outputConcurrent (fReset ++ str ++ "\n") StdOut -> outputConcurrent (fReset <> str <> t "\n")
StdErr -> errorConcurrent (fReset ++ str ++ "\n") StdErr -> errorConcurrent (fReset <> str <> t "\n")
modify $ \s -> s { s_history = line : s_history s } modify $ \s -> s { s_history = line : s_history s }
showPattern :: String -> String showPattern :: Text -> Text
showPattern p = p >>= \case showPattern = Text.concatMap
'*' -> setFGColorVivid Ansi.Yellow ++ "…" ++ fReset (\case
x -> [x] '*' -> 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 dispatchPat oldKind i pat prefix = do
let kindStr = case oldKind of let kindStr = case oldKind of
StdOut -> "stdout" StdOut -> t "stdout"
StdErr -> "stderr" StdErr -> t "stderr"
let betterName = let betterName =
let a = unwords prefix let a = Text.unwords prefix
la = length a la = Text.length a
in if in if
| i == 1 && la < 70 | i == 1 && la < 70
-> a -> a
| la > length pat && la < 70 | la > Text.length pat && la < 70
-> a ++ setFGColorVivid Ansi.Yellow ++ " …" ++ fReset -> a <> setFGColorVivid Ansi.Yellow <> t " …" <> fReset
| otherwise | otherwise
-> showPattern pat -> showPattern pat
let prettyPat = let prettyPat =
fGrey fGrey
++ "(" <> t "("
++ show i <> t (show i)
++ " lines " <> t " lines "
++ kindStr <> kindStr
++ ")" <> t ")"
++ fReset <> fReset
++ " " <> t " "
++ betterName <> betterName
++ "\n" <> t "\n"
conf <- gets s_config conf <- gets s_config
liftIO $ case oldKind of liftIO $ case oldKind of
StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat 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 :: StreamKind -> Int -> StateT State IO ()
dispatchSkipped oldKind i = do dispatchSkipped oldKind i = do
let kindStr = case oldKind of let kindStr = case oldKind of
StdOut -> "stdout" StdOut -> t "stdout"
StdErr -> "stderr" StdErr -> t "stderr"
let prettyPat = let prettyPat :: Text =
fGrey fGrey
++ "(" <> t "("
++ show i <> t (show i)
++ " lines " <> t " lines "
++ kindStr <> kindStr
++ ") …skipped…" <> t ") …skipped…"
++ fReset <> fReset
++ "\n" <> t "\n"
conf <- gets s_config conf <- gets s_config
liftIO $ case oldKind of liftIO $ case oldKind of
StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat StdOut -> when (c_keepStdout conf /= Drop) $ outputConcurrent prettyPat
StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent 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 summarizeLines cur@(kind, line) = do
s <- get s <- get
let conf = s_config s let conf = s_config s
@ -257,31 +258,31 @@ summarizeLines cur@(kind, line) = do
if matchPattern pat line then Just joiner else Nothing if matchPattern pat line then Just joiner else Nothing
) )
(c_summarize conf ++ case kind of (c_summarize conf ++ case kind of
StdOut -> [ (JoinAll, "*") | c_keepStdout conf == Conflate ] StdOut -> [ (JoinAll, t "*") | c_keepStdout conf == Conflate ]
StdErr -> [ (JoinAll, "*") | c_keepStderr conf == Conflate ] StdErr -> [ (JoinAll, t "*") | c_keepStderr conf == Conflate ]
) )
case (s_summary s, match) of case (s_summary s, match) of
(Nothing, _) -> put s (Nothing, _) -> put s
{ s_summary = Just { s_summary = Just
( cur ( cur
, case match of , case match of
Nothing -> JoinedNot Nothing -> JoinedNot
Just (JoinYield , _ ) -> JoinedYield Just (JoinYield , _ ) -> JoinedYield
Just (JoinAll , _ ) -> JoinedAll 1 Just (JoinAll , _ ) -> JoinedAll 1
Just (JoinSpecific, pat) -> Joined 1 pat (words line) Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
) )
} }
(Just (oldLine, JoinedNot), _) -> do (Just (oldLine, JoinedNot), _) -> do
dispatchLine oldLine dispatchLine oldLine
put s put s
{ s_summary = Just { s_summary = Just
( cur ( cur
, case match of , case match of
Nothing -> JoinedNot Nothing -> JoinedNot
Just (JoinYield , _ ) -> JoinedYield Just (JoinYield , _ ) -> JoinedYield
Just (JoinAll , _ ) -> JoinedAll 1 Just (JoinAll , _ ) -> JoinedAll 1
Just (JoinSpecific, pat) -> Joined 1 pat (words line) Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
) )
} }
(Just (oldLine, JoinedYield), Nothing) -> do (Just (oldLine, JoinedYield), Nothing) -> do
dispatchYielded oldLine dispatchYielded oldLine
@ -290,13 +291,13 @@ summarizeLines cur@(kind, line) = do
dispatchYielded oldLine dispatchYielded oldLine
put s put s
{ s_summary = Just { s_summary = Just
( cur ( cur
, case match of , case match of
Nothing -> JoinedNot Nothing -> JoinedNot
Just (JoinAll , _ ) -> JoinedAll 1 Just (JoinAll , _ ) -> JoinedAll 1
Just (JoinSpecific, pat) -> Joined 1 pat (words line) Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
Just (JoinYield , _ ) -> JoinedYield Just (JoinYield , _ ) -> JoinedYield
) )
} }
(Just ((oldKind, _), JoinedAll i), Nothing) -> do (Just ((oldKind, _), JoinedAll i), Nothing) -> do
dispatchSkipped oldKind i dispatchSkipped oldKind i
@ -316,7 +317,7 @@ summarizeLines cur@(kind, line) = do
put s { s_summary = Just (cur, JoinedAll 1) } put s { s_summary = Just (cur, JoinedAll 1) }
(JoinSpecific, pat) -> do (JoinSpecific, pat) -> do
dispatchSkipped oldKind i 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) -> (Just ((oldKind, _), Joined i oldPat oldPrefix), Just joiner) ->
case joiner of case joiner of
(JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do (JoinSpecific, pat) | oldPat == pat && kind == oldKind -> do
@ -324,22 +325,22 @@ summarizeLines cur@(kind, line) = do
let go [] = [] let go [] = []
go ((a, b) : rest) | a == b = a : go rest go ((a, b) : rest) | a == b = a : go rest
| otherwise = [] | 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) } put s { s_summary = Just (cur, Joined (i + 1) pat newPrefix) }
_ -> do _ -> do
dispatchPat oldKind i oldPat oldPrefix dispatchPat oldKind i oldPat oldPrefix
put s put s
{ s_summary = Just { s_summary = Just
( cur ( cur
, case joiner of , case joiner of
(JoinYield , _ ) -> JoinedYield (JoinYield , _ ) -> JoinedYield
(JoinAll , _ ) -> JoinedAll 1 (JoinAll , _ ) -> JoinedAll 1
(JoinSpecific, pat) -> Joined 1 pat (words line) (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 processLine newPair@(kind, _) = execStateT $ do
conf <- gets s_config conf <- gets s_config
modify $ \s -> s { s_lines = newPair : s_lines s } 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 } StdErr -> modify $ \s -> s { s_countErr = s_countErr s + 1 }
curLines <- gets s_lines curLines <- gets s_lines
prettyLinesWithSummary <- do prettyLinesWithSummary <- do
let ellipse = let ellipse :: Text -> Text
let go _ "" = "" ellipse input =
go 0 _ = "…" let inputLength = Text.length input
go n (x : xs) = x : go (n - 1) xs
in case c_termSize conf of in case c_termSize conf of
Nothing -> id Nothing -> input
Just (_, w) -> go (w - 3) Just (_, w) -> if inputLength <= w - 2
then input
else Text.take (w - 3) input <> t "…"
let prettyLines = reverse $ take (c_lines conf) curLines <&> \case let prettyLines = reverse $ take (c_lines conf) curLines <&> \case
(StdOut, line) -> fWhiteDis ++ "│ " ++ fReset ++ ellipse line (StdOut, line) -> fWhiteDis <> t "│ " <> fReset <> ellipse line
(StdErr, line) -> fRedDis ++ "│ " ++ fReset ++ ellipse line (StdErr, line) -> fRedDis <> t "│ " <> fReset <> ellipse line
summary <- gets s_summary summary <- gets s_summary
pure $ case summary of pure $ case summary of
Nothing -> prettyLines Nothing -> prettyLines
Just ((StdOut, line), JoinedNot) -> Just ((StdOut, line), JoinedNot) ->
(fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdOut, line), JoinedAll 1) -> Just ((StdOut, line), JoinedAll 1) ->
(fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdOut, _line), JoinedAll i) -> Just ((StdOut, _line), JoinedAll i) ->
( fWhiteDis ( fWhiteDis
++ "│ " <> t "│ "
++ fGrey <> fGrey
++ "…skipped… (" <> t "…skipped… ("
++ show i <> t (show i)
++ " lines)" <> t " lines)"
++ fReset <> fReset
) )
: prettyLines : prettyLines
Just ((StdOut, line), Joined 1 _ _) -> Just ((StdOut, line), Joined 1 _ _) ->
(fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdOut, _), Joined i pat _) -> Just ((StdOut, _), Joined i pat _) ->
( fWhiteDis ( fWhiteDis
++ "│ " <> t "│ "
++ fReset <> fReset
++ showPattern pat <> showPattern pat
++ fGrey <> fGrey
++ " (" <> t " ("
++ show i <> t (show i)
++ " lines)" <> t " lines)"
++ fReset <> fReset
) )
: prettyLines : prettyLines
Just ((StdOut, line), JoinedYield) -> Just ((StdOut, line), JoinedYield) ->
(fWhiteDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdErr, line), JoinedNot) -> Just ((StdErr, line), JoinedNot) ->
(fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdErr, line), JoinedYield) -> Just ((StdErr, line), JoinedYield) ->
(fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdErr, line), JoinedAll 1) -> Just ((StdErr, line), JoinedAll 1) ->
(fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdErr, _line), JoinedAll i) -> Just ((StdErr, _line), JoinedAll i) ->
( fRedDis ( fRedDis
++ "│ " <> t "│ "
++ fGrey <> fGrey
++ "…skipped… (" <> t "…skipped… ("
++ show i <> t (show i)
++ " lines)" <> t " lines)"
++ fReset <> fReset
) )
: prettyLines : prettyLines
Just ((StdErr, line), Joined 1 _ _) -> Just ((StdErr, line), Joined 1 _ _) ->
(fRedDis ++ "│ " ++ fReset ++ ellipse line) : prettyLines (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
Just ((StdErr, _), Joined i pat _) -> Just ((StdErr, _), Joined i pat _) ->
( fRedDis ( fRedDis
++ "│ " <> t "│ "
++ fReset <> fReset
++ showPattern pat <> showPattern pat
++ fGrey <> fGrey
++ " (" <> t " ("
++ show i <> t (show i)
++ " lines)" <> t " lines)"
++ fReset <> fReset
) )
: prettyLines : prettyLines
let showCount = min (c_lines conf) (length prettyLinesWithSummary) let showCount = min (c_lines conf) (length prettyLinesWithSummary)
@ -450,12 +452,12 @@ updateStateLine updateCur = do
liftIO $ setConsoleRegion liftIO $ setConsoleRegion
(last $ s_regions s) (last $ s_regions s)
( fGrey ( fGrey
++ "╰─ … " <> t "╰─ … "
++ line <> line
++ ", " <> t ", "
++ setFGColorVivid Ansi.Blue <> setFGColorVivid Ansi.Blue
++ (c_label $ s_config s) <> (c_label $ s_config s)
++ fReset <> fReset
) )
quoteIfSpaces :: String -> String quoteIfSpaces :: String -> String
@ -575,11 +577,11 @@ main = B.mainFromCmdParser $ do
pure State pure State
{ s_config = Config { s_config = Config
{ c_label = case label of { c_label = case label of
[] -> [] ->
let full = unwords $ map quoteIfSpaces rest let full = unwords $ map quoteIfSpaces rest
in if length full < 80 then full else head rest in t $ if length full < 80 then full else head rest
[labelStr] -> labelStr [labelStr] -> t labelStr
_ -> error "too many labels!" _ -> error "too many labels!"
, c_lines = adjustedNumLines , c_lines = adjustedNumLines
, c_keepStdout = if , c_keepStdout = if
| stdoutCheckCount > 1 -> error | stdoutCheckCount > 1 -> error
@ -597,9 +599,9 @@ main = B.mainFromCmdParser $ do
| conflateStderr || conflateBoth -> Conflate | conflateStderr || conflateBoth -> Conflate
| dropStderr || dropBoth -> Drop | dropStderr || dropBoth -> Drop
| otherwise -> Keep | otherwise -> Keep
, c_summarize = (yield <&> \x -> (JoinYield, x)) , c_summarize = (yield <&> \x -> (JoinYield, t x))
++ (summarize <&> \x -> (JoinSpecific, x)) ++ (summarize <&> \x -> (JoinSpecific, t x))
++ (skip <&> \x -> (JoinAll, x)) ++ (skip <&> \x -> (JoinAll, t x))
, c_outFile = Nothing , c_outFile = Nothing
, c_errFile = Nothing , c_errFile = Nothing
, c_sectionChar = Nothing -- if section then Just '#' else Nothing , c_sectionChar = Nothing -- if section then Just '#' else Nothing
@ -627,12 +629,12 @@ main = B.mainFromCmdParser $ do
go go
in go in go
let outHandler out = forever $ do let outHandler out = forever $ do
x <- filter (/= '\r') <$> System.IO.hGetLine out x <- Text.filter (/= '\r') <$> Text.IO.hGetLine out
fst teeHandles `forM_` \h -> System.IO.hPutStrLn h x fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h x
modifyMVar_ stateVar (processLine (StdOut, x)) modifyMVar_ stateVar (processLine (StdOut, x))
let errHandler err = forever $ do let errHandler err = forever $ do
x <- filter (/= '\r') <$> System.IO.hGetLine err x <- Text.filter (/= '\r') <$> Text.IO.hGetLine err
snd teeHandles `forM_` \h -> System.IO.hPutStrLn h x snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h x
modifyMVar_ stateVar (processLine (StdErr, x)) modifyMVar_ stateVar (processLine (StdErr, x))
let tickHandler = forever $ do let tickHandler = forever $ do
threadDelay 333333 threadDelay 333333
@ -684,14 +686,14 @@ main = B.mainFromCmdParser $ do
s_regions finalState `forM_` \r -> closeConsoleRegion r s_regions finalState `forM_` \r -> closeConsoleRegion r
let prefix = let prefix =
fGrey fGrey
++ line <> line
++ ", " <> t ", "
++ setFGColorVivid Ansi.Blue <> setFGColorVivid Ansi.Blue
++ (c_label $ s_config finalState) <> (c_label $ s_config finalState)
++ fGrey <> fGrey
let lastLine = case ecMay of let lastLine = case ecMay of
Nothing -> prefix ++ ", UserInterrupt\n" ++ fReset Nothing -> prefix <> t ", UserInterrupt\n" <> fReset
Just ec -> prefix ++ ", ec=" ++ showEC ec ++ "\n" Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n"
pure (lastLine, ecMay) pure (lastLine, ecMay)
flushConcurrentOutput flushConcurrentOutput

41
src-hxbrief/Util.hs
View File

@ -3,6 +3,8 @@
module Util where module Util where
import Data.Text ( Text )
import qualified Data.Text as Text
import qualified System.Console.ANSI as Ansi import qualified System.Console.ANSI as Ansi
import System.Exit ( ExitCode import System.Exit ( ExitCode
( ExitFailure ( ExitFailure
@ -11,27 +13,32 @@ import System.Exit ( ExitCode
) )
t :: String -> Text
t = Text.pack
fGrey :: String fGrey :: Text
fGrey = Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.White] fGrey =
fWhite :: String t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.White]
fWhite = Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.White] fWhite :: Text
fWhiteDis :: String fWhite =
fWhiteDis = "" t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.White]
fRedDis :: String fWhiteDis :: Text
fRedDis = "" -- TODO disabled until the bug is fixed. fWhiteDis = t ""
fRedDis :: Text
fRedDis = t "" -- TODO disabled until the bug is fixed.
-- setFGColorDull Ansi.Red -- setFGColorDull Ansi.Red
fReset :: String fReset :: Text
fReset = Ansi.setSGRCode [Ansi.Reset] fReset = t $ Ansi.setSGRCode [Ansi.Reset]
setFGColorVivid :: Ansi.Color -> String setFGColorVivid :: Ansi.Color -> Text
setFGColorVivid c = setFGColorVivid c =
Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid c] t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Vivid c]
setFGColorDull :: Ansi.Color -> String setFGColorDull :: Ansi.Color -> Text
setFGColorDull c = Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull c] setFGColorDull c =
t $ Ansi.setSGRCode [Ansi.SetColor Ansi.Foreground Ansi.Dull c]
showEC :: ExitCode -> String showEC :: ExitCode -> Text
showEC = \case showEC = \case
ExitSuccess -> setFGColorVivid Ansi.Green ++ "0" ++ fReset ExitSuccess -> setFGColorVivid Ansi.Green <> t "0" <> fReset
ExitFailure i -> setFGColorVivid Ansi.Red ++ show i ++ fReset ExitFailure i -> setFGColorVivid Ansi.Red <> t (show i) <> fReset