summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--minici.cabal13
-rw-r--r--src/Command.hs23
-rw-r--r--src/Command/Run.hs86
-rw-r--r--src/Main.hs99
4 files changed, 153 insertions, 68 deletions
diff --git a/minici.cabal b/minici.cabal
index d93ce0f..86ca4f3 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -24,11 +24,14 @@ executable minici
ghc-options: -Wall -threaded
-- Modules included in this executable, other than Main.
- other-modules: Config
- Job
- Paths_minici
- Version
- Version.Git
+ other-modules:
+ Command
+ Command.Run
+ Config
+ Job
+ Paths_minici
+ Version
+ Version.Git
-- LANGUAGE extensions used by modules in this package.
other-extensions: TemplateHaskell
diff --git a/src/Command.hs b/src/Command.hs
new file mode 100644
index 0000000..78d0d6c
--- /dev/null
+++ b/src/Command.hs
@@ -0,0 +1,23 @@
+module Command (
+ Command(..),
+
+ CommandExec(..),
+ getConfig,
+) where
+
+import Control.Monad.Reader
+
+import Config
+
+class Command c where
+ commandName :: proxy c -> String
+
+ commandInit :: proxy c -> c
+ commandExec :: c -> CommandExec ()
+
+
+newtype CommandExec a = CommandExec (ReaderT Config IO a)
+ deriving (Functor, Applicative, Monad, MonadIO)
+
+getConfig :: CommandExec Config
+getConfig = CommandExec ask
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
new file mode 100644
index 0000000..3b997b5
--- /dev/null
+++ b/src/Command/Run.hs
@@ -0,0 +1,86 @@
+module Command.Run (
+ RunCommand,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Reader
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO
+import System.Process
+
+import Command
+import Config
+import Job
+
+data RunCommand = RunCommand
+
+instance Command RunCommand where
+ commandName _ = "run"
+
+ commandInit _ = RunCommand
+ commandExec _ = cmdRun
+
+cmdRun :: CommandExec ()
+cmdRun = do
+ config <- getConfig
+ liftIO $ do
+ commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
+ readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
+
+ putStr $ replicate (8 + 50) ' '
+ forM_ (configJobs config) $ \job -> do
+ T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
+ putStrLn ""
+
+ forM_ commits $ \(cid, desc) -> do
+ let shortCid = T.pack $ take 7 cid
+ outs <- runJobs "./.minici" cid $ configJobs config
+ displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs
+
+
+fitToLength :: Int -> Text -> Text
+fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
+ | otherwise = T.take (maxlen - 1) str <> "…"
+ where len = T.length str
+
+showStatus :: Bool -> JobStatus a -> Text
+showStatus blink = \case
+ JobQueued -> "\ESC[94m…\ESC[0m "
+ JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
+ JobSkipped -> "\ESC[0m-\ESC[0m "
+ JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
+ JobError _ -> "\ESC[91m!!\ESC[0m "
+ JobFailed -> "\ESC[91m✗\ESC[0m "
+ JobDone _ -> "\ESC[92m✓\ESC[0m "
+
+displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
+displayStatusLine prefix1 prefix2 statuses = do
+ blinkVar <- newTVarIO False
+ t <- forkIO $ forever $ do
+ threadDelay 500000
+ atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
+ go blinkVar ""
+ killThread t
+ where
+ go blinkVar prev = do
+ (ss, cur) <- atomically $ do
+ ss <- mapM readTVar statuses
+ blink <- readTVar blinkVar
+ let cur = T.concat $ map ((" " <>) . showStatus blink) ss
+ when (cur == prev) retry
+ return (ss, cur)
+ when (not $ T.null prev) $ putStr "\r"
+ let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"
+ else prefix1
+ T.putStr $ prefix1' <> prefix2 <> cur
+ hFlush stdout
+
+ if all jobStatusFinished ss
+ then T.putStrLn ""
+ else go blinkVar cur
diff --git a/src/Main.hs b/src/Main.hs
index 363fad8..1300024 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,22 +1,19 @@
module Main (main) where
-import Control.Concurrent
-import Control.Concurrent.STM
-
import Control.Monad
+import Control.Monad.Reader
-import Data.Text (Text)
-import Data.Text qualified as T
-import Data.Text.IO qualified as T
+import Data.List
+import Data.Proxy
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
-import System.Process
+import Command
+import Command.Run
import Config
-import Job
import Version
data CmdlineOptions = CmdlineOptions
@@ -40,58 +37,29 @@ options =
"show version and exit"
]
-fitToLength :: Int -> Text -> Text
-fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
- | otherwise = T.take (maxlen - 1) str <> "…"
- where len = T.length str
-
-showStatus :: Bool -> JobStatus a -> Text
-showStatus blink = \case
- JobQueued -> "\ESC[94m…\ESC[0m "
- JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
- JobSkipped -> "\ESC[0m-\ESC[0m "
- JobRunning -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m "
- JobError _ -> "\ESC[91m!!\ESC[0m "
- JobFailed -> "\ESC[91m✗\ESC[0m "
- JobDone _ -> "\ESC[92m✓\ESC[0m "
-
-displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
-displayStatusLine prefix1 prefix2 statuses = do
- blinkVar <- newTVarIO False
- t <- forkIO $ forever $ do
- threadDelay 500000
- atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
- go blinkVar ""
- killThread t
+data SomeCommandType = forall c. Command c => SC (Proxy c)
+
+commands :: [ SomeCommandType ]
+commands =
+ [ SC $ Proxy @RunCommand
+ ]
+
+lookupCommand :: String -> Maybe SomeCommandType
+lookupCommand name = find p commands
where
- go blinkVar prev = do
- (ss, cur) <- atomically $ do
- ss <- mapM readTVar statuses
- blink <- readTVar blinkVar
- let cur = T.concat $ map ((" " <>) . showStatus blink) ss
- when (cur == prev) retry
- return (ss, cur)
- when (not $ T.null prev) $ putStr "\r"
- let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"
- else prefix1
- T.putStr $ prefix1' <> prefix2 <> cur
- hFlush stdout
-
- if all jobStatusFinished ss
- then T.putStrLn ""
- else go blinkVar cur
+ p (SC cmd) = commandName cmd == name
main :: IO ()
main = do
args <- getArgs
- opts <- case getOpt Permute options args of
- (o, _, []) -> return (foldl (flip id) defaultCmdlineOptions o)
+ (opts, cmdargs) <- case getOpt Permute options args of
+ (o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)
(_, _, errs) -> do
hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
exitFailure
when (optShowHelp opts) $ do
- let header = "Usage: minici [<option>...]"
+ let header = "Usage: minici [<option>...] <command> [<args>]"
putStr $ usageInfo header options
exitSuccess
@@ -99,18 +67,23 @@ main = do
putStrLn versionLine
exitSuccess
+ (ncmd, cargs) <- case cmdargs of
+ [] -> return (head commands, [])
+ (cname : cargs)
+ | Just nc <- lookupCommand cname -> return (nc, cargs)
+ | otherwise -> do
+ hPutStr stderr $ unlines
+ [ "Unknown command `" <> cname <> "'."
+ , "Try `minici --help' for more information."
+ ]
+ exitFailure
+
+ runSomeCommand ncmd cargs
+
+runSomeCommand :: SomeCommandType -> [ String ] -> IO ()
+runSomeCommand (SC tproxy) _ = do
Just configPath <- findConfig
config <- parseConfig configPath
-
- commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
- readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
-
- putStr $ replicate (8 + 50) ' '
- forM_ (configJobs config) $ \job -> do
- T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
- putStrLn ""
-
- forM_ commits $ \(cid, desc) -> do
- let shortCid = T.pack $ take 7 cid
- outs <- runJobs "./.minici" cid $ configJobs config
- displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs
+ let cmd = commandInit tproxy
+ let CommandExec exec = commandExec cmd
+ flip runReaderT config exec
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-17 09:35:24 +0000