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,
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

330
src-hxbrief/Main.hs
View File

@ -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

41
src-hxbrief/Util.hs
View File

@ -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