{-# OPTIONS_GHC -Wno-unused-imports #-}
{-# LANGUAGE MultiWayIf #-}

module Main
  ( main
  )
where


import           Control.Concurrent             ( threadDelay )
import qualified Control.Concurrent.Async      as A
import           Control.Concurrent.MVar
import           Control.Exception              ( AsyncException(UserInterrupt)
                                                , IOException
                                                , bracket
                                                , catch
                                                , mask
                                                , throwIO
                                                , try
                                                )
import           Control.Monad                  ( forM_
                                                , forever
                                                , replicateM
                                                , unless
                                                , when
                                                , zipWithM_
                                                )
import           Control.Monad.IO.Class         ( MonadIO
                                                , liftIO
                                                )
import           Control.Monad.Trans.State.Strict
                                                ( StateT(StateT)
                                                , evalStateT
                                                , execStateT
                                                , get
                                                , gets
                                                , modify
                                                , put
                                                )
import qualified Data.Char                     as Char
import           Data.List                      ( isInfixOf
                                                , isPrefixOf
                                                , isSuffixOf
                                                )
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)
                                                , TimeSpec
                                                , diffTimeSpec
                                                , getTime
                                                , toNanoSecs
                                                )
import qualified System.Console.ANSI           as Ansi
import           System.Console.Concurrent      ( errorConcurrent
                                                , flushConcurrentOutput
                                                , outputConcurrent
                                                , withConcurrentOutput
                                                )
import           System.Console.Regions         ( ConsoleRegion
                                                , RegionLayout(Linear)
                                                , closeConsoleRegion
                                                , displayConsoleRegions
                                                , openConsoleRegion
                                                , setConsoleRegion
                                                )
import qualified System.Environment
import           System.Exit                    ( exitSuccess
                                                , exitWith
                                                )
import           System.IO                      ( Handle
                                                , IOMode(WriteMode)
                                                )
import qualified System.IO
import qualified System.Process                as P
import qualified Text.PrettyPrint.HughesPJ     as PP
import           Text.Printf                    ( printf )
import           Text.Read                      ( readMaybe )
import qualified UI.Butcher.Monadic            as B

import           Util


data StreamKind = StdOut | StdErr
  deriving (Eq, Show)

data JoinMode
  = JoinYield    -- i.e. don't join: We want to yield that exact line
  | JoinAll      -- join with any other JoinAll-tagged lines/patterns
  | JoinSpecific -- join with this pattern only

data JoinedInfo
  = JoinedNot     -- Line did not match any pattern
  | JoinedYield   -- Line matched a yield pattern, must be forwarded as-is
  | JoinedAll Int
  | Joined Int Text [Text] -- pattern, prefix

data KeepMode
  = Drop -- dont forward
  | Keep -- forward each line, apart from summaries
  | Conflate -- summarize non-summarized lines as "*"
  deriving (Eq, Show)

data Config = Config
  { c_label       :: Text
  , c_lines       :: Int
  , c_keepStdout  :: KeepMode
  , c_keepStderr  :: KeepMode
  , c_summarize   :: [(JoinMode, Text)]
  , c_outFile     :: Maybe Handle
  , c_errFile     :: Maybe Handle
  , c_sectionChar :: Maybe Char
  , c_termSize    :: Maybe (Int, Int)
  }

data State = State
  { s_config       :: Config
  , s_regions      :: [ConsoleRegion]
  , s_history      :: [(StreamKind, Text)]
  , s_lines        :: [(StreamKind, Text)]
  , s_countOut     :: Int
  , s_countErr     :: Int
  , s_globalStart  :: TimeSpec
  , s_lastLineTime :: TimeSpec
  , s_summary      :: Maybe ((StreamKind, Text), JoinedInfo)
  }


