diff options
| -rw-r--r-- | minici.cabal | 1 | ||||
| -rw-r--r-- | src/Command.hs | 18 | ||||
| -rw-r--r-- | src/Command/Run.hs | 48 | ||||
| -rw-r--r-- | src/Main.hs | 8 | ||||
| -rw-r--r-- | src/Terminal.hs | 45 |
5 files changed, 94 insertions, 26 deletions
diff --git a/minici.cabal b/minici.cabal index 7f20ac1..6b298f6 100644 --- a/minici.cabal +++ b/minici.cabal @@ -54,6 +54,7 @@ executable minici Job.Types Paths_minici Repo + Terminal Version Version.Git autogen-modules: diff --git a/src/Command.hs b/src/Command.hs index 2c2235f..c602ba8 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -6,8 +6,10 @@ module Command ( CommandArgumentsType(..), CommandExec(..), + CommandInput(..), getCommonOptions, getConfig, + getTerminalOutput, ) where import Control.Monad.Except @@ -20,6 +22,7 @@ import Data.Text qualified as T import System.Console.GetOpt import Config +import Terminal data CommonOptions = CommonOptions { optJobs :: Int @@ -67,11 +70,20 @@ instance CommandArgumentsType (Maybe Text) where argsFromStrings _ = throwError "expected at most one argument" -newtype CommandExec a = CommandExec (ReaderT ( CommonOptions, Config ) IO a) +newtype CommandExec a = CommandExec (ReaderT CommandInput IO a) deriving (Functor, Applicative, Monad, MonadIO) +data CommandInput = CommandInput + { ciOptions :: CommonOptions + , ciConfig :: Config + , ciTerminalOutput :: TerminalOutput + } + getCommonOptions :: CommandExec CommonOptions -getCommonOptions = CommandExec (asks fst) +getCommonOptions = CommandExec (asks ciOptions) getConfig :: CommandExec Config -getConfig = CommandExec (asks snd) +getConfig = CommandExec (asks ciConfig) + +getTerminalOutput :: CommandExec TerminalOutput +getTerminalOutput = CommandExec (asks ciTerminalOutput) diff --git a/src/Command/Run.hs b/src/Command/Run.hs index a2436c8..7c169b2 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -11,16 +11,16 @@ import Data.List import Data.Maybe import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import System.Exit -import System.IO import System.Process import Command import Config import Job import Repo +import Terminal + data RunCommand = RunCommand Text @@ -56,6 +56,7 @@ cmdRun (RunCommand changeset) = do return ( base, tip ) [] -> error "splitOn should not return empty list" + tout <- getTerminalOutput liftIO $ do mngr <- newJobManager optJobs Just repo <- openRepo "." @@ -63,12 +64,11 @@ cmdRun (RunCommand changeset) = do jobssets <- mapM loadJobSetForCommit commits let names = nub $ map jobName $ concatMap jobsetJobs jobssets - putStr $ replicate (8 + 50) ' ' - forM_ names $ \name -> do - T.putStr $ (" "<>) $ fitToLength 7 $ textJobName name - putStrLn "" + void $ newLine tout $ T.concat $ + T.replicate (8 + 50) " " : + map ((" "<>) . fitToLength 7 . textJobName) names - forM_ jobssets $ \jobset -> do + statuses <- forM jobssets $ \jobset -> do let commit = jobsetCommit jobset shortCid = T.pack $ take 7 $ showCommitId $ commitId commit shortDesc = fitToLength 50 (commitDescription commit) @@ -76,10 +76,17 @@ cmdRun (RunCommand changeset) = do Right jobs -> do outs <- runJobs mngr "./.minici" commit jobs let findJob name = snd <$> find ((name ==) . jobName . fst) outs - displayStatusLine shortCid (" " <> shortDesc) $ map findJob names + displayStatusLine tout shortCid (" " <> shortDesc) $ map findJob names + return $ map snd outs Left err -> do - T.putStrLn $ "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m" - hFlush stdout + void $ newLine tout $ + "\ESC[91m" <> shortCid <> "\ESC[0m" <> " " <> shortDesc <> " \ESC[91m" <> T.pack err <> "\ESC[0m" + return [] + + -- wait for all jobs to complete + atomically $ forM_ (concat statuses) $ \tvar -> do + status <- readTVar tvar + when (not $ jobStatusFinished status) retry fitToLength :: Int -> Text -> Text @@ -97,29 +104,30 @@ showStatus blink = \case JobFailed -> "\ESC[91m✗\ESC[0m " JobDone _ -> "\ESC[92m✓\ESC[0m " -displayStatusLine :: Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO () -displayStatusLine prefix1 prefix2 statuses = do +displayStatusLine :: TerminalOutput -> Text -> Text -> [ Maybe (TVar (JobStatus JobOutput)) ] -> IO () +displayStatusLine tout prefix1 prefix2 statuses = do blinkVar <- newTVarIO False t <- forkIO $ forever $ do threadDelay 500000 atomically $ writeTVar blinkVar . not =<< readTVar blinkVar - go blinkVar "\0" - killThread t + line <- newLine tout "" + void $ forkIO $ do + go line blinkVar "\0" + killThread t where - go blinkVar prev = do + go line blinkVar prev = do (ss, cur) <- atomically $ do ss <- mapM (sequence . fmap readTVar) statuses blink <- readTVar blinkVar let cur = T.concat $ map (maybe " " ((" " <>) . showStatus blink)) ss when (cur == prev) retry return (ss, cur) - when (not $ T.null prev) $ putStr "\r" + let prefix1' = if any (maybe False jobStatusFailed) ss then "\ESC[91m" <> prefix1 <> "\ESC[0m" else prefix1 - T.putStr $ prefix1' <> prefix2 <> cur - hFlush stdout + redrawLine line $ prefix1' <> prefix2 <> cur if all (maybe True jobStatusFinished) ss - then T.putStrLn "" - else go blinkVar cur + then return () + else go line blinkVar cur diff --git a/src/Main.hs b/src/Main.hs index c693281..d24642d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,7 @@ import System.IO import Command import Command.Run import Config +import Terminal import Version data CmdlineOptions = CmdlineOptions @@ -120,7 +121,7 @@ fullCommandOptions proxy = ] runSomeCommand :: CommonOptions -> SomeCommandType -> [ String ] -> IO () -runSomeCommand copts (SC tproxy) args = do +runSomeCommand ciOptions (SC tproxy) args = do let exitWithErrors errs = do hPutStrLn stderr $ concat errs <> "Try `minici " <> commandName tproxy <> " --help' for more information." exitFailure @@ -142,7 +143,8 @@ runSomeCommand copts (SC tproxy) args = do Left err -> do putStr err exitFailure - Right config -> do + Right ciConfig -> do let cmd = commandInit tproxy (fcoSpecific opts) cmdargs let CommandExec exec = commandExec cmd - flip runReaderT ( copts, config ) exec + ciTerminalOutput <- initTerminalOutput + flip runReaderT CommandInput {..} exec diff --git a/src/Terminal.hs b/src/Terminal.hs new file mode 100644 index 0000000..bf50c58 --- /dev/null +++ b/src/Terminal.hs @@ -0,0 +1,45 @@ +module Terminal ( + TerminalOutput, + TerminalLine, + initTerminalOutput, + newLine, + redrawLine, +) where + +import Control.Concurrent + +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T + +import System.IO + + +data TerminalOutput = TerminalOutput + { outNumLines :: MVar Int + } + +data TerminalLine = TerminalLine + { lineOutput :: TerminalOutput + , lineNum :: Int + } + +initTerminalOutput :: IO TerminalOutput +initTerminalOutput = do + outNumLines <- newMVar 0 + return TerminalOutput {..} + +newLine :: TerminalOutput -> Text -> IO TerminalLine +newLine lineOutput@TerminalOutput {..} text = do + modifyMVar outNumLines $ \lineNum -> do + T.putStrLn text + hFlush stdout + return ( lineNum + 1, TerminalLine {..} ) + +redrawLine :: TerminalLine -> Text -> IO () +redrawLine TerminalLine {..} text = do + let TerminalOutput {..} = lineOutput + withMVar outNumLines $ \total -> do + let moveBy = total - lineNum + T.putStr $ "\ESC[s\ESC[" <> T.pack (show moveBy) <> "F" <> text <> "\ESC[u" + hFlush stdout |