{-# 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
                                                , join
                                                , 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 Text.Regex.Base.RegexLike     as Regex
import qualified Text.Regex.PCRE.Text          as PCRE
import qualified UI.Butcher.Monadic            as B

import           Util


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

data JoinMode
  = JoinYield    -- don't join: We want to yield that exact line
  | JoinDrop     -- don't join, and drop the line from the summary
  | JoinAllKeep  -- join with any other JoinAll-tagged lines/patterns, override headers
  | JoinAllDrop  -- join with any other JoinAll-tagged lines/patterns, drop before headers, dont output
  | JoinSpecific -- join with this pattern only
  | JoinHeader1   -- join with nothing, stays, only gets replaced by next yield/header
  | JoinHeader2
  | JoinErrorStart
  | JoinErrorStop

data JoinedInfo
  = JoinedNot Bool -- yield or drop, not to be merged. bool determines whether to forward
  | JoinedHeader TimeSpec Bool (Maybe Text) Int Int -- header, not to be merged. bool determines whether to forward. Int is count stdout/stderr
  | JoinedAll Bool Int -- bool determines whether to forward
  | 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, PCRE.Regex)]
  , c_errorStop   :: [PCRE.Regex]
  , c_outFile     :: Maybe Handle
  , c_errFile     :: Maybe Handle
  , c_sectionChar :: Maybe Char
  , c_termSize    :: Maybe (Int, Int)
  -- We don't need this in the config currently.
  -- , c_filterEscapes :: Bool
  }

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

data Summary
  = SummaryNone
  | SummaryNorm StreamKind Text JoinedInfo
  | SummaryErr StreamKind Text


-- bumpLineTime :: StateT State IO ()
-- bumpLineTime = do
--   now <- liftIO $ getTime RealtimeCoarse
--   modify $ \s -> s { s_lastLineTime = s_nowTime s, s_nowTime = now }

bumpBothTimes :: StateT State IO ()
bumpBothTimes = do
  now <- liftIO $ getTime RealtimeCoarse
  modify $ \s -> s { s_lastLineTime = now, s_nowTime = now }

bumpNowTime :: StateT State IO ()
bumpNowTime = do
  now <- liftIO $ getTime RealtimeCoarse
  modify $ \s -> s { s_nowTime = now }

diffTimes :: TimeSpec -> TimeSpec -> Float
diffTimes a b =
  fromIntegral (toNanoSecs (diffTimeSpec a b) `div` 1000000) / (1000 :: Float)

stateLine :: StateT State IO Text
stateLine = do
  s <- get
  let diffFloat1 = diffTimes (s_globalStart s) (s_nowTime s)
  let diffFloat2 = diffTimes (s_lastLineTime s) (s_nowTime s)
  let outStr = if False && 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

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 p = setFGColorVivid Ansi.Yellow <> p <> fReset

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

showHeader :: Float -> Text -> Maybe Text -> Int -> Int -> Text
showHeader diffTime header mLevel2 countOut countErr =
  header
    <> (maybe (t "") (\l2 -> t " " <> l2) mLevel2)
    <> fGrey
    <> t (printf " (%i/%i lines out/err, %0.1fs)" countOut countErr diffTime)
    <> fReset

dispatchHeader
  :: TimeSpec -> StreamKind -> Int -> Int -> Text -> StateT State IO ()
dispatchHeader startTime oldKind countOut countErr header = do
  now <- gets s_nowTime
  let prettyPat =
        showHeader (diffTimes startTime now) header Nothing countOut countErr
          <> 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

dispatchSummary :: Summary -> StateT State IO ()
dispatchSummary = \case
  SummaryErr kind line -> dispatchYielded (kind, line)
  SummaryNone          -> pure ()
  SummaryNorm kind line (JoinedNot keep) ->
    when keep $ dispatchYielded (kind, line)
  SummaryNorm kind line (JoinedHeader startTime keep _mLevel2 iOut iErr) ->
    when keep $ dispatchHeader startTime kind iOut iErr line
  SummaryNorm kind _ (JoinedAll keep i   ) -> when keep $ dispatchSkipped kind i
  SummaryNorm kind _ (Joined i pat prefix) -> dispatchPat kind i pat prefix