getTimeDiff :: Bool -> StateT State IO (Float, Float)
getTimeDiff updateCur = do
  now <- liftIO $ getTime RealtimeCoarse
  when updateCur $ modify $ \s -> s { s_lastLineTime = now }
  s <- get
  let diffNanos1 = toNanoSecs $ diffTimeSpec (s_globalStart s) now
  let diffNanos2 = toNanoSecs $ diffTimeSpec (s_lastLineTime s) now
  pure
    ( fromIntegral (diffNanos1 `div` 1000000) / (1000 :: Float)
    , fromIntegral (diffNanos2 `div` 1000000) / (1000 :: Float)
    )


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 t $ printf
          "waiting since %0.0fs … %0.1fs total, %i/%i lines stdout/stderr"
          diffFloat2
          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 :: 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
  liftIO $ case kind of
    StdOut -> when (c_keepStdout conf /= Drop)
      $ 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, Text) -> StateT State IO ()
dispatchYielded line@(kind, str) = do
  liftIO $ case kind of
    StdOut -> outputConcurrent (fReset <> str <> t "\n")
    StdErr -> errorConcurrent (fReset <> str <> t "\n")
  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
  )

dispatchPat :: StreamKind -> Int -> Text -> [Text] -> StateT State IO ()
dispatchPat oldKind i pat prefix = do
  let kindStr = case oldKind of
        StdOut -> t "stdout"
        StdErr -> t "stderr"
  let betterName =
        let a  = Text.unwords prefix
            la = Text.length a
        in  if
              | i == 1 && la < 70
              -> a
              | la > Text.length pat && la < 70
              -> a <> setFGColorVivid Ansi.Yellow <> t " …" <> fReset
              | otherwise
              -> showPattern pat
  let prettyPat =
        fGrey
          <> 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
    StdErr -> when (c_keepStderr conf /= Drop) $ errorConcurrent prettyPat

dispatchSkipped :: StreamKind -> Int -> StateT State IO ()
dispatchSkipped oldKind i = do
  let kindStr = case oldKind of
        StdOut -> t "stdout"
        StdErr -> t "stderr"
  let prettyPat :: Text =
        fGrey
          <> 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, 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 ]
        )
  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 (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 (Text.words line)
          )
        }
    (Just (oldLine, JoinedYield), Nothing) -> do
      dispatchYielded oldLine
      put s { s_summary = Just (cur, JoinedNot) }
    (Just (oldLine, JoinedYield), _) -> do
      dispatchYielded oldLine
      put s
        { s_summary = Just
          ( 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
      put s { s_summary = Just (cur, JoinedNot) }
    (Just ((oldKind, _), Joined i oldPat oldPrefix), Nothing) -> do
      dispatchPat oldKind i oldPat oldPrefix
      put s { s_summary = Just (cur, JoinedNot) }
    (Just ((oldKind, _), JoinedAll i), Just joiner) -> case joiner of
      (JoinYield, _pat) -> do
        dispatchSkipped oldKind i
        put s { s_summary = Just (cur, JoinedYield) }
      (JoinAll, _)
        | kind == oldKind -> do
          put s { s_summary = Just (cur, JoinedAll (i + 1)) }
        | otherwise -> do
          dispatchSkipped oldKind i
          put s { s_summary = Just (cur, JoinedAll 1) }
      (JoinSpecific, pat) -> do
        dispatchSkipped oldKind i
        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
          let newPrefix =
                let go [] = []
                    go ((a, b) : rest) | a == b    = a : go rest
                                       | otherwise = []
                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 (Text.words line)
              )
            }


processLine :: (StreamKind, Text) -> State -> IO State
processLine newPair@(kind, _) = execStateT $ do
  conf <- gets s_config
  modify $ \s -> s { s_lines = newPair : s_lines s }
  do
    s0 <- get
    let (keep, over) = splitAt (c_lines conf - 1) (s_lines s0)
    put s0 { s_lines = keep }
    over `forM_` summarizeLines
  case kind of
    StdOut -> modify $ \s -> s { s_countOut = s_countOut s + 1 }
    StdErr -> modify $ \s -> s { s_countErr = s_countErr s + 1 }
  curLines               <- gets s_lines
  prettyLinesWithSummary <- do
    let ellipse :: Text -> Text
        ellipse input =
          let inputLength = Text.length input
          in  case c_termSize conf of
                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 <> 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 <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdOut, line), JoinedAll 1) ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdOut, _line), JoinedAll i) ->
        (  fWhiteDis
          <> t "│ "
          <> fGrey
          <> t "…skipped… ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      Just ((StdOut, line), Joined 1 _ _) ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdOut, _), Joined i pat _) ->
        (  fWhiteDis
          <> t "│ "
          <> fReset
          <> showPattern pat
          <> fGrey
          <> t " ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      Just ((StdOut, line), JoinedYield) ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdErr, line), JoinedNot) ->
        (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdErr, line), JoinedYield) ->
        (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdErr, line), JoinedAll 1) ->
        (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdErr, _line), JoinedAll i) ->
        (  fRedDis
          <> t "│ "
          <> fGrey
          <> t "…skipped… ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      Just ((StdErr, line), Joined 1 _ _) ->
        (fRedDis <> t "│ " <> fReset <> ellipse line) : prettyLines
      Just ((StdErr, _), Joined i pat _) ->
        (  fRedDis
          <> t "│ "
          <> fReset
          <> showPattern pat
          <> fGrey
          <> t " ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
  let showCount = min (c_lines conf) (length prettyLinesWithSummary)
  do -- make sure we have enough regions allocated
    let need = showCount + 1
    got <- gets (length . s_regions)
    when (need > got) $ do
      new <- liftIO $ replicateM (need - got) (openConsoleRegion Linear)
      modify $ \s -> s { s_regions = s_regions s ++ new }
  do
    regions <- gets s_regions
    liftIO $ zipWithM_
      (\x region -> do
        setConsoleRegion region x
      )
      prettyLinesWithSummary
      (take showCount regions)
  updateStateLine True

updateStateLine :: Bool -> StateT State IO ()
updateStateLine updateCur = do
  line <- stateLine updateCur True
  s    <- get
  liftIO $ setConsoleRegion
    (last $ s_regions s)
    (  fGrey
    <> t "╰─ … "
    <> line
    <> t ", "
    <> setFGColorVivid Ansi.Blue
    <> (c_label $ s_config s)
    <> fReset
    )

quoteIfSpaces :: String -> String
quoteIfSpaces s = if any Char.isSpace s then "\"" ++ s ++ "\"" else s

main :: IO ()
main = B.mainFromCmdParser $ do
  B.reorderStart
  numLines :: Int <- B.addFlagReadParam "n" ["lines"] "LINES" (B.flagDefault 5)
  maxLines        <- B.addSimpleBoolFlag "" ["max-lines"] mempty
  keepStdout      <- B.addSimpleBoolFlag "" ["keep-out"] mempty
  keepStderr      <- B.addSimpleBoolFlag "" ["keep-err"] mempty
  keepBoth        <- B.addSimpleBoolFlag "" ["keep"] mempty
  dropStdout      <- B.addSimpleBoolFlag "" ["drop-out"] mempty
  dropStderr      <- B.addSimpleBoolFlag "" ["drop-err"] mempty
  dropBoth        <- B.addSimpleBoolFlag "" ["drop"] mempty
  conflateStdout  <- B.addSimpleBoolFlag "" ["conflate-out"] mempty
  conflateStderr  <- B.addSimpleBoolFlag "" ["conflate-err"] mempty
  conflateBoth    <- B.addSimpleBoolFlag "" ["conflate"] mempty
  summarize       <- B.addFlagStringParams "s" ["summarize"] "PATTERN" mempty
  skip            <- B.addFlagStringParams "x" ["skip"] "PATTERN" mempty
  label           <- B.addFlagStringParams "" ["label"] "STRING" mempty
  yield           <- B.addFlagStringParams "y" ["yield"] "PATTERN" mempty
  omitSummary     <- B.addSimpleBoolFlag "" ["omit-summary"] mempty
  tee             <- B.addFlagStringParams
    ""
    ["tee"]
    "BASENAMEBASEPATH"
    ( B.flagHelp
    $ PP.text "Write copy of stdout/stderr to BASEPATH.{out/err}.txt"
    )
  teeBoth <- B.addFlagStringParams
    ""
    ["tee-both"]
    "FILENAMEFILEPATH"
    (B.flagHelp $ PP.text "Write copy of stdout and stderr to FILEPATH")
  -- section         <- B.addSimpleBoolFlag "" ["section"] mempty
  B.reorderStop
  rest <- B.addParamRestOfInputRaw "COMMAND" mempty <&> \case
    B.InputString ('-' : '-' : ' ' : r) -> words r
    B.InputString ('-'       : '-' : r) -> words r
    B.InputString (r                  ) -> words r
    B.InputArgs   ("--" : r           ) -> r
    B.InputArgs   r                     -> r
  helpDesc <- B.peekCmdDesc
  B.addCmdImpl $ do
    when (null rest) $ do
      print $ B.ppHelpShallow helpDesc
      exitSuccess
    let (restPath : restArgs) = rest
    recursiveMay <- System.Environment.lookupEnv "IN_HXBRIEF"
    case recursiveMay of
      Just _ -> do
        -- TODO: Arguably, we should do _something_ here, e.g. summarizing
        --       and filtering etc.
        P.callProcess restPath restArgs
        exitSuccess
      Nothing -> pure ()
    let mainBracket = bracket
          (do
            System.IO.hSetEcho System.IO.stdin False
            System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering
            GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8
            case (tee, teeBoth) of
              ([]       , []) -> pure (Nothing, Nothing)
              ([teeName], []) -> do
                h1 <- System.IO.openFile (teeName ++ ".out.txt") WriteMode
                h2 <- System.IO.openFile (teeName ++ ".err.txt") WriteMode
                pure (Just h1, Just h2)
              ([], [teeBothName]) -> do
                h <- System.IO.openFile teeBothName WriteMode
                pure (Just h, Just h)
              _ -> error "too many/conflicting tee arguments!"
          )
          (\teeHandles -> do
            fst teeHandles `forM_` System.IO.hClose
            snd teeHandles `forM_` System.IO.hClose
            -- ^ may be closed already, this is not an error according to docs!
            System.IO.hSetEcho System.IO.stdin True
          )
    withConcurrentOutput $ mainBracket $ \teeHandles -> mask $ \restore -> do
      -- restore $ GHC.IO.Encoding.setFileSystemEncoding GHC.IO.Encoding.utf8
      -- restore $ System.IO.hSetEncoding System.IO.stdout GHC.IO.Encoding.utf8
      -- restore $ System.IO.hSetEncoding System.IO.stderr GHC.IO.Encoding.utf8
      termSizeMay <- restore $ do
        support <- Ansi.hSupportsANSI System.IO.stdin
        if support
          then Ansi.getTerminalSize
          else do
            envLines <- System.Environment.lookupEnv "LINES"
            envCols  <- System.Environment.lookupEnv "COLUMNS"
            pure $ (,) <$> (envLines >>= readMaybe) <*> (envCols >>= readMaybe)
      let stdoutCheckCount =
            length
              $  [ () | keepStdout || keepBoth ]
              ++ [ () | conflateStdout || conflateBoth ]
              ++ [ () | dropStdout || dropBoth ]
      let stderrCheckCount =
            length
              $  [ () | keepStderr || keepBoth ]
              ++ [ () | conflateStderr || conflateBoth ]
              ++ [ () | dropStderr || dropBoth ]
      adjustedNumLines <- case termSizeMay of
        Just (termLines, _) | maxLines -> pure $ max 1 (termLines - 3)
        Just (termLines, _) | termLines < numLines + 3 -> do
          let actual = max 1 (termLines - 3)
          errorConcurrent
            $  "Warning: output is too small, only showing "
            ++ show actual
            ++ " lines!\n"
          pure actual
        _ -> pure numLines
      (lastLine, ecMay) <- displayConsoleRegions $ do
        initialState <- do
          startTime <- getTime RealtimeCoarse
          line0     <- openConsoleRegion Linear
          pure State
            { s_config       = Config
              { c_label       = case label of
                [] ->
                  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
                                    "too many keep/drop/conflate for stdout!"
                                  | keepStdout || keepBoth -> Keep
                                  | conflateStdout || conflateBoth -> Conflate
                                  | dropStdout || dropBoth -> Drop
                                  | otherwise -> if null summarize
                                    then Drop
                                    else Conflate
              , c_keepStderr  = if
                                  | stderrCheckCount > 1 -> error
                                    "too many keep/drop/conflate for stderr!"
                                  | keepStderr || keepBoth -> Keep
                                  | 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_outFile     = Nothing
              , c_errFile     = Nothing
              , c_sectionChar = Nothing -- if section then Just '#' else Nothing
              , c_termSize    = termSizeMay
              }
            , s_regions      = [line0]
            , s_history      = []
            , s_lines        = []
            , s_countOut     = 0
            , s_countErr     = 0
            , s_globalStart  = startTime
            , s_lastLineTime = startTime
            , s_summary      = Nothing
            }
        stateVar :: MVar State <- newMVar initialState

        let inHandler inp =
              let go = do
                    x <- try getLine
                    case x of
                      Left  (_ :: IOException) -> System.IO.hClose inp
                      Right line               -> do
                        System.IO.hPutStrLn inp line
                        System.IO.hFlush inp
                        go
              in  go
        let outHandler out = forever $ do
              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 <- 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
              modifyMVar_ stateVar $ execStateT $ updateStateLine False
        innerEnv <- do
          env <- System.Environment.getEnvironment
          pure (env ++ [("IN_HXBRIEF", "1")])

        let mainBlock =
              P.withCreateProcess
                  ((P.proc restPath restArgs) { P.std_in  = P.CreatePipe
                                              , P.std_out = P.CreatePipe
                                              , P.std_err = P.CreatePipe
                                              , P.env     = Just innerEnv
                                              }
                  )
                $ \(Just inp) (Just out) (Just err) hdl -> do
                    A.withAsync (inHandler inp) $ \inAsync ->
                      A.withAsync (outHandler out) $ \outAsync ->
                        A.withAsync (errHandler err) $ \errAsync ->
                          A.withAsync tickHandler $ \_tickAsync -> do
                            ec <- P.waitForProcess hdl
                            A.cancel inAsync
                            _a <- A.waitCatch outAsync
                            _b <- A.waitCatch errAsync
                            pure (Just ec)
        ecMay <- restore mainBlock `catch` (\UserInterrupt -> pure Nothing)
        modifyMVar_ stateVar $ execStateT $ do
          finalLines <- gets s_lines
          countOut   <- gets s_countOut
          countErr   <- gets s_countErr
          if countOut == 0 && countErr == 1
            then do
              modify
                $ \s -> s { s_config = (s_config s) { c_keepStderr = Keep } }
              reverse finalLines `forM_` dispatchLine
            else do
              -- we leave the lines in final state, but process them
              reverse finalLines `forM_` summarizeLines
              gets s_summary >>= \case
                Nothing                       -> pure ()
                Just (line     , JoinedNot  ) -> dispatchLine line
                Just (line     , JoinedYield) -> dispatchYielded line
                Just ((kind, _), JoinedAll i) -> dispatchSkipped kind i
                Just ((kind, _), Joined i pat prefix) ->
                  dispatchPat kind i pat prefix
        finalState <- takeMVar stateVar
        line       <- evalStateT (stateLine False False) finalState
        s_regions finalState `forM_` \r -> closeConsoleRegion r
        let prefix =
              fGrey
                <> line
                <> t ", "
                <> setFGColorVivid Ansi.Blue
                <> (c_label $ s_config finalState)
                <> fGrey
        let lastLine = case ecMay of
              Nothing -> prefix <> t ", UserInterrupt\n" <> fReset
              Just ec -> prefix <> t ", ec=" <> showEC ec <> t "\n"
        pure (lastLine, ecMay)

      flushConcurrentOutput
      unless omitSummary $ errorConcurrent lastLine
      case ecMay of
        Nothing -> throwIO UserInterrupt -- essentially re-throw
        Just ec -> exitWith ec