summarizeLines :: (StreamKind, Text, Float) -> StateT State IO ()
summarizeLines (kind, line, _linetime) = do
  s <- get
  let conf = s_config s
  let match :: (JoinMode, Text) =
        case
            ( firstJust
              (\(mode, pat, regex) -> if Regex.matchTest regex line
                then Just (mode, pat)
                else Nothing
              )
              (c_summarize conf)
            , kind
            )
          of
            (Just j , _     ) -> j
            (Nothing, StdOut) -> case c_keepStdout conf of
              Conflate -> (JoinAllKeep, t "*")
              Keep     -> (JoinYield, t "*")
              Drop     -> (JoinDrop, t "*")
            (Nothing, StdErr) -> case c_keepStderr conf of
              Conflate -> (JoinAllKeep, t "*")
              Keep     -> (JoinYield, t "*")
              Drop     -> (JoinDrop, t "*")
  let
    defaultReplace = put s
      { s_summary =
        (case match of
          (JoinYield  , _) -> SummaryNorm kind line (JoinedNot True)
          (JoinAllKeep, _) -> SummaryNorm kind line (JoinedAll True 1)
          (JoinAllDrop, _) -> SummaryNorm kind line (JoinedAll False 1)
          (JoinSpecific, pat) ->
            SummaryNorm kind line (Joined 1 pat (Text.words line))
          (JoinHeader1, _) ->
            SummaryNorm kind line (JoinedHeader (s_nowTime s) False Nothing 0 0)
          (JoinHeader2, _) ->
            SummaryNorm kind line (JoinedHeader (s_nowTime s) False Nothing 0 0)
          (JoinDrop      , _) -> SummaryNorm kind line (JoinedNot False)
          (JoinErrorStart, _) -> SummaryErr kind line
          (JoinErrorStop, _) ->
            error "hxbrief internal error, unexpected JoinErrorStop"
        )
      }
  case (s_summary s, match) of
    (SummaryNone, (JoinErrorStart, _)) -> do
      put s { s_summary = SummaryErr kind line }
    (summary@SummaryNorm{}, (JoinErrorStart, _)) -> do
      dispatchSummary summary
      put s { s_summary = SummaryErr kind line }
    (SummaryErr oldKind oldLine, _) -> do
      dispatchYielded (oldKind, oldLine)
      case
          firstJust
            (\regex -> if Regex.matchTest regex line then Just () else Nothing)
            (c_errorStop conf)
        of
          Just () -> defaultReplace
          Nothing -> do
            put s { s_summary = SummaryErr kind line }
    (SummaryNone, _      ) -> defaultReplace
    -- (Just (oldKind, oldLine, JoinedNot), _) -> do
    --   dispatchLine (oldKind, oldLine)
    --   put s
    --     { s_summary = Just
    --       ( kind
    --       , line
    --       , case match of
    --         Nothing                  -> JoinedNot
    --         Just (JoinYield   , _  ) -> JoinedYield
    --         Just (JoinAllKeep , _  ) -> JoinedAll True 1
    --         Just (JoinAllDrop , _  ) -> JoinedAll False 1
    --         Just (JoinSpecific, pat) -> Joined 1 pat (Text.words line)
    --         Just (JoinHeader  , _  ) -> JoinedHeader
    --       )
    --     }
    (SummaryNorm oldKind oldLine (JoinedNot keep), _joiner) -> do
      when keep $ dispatchYielded (oldKind, oldLine)
      defaultReplace
    (SummaryNorm oldKind oldLine (JoinedHeader startTime keep mLevel2 countOut countErr), joiner)
      -> do
        let
          replaceMay = case joiner of
            (JoinYield   , _pat) -> Just (JoinedNot True)
            (JoinAllKeep , _   ) -> Just (JoinedAll True 1)
            (JoinAllDrop , _   ) -> Nothing
            (JoinSpecific, pat ) -> Just (Joined 1 pat (Text.words line))
            (JoinHeader1, _) ->
              Just (JoinedHeader (s_nowTime s) False Nothing 0 0)
            (JoinHeader2   , _) -> Nothing
            (JoinDrop      , _) -> Nothing
            (JoinErrorStart, _) -> Nothing
            (JoinErrorStop , _) -> Nothing
        case replaceMay of
          Just replace -> do
            when keep
              $ dispatchHeader startTime oldKind countOut countErr oldLine
            put s { s_summary = SummaryNorm kind line replace }
          Nothing -> do
            let newLevel2 = case joiner of
                  (JoinHeader2, _) -> Just line
                  _                -> mLevel2
            put s
              { s_summary = SummaryNorm
                oldKind
                oldLine
                (case kind of
                  StdOut -> JoinedHeader startTime
                                         keep
                                         newLevel2
                                         (countOut + 1)
                                         countErr
                  StdErr -> JoinedHeader startTime
                                         keep
                                         newLevel2
                                         countOut
                                         (countErr + 1)
                )
              }
    (SummaryNorm oldKind _ (JoinedAll keep i), joiner) -> case joiner of
      (JoinAllKeep, _) | kind == oldKind -> do
        put s { s_summary = SummaryNorm kind line (JoinedAll True (i + 1)) }
      (JoinAllDrop, _) | kind == oldKind -> do
        put s { s_summary = SummaryNorm kind line (JoinedAll False (i + 1)) }
      _ -> do
        when keep $ dispatchSkipped oldKind i
        defaultReplace
    (SummaryNorm oldKind _ (Joined i oldPat oldPrefix), 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 = SummaryNorm kind line (Joined (i + 1) pat newPrefix)
            }
        _ -> do
          dispatchPat oldKind i oldPat oldPrefix
          defaultReplace


prettyLine :: Config -> (StreamKind, Text, Float) -> Text
prettyLine conf (kind, line, linetime) =
  let floatright =
        if linetime > 0.2 then t $ printf " (%0.1fs)" linetime else t ""
  in  case kind of
        StdOut ->
          fWhiteDis <> t "│ " <> fReset <> ellipseFloat conf line floatright
        StdErr ->
          fRedDis <> t "│ " <> fReset <> ellipseFloat conf line floatright

ellipseFloat :: Config -> Text -> Text -> Text
ellipseFloat conf start floatright =
  let startLength = Text.length start
      floatLength = Text.length floatright
  in  case c_termSize conf of
        Nothing -> start <> floatright
        Just (_, w) ->
          let space = w - floatLength - 2
          in  if space >= startLength
                then
                  start
                  <> Text.replicate (space - startLength) (t " ")
                  <> floatright
                else Text.take (space - 1) start <> t "…" <> floatright
ellipse :: Config -> Text -> Text
ellipse conf x = ellipseFloat conf x (Text.empty)

processLine :: StreamKind -> Text -> State -> IO State
processLine newKind newLine = execStateT $ do
  conf <- gets s_config
  bumpBothTimes
  modify $ \s -> s { s_lines = (newKind, newLine, 0) : 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 newKind 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 prettyLines =
          reverse $ take (c_lines conf) curLines <&> prettyLine conf

    summary <- gets s_summary
    now     <- gets s_nowTime
    pure $ case summary of
      SummaryNone -> prettyLines
      SummaryNorm StdOut line (JoinedNot _) ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdOut line (JoinedHeader startTime _ mLevel2 countOut countErr)
        -> (fWhiteDis <> t "│ " <> fReset <> ellipse
             conf
             (showHeader (diffTimes startTime now)
                         line
                         mLevel2
                         countOut
                         countErr
             )
           )
          : prettyLines
      SummaryNorm StdOut line (JoinedAll _ 1) ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdOut _line (JoinedAll _ i) ->
        (  fWhiteDis
          <> t "│ "
          <> fGrey
          <> t "…skipped… ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      SummaryNorm StdOut line (Joined 1 _ _) ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdOut _ (Joined i pat _) ->
        (  fWhiteDis
          <> t "│ "
          <> fReset
          <> showPattern pat
          <> fGrey
          <> t " ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      SummaryErr StdOut line ->
        (fWhiteDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdErr line (JoinedNot _) ->
        (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdErr line (JoinedHeader startTime _ mLevel2 countOut countErr)
        -> (fRedDis <> t "│ " <> fReset <> ellipse
             conf
             (showHeader (diffTimes startTime now)
                         line
                         mLevel2
                         countOut
                         countErr
             )
           )
          : prettyLines
      SummaryNorm StdErr line (JoinedAll _ 1) ->
        (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdErr _line (JoinedAll _ i) ->
        (  fRedDis
          <> t "│ "
          <> fGrey
          <> t "…skipped… ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      SummaryNorm StdErr line (Joined 1 _ _) ->
        (fRedDis <> t "│ " <> fReset <> ellipse conf line) : prettyLines
      SummaryNorm StdErr _ (Joined i pat _) ->
        (  fRedDis
          <> t "│ "
          <> fReset
          <> showPattern pat
          <> fGrey
          <> t " ("
          <> t (show i)
          <> t " lines)"
          <> fReset
          )
          : prettyLines
      SummaryErr StdErr line ->
        (fRedDis <> t "│ " <> fReset <> ellipse conf line) : 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

updateLastLine :: StateT State IO ()
updateLastLine = do
  bumpNowTime
  modify $ \s -> s
    { s_lines = case s_lines s of
                  [] -> []

                  ((k, l, _) : rest) ->
                    (k, l, diffTimes (s_lastLineTime s) (s_nowTime s)) : rest
    }
  do
    s <- get
    case (s_lines s, reverse $ s_regions s) of
      (line : _, _ : region : _) -> do
        liftIO $ setConsoleRegion region $ prettyLine (s_config s) line
      _ -> pure ()


updateStateLine :: StateT State IO ()
updateStateLine = do
  line <- stateLine
  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

-- brittany-next-binding --columns 180
main :: IO ()
main = B.mainFromCmdParser $ do
  B.reorderStart
  -- For both stdout and stderr, each line flow through multiple stages.
  -- In the console UI, lines "flow" from bottom of the screen upwards.
  -- Lets image we run over the canonical "fizzbuzz" linewise output:
  -- -- 1, 2, Fizz, 4, Buzz, Fizz, 7, 8, Fizz, Buzz, 11, Fizz, 13, 14, Fizz Buzz, 16, 17, Fizz, 19, Buzz, Fizz, 22, 23, Fizz, Buzz, 26, Fizz, 28, 29, Fizz Buzz, 31, 32, Fizz, 34, Buzz, Fizz, ...
  -- We configure to 2 live lines + summary, summarizing lines that contain
  -- numbers, yielding lines that contain Fizz/Buzz.
  -- Time flows from left to right:
  --   (you can see this live by running:)
  --    > hxbrief --drop --yield "Fizz|Buzz" -s "[0-9]" -n3 -- ./sample-fizzbuzz.sh
  --   t0   t1   t2      t3      t4      t5      t6      t7      t8       Line class
  --                                                             ....     -forwarded-
  --                                                     Fizz    Buzz     -forwarded-
  --                                     Fizz    Fizz    Buzz    Fizz     -forwarded-
  --             | 1     | %d+   | Fizz  | 4     | Buzz  | Fizz  | 7      -summary-
  --        | 1  | 2     | Fizz  | 4     | Buzz  | Fizz  | 7     | 8      -live-
  --   | 1  | 2  | Fizz  | 4     | Buzz  | Fizz  | 7     | 8     | Fizz   -live-
  --
  -- As you can see, lines flow from being the output of our fizzbuzz into our
  -- live display, into the summary, into the forwarded. At each step, we can
  -- filter/merge lines, i.e.
  --
  -- input  -------->  live  -------------->  summary  -------->  forwarded
  --        filter f1        filter/merge f2           filter f3
  --
  -- f1/f2/f3 together determine how far each line "travels". hxbrief allows
  -- configuring a) a default behaviour b) a list of (regex, behaviour) pairs
  -- that control how any particular input line is handled.
  --    behaviour | matching lines ...
  -- 1) discard   | are filtered out at f1. All other pass f1.
  -- 2) drop      | are filtered out at f2.
  -- 3) conflate  | combine with any other lines with this behaviour
  -- 4) group     | combine with lines that matched the same pattern, get filtered at f3
  -- 5) summary   | combine with lines that matched the same pattern, pass f3
  -- 6) header    | always replace the current summary, get filtered out at f3
  -- 7) yield     | always replace the current summary, pass f3





  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-all"] mempty
  dropStdout      <- B.addSimpleBoolFlag "" ["drop-out"] mempty
  dropStderr      <- B.addSimpleBoolFlag "" ["drop-err"] mempty
  dropBoth        <- B.addSimpleBoolFlag "" ["drop-all"] mempty
  conflateStdout  <- B.addSimpleBoolFlag "" ["conflate-out"] mempty
  conflateStderr  <- B.addSimpleBoolFlag "" ["conflate-err"] mempty
  conflateBoth    <- B.addSimpleBoolFlag "" ["conflate-all"] mempty
  summarize       <- B.addFlagStringParams "s" ["summarize"] "REGEX" (B.flagHelpStr "bundle lines starting with this pattern into one line")
  summarizeFull   <- B.addFlagStringParams "" ["summarize-any"] "REGEX" (B.flagHelpStr "bundle lines containing this pattern into one line")
  dropArg         <- B.addFlagStringParams "x" ["drop"] "REGEX" (B.flagHelpStr "drop lines starting with this pattern, similar to `grep -v`")
  dropFull        <- B.addFlagStringParams "" ["drop-any"] "REGEX" (B.flagHelpStr "drop lines containing this pattern, similar to `grep -v`")
  label           <- B.addFlagStringParams "" ["label"] "STRING" mempty
  yield           <- B.addFlagStringParams "y" ["yield"] "REGEX" (B.flagHelpStr "always fully retain lines starting with this pattern, disregarding skip/summarize")
  yieldFull       <- B.addFlagStringParams "" ["yield-any"] "REGEX" (B.flagHelpStr "always fully retain lines containing this pattern, disregarding skip/summarize")
  header          <- B.addFlagStringParams "h" ["header"] "REGEX" (B.flagHelpStr "starting with this pattern: always replaces summary, then gets dropped")
  headerFull      <- B.addFlagStringParams "" ["header-any"] "REGEX" (B.flagHelpStr "containing this pattern: always replaces summary, then gets dropped")
  header2         <- B.addFlagStringParams "" ["header2"] "REGEX" (B.flagHelpStr "starting with this pattern: always replaces summary, then gets dropped")
  header2Full     <- B.addFlagStringParams "" ["header2-any"] "REGEX" (B.flagHelpStr "containing this pattern: always replaces summary, then gets dropped")
  errorStart      <- B.addFlagStringParams "" ["error-start"] "REGEX" mempty
  errorStartFull  <- B.addFlagStringParams "" ["error-start-any"] "REGEX" mempty
  errorStop       <- B.addFlagStringParams "" ["error-stop"] "REGEX" mempty
  errorStopFull   <- B.addFlagStringParams "" ["error-stop-any"] "REGEX" 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")
  filterEscapes   <- B.addSimpleBoolFlag "" ["filter-escape-sequences"] (B.flagHelpStr "filter console escape-sequences from process output. Slower, but prevents glitches.")
  -- 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
      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)
          compilerStop 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 regex
      compiled_summarize <-
        sequence
        $ join
        $ [ yield <&> compiler JoinYield . (\x -> "^(" ++ x ++ ")")
          , yieldFull <&> compiler JoinYield
          , summarize <&> compiler JoinSpecific . (\x -> "^(" ++ x ++ ")")
          , summarizeFull <&> compiler JoinSpecific
          , header <&> compiler JoinHeader1 . (\x -> "^(" ++ x ++ ")")
          , headerFull <&> compiler JoinHeader1
          , header2 <&> compiler JoinHeader2 . (\x -> "^(" ++ x ++ ")")
          , header2Full <&> compiler JoinHeader2
          , dropArg <&> compiler JoinAllDrop . (\x -> "^(" ++ x ++ ")")
          , dropFull <&> compiler JoinAllDrop
          , errorStart <&> compiler JoinErrorStart . (\x -> "^(" ++ x ++ ")")
          , errorStartFull <&> compiler JoinErrorStart
          ]
      compiled_errorStop <- sequence $ join [errorStop <&> compilerStop . (\x -> "^(" ++ x ++ ")"), errorStopFull <&> compilerStop]
      (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                      -> Keep
                                 , 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   = compiled_summarize
                                 , c_errorStop   = compiled_errorStop
                                 , 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_nowTime      = startTime
            , s_summary      = SummaryNone
            }
        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
              rawLine <- Text.IO.hGetLine out
              let line = if filterEscapes then filterEscapeFunc rawLine else Text.filter (/= '\r') rawLine
              fst teeHandles `forM_` \h -> Text.IO.hPutStrLn h line
              modifyMVar_ stateVar (processLine StdOut line)
        let errHandler err = forever $ do
              rawLine <- Text.IO.hGetLine err
              let line = if filterEscapes then filterEscapeFunc rawLine else Text.filter (/= '\r') rawLine
              snd teeHandles `forM_` \h -> Text.IO.hPutStrLn h line
              modifyMVar_ stateVar (processLine StdErr line)
        let tickHandler = forever $ do
              threadDelay 333333
              modifyMVar_ stateVar $ execStateT $ updateLastLine >> updateStateLine
        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_` \(kind, line, _) -> dispatchLine (kind, line)
            else do
              -- we leave the lines in final state, but process them
              reverse finalLines `forM_` summarizeLines
              gets s_summary >>= dispatchSummary
        finalState <- takeMVar stateVar
        line       <- evalStateT (bumpNowTime >> stateLine) 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