diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,17 @@ +# 1.0.1.0 + +- Binary operator options can now be parsed/formatted as JSON in a more compact + way: `foo --times bar --times baz` can now be serialized/deserialized as + `{"times":[foo,bar,baz]}` +- `--package PACKAGE` (i.e. without any version or version range specified) now + stands for all versions of `PACKAGE`. Likewise in JSON + `{"package":"PACKAGE","versions":null}` now stands for all versions. +- In the TUI, a build can now be: + - interrupted with Ctrl+C + - terminated with Ctrl+\ + - prioritized with P + - restarted with R + +# 1.0.0.0 + +Initial Hackage release diff --git a/cabal-matrix.cabal b/cabal-matrix.cabal --- a/cabal-matrix.cabal +++ b/cabal-matrix.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cabal-matrix -version: 1.0.0.0 +version: 1.0.1.0 author: mniip maintainer: mniip license: BSD-3-Clause @@ -17,7 +17,9 @@ homepage: https://github.com/mniip/cabal-matrix build-type: Simple -extra-doc-files: README.md +extra-doc-files: + CHANGELOG.md + README.md source-repository HEAD type: git diff --git a/src/Cabal/Matrix/Cli.hs b/src/Cabal/Matrix/Cli.hs --- a/src/Cabal/Matrix/Cli.hs +++ b/src/Cabal/Matrix/Cli.hs @@ -264,10 +264,11 @@ (long "compiler" <> short 'w' <> metavar "COMPILER1,COMPILER2,..." <> help "Specify a comma-separated list of compilers") , Expr "--package" . uncurry PackageVersionExpr <$> option readPackage - (long "package" <> metavar "PACKAGE=VERSION1,VERSION2,..." + (long "package" <> metavar "PACKAGE[=VERSION1,VERSION2,...]" <> help "Specify a comma-separated list of versions of a given \ \package. Each version can instead be a version range such as \ - \'>=1.0 && <2.0'") + \'>=1.0 && <2.0'. If only the package name is specified, all \ + \its versions are tried.") , Expr "--prefer" . PreferExpr <$> option readPrefer (long "prefer" <> metavar "[newest],[oldest]" <> help "Specify whether to try newest or oldest versions of \ @@ -324,10 +325,14 @@ | s `elem` ["oldest", "older", "old"] -> Just PreferOldest | otherwise -> Nothing -readPackage :: ReadM (PackageName, [Either Version VersionRange]) -readPackage = byEquals - (mkPackageName . strip <$> str) - (commaSeparated versionOrRange) +readPackage :: ReadM (PackageName, VersionExpr) +readPackage = do + s <- readerAsk + if '=' `elem` s + then byEquals + (mkPackageName . strip <$> str) + (SomeVersions <$> commaSeparated versionOrRange) + else ((, AllVersions) . mkPackageName . strip <$> str) where versionOrRange = ReadM $ ReaderT \s -> case eitherParsec @Version s of Right ver -> pure $ Left ver diff --git a/src/Cabal/Matrix/Files.hs b/src/Cabal/Matrix/Files.hs --- a/src/Cabal/Matrix/Files.hs +++ b/src/Cabal/Matrix/Files.hs @@ -17,6 +17,7 @@ import Data.Aeson.Types import Data.Foldable import Data.Functor +import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe @@ -66,18 +67,11 @@ toJSON (MatrixExprJSON e) = go e where go = \case - TimesExpr x y -> object - [ "times" .= toJSON (MatrixExprJSON x, MatrixExprJSON y) - ] - AddExpr x y -> object - [ "add" .= toJSON (MatrixExprJSON x, MatrixExprJSON y) - ] - SubtractExpr x y -> object - [ "subtract" .= toJSON (MatrixExprJSON x, MatrixExprJSON y) - ] - SeqExpr x y -> object - [ "seq" .= toJSON (MatrixExprJSON x, MatrixExprJSON y) - ] + -- Format TimesExpr (TimesExpr ... e2) e1 as {"times":[...,e2,e1]} + TimesExpr x y -> goTimes x [MatrixExprJSON y] + AddExpr x y -> goAdd x [MatrixExprJSON y] + SubtractExpr x y -> goSubtract x [MatrixExprJSON y] + SeqExpr x y -> goSeq x [MatrixExprJSON y] UnitExpr -> "unit" CompilersExpr compilers -> object [ "compilers" .= toJSON @@ -88,7 +82,9 @@ ] PackageVersionExpr packageName versions -> object [ "package" .= unPackageName packageName - , "versions" .= toJSON (VersionJSON <$> versions) + , "versions" .= case versions of + AllVersions -> Null + SomeVersions verList -> toJSON (VersionJSON <$> verList) ] CustomUnorderedExpr key options -> object [ "custom_unordered" .= key @@ -98,6 +94,22 @@ [ "custom_ordered" .= key , "options" .= toJSON options ] + goTimes (TimesExpr x y) ys = goTimes x (MatrixExprJSON y : ys) + goTimes y xs = object + [ "times" .= toJSON (MatrixExprJSON y : xs) + ] + goAdd (AddExpr x y) ys = goAdd x (MatrixExprJSON y : ys) + goAdd y xs = object + [ "add" .= toJSON (MatrixExprJSON y : xs) + ] + goSubtract (SubtractExpr x y) ys = goSubtract x (MatrixExprJSON y : ys) + goSubtract y xs = object + [ "subtract" .= toJSON (MatrixExprJSON y : xs) + ] + goSeq (SeqExpr x y) ys = goSeq x (MatrixExprJSON y : ys) + goSeq y xs = object + [ "seq" .= toJSON (MatrixExprJSON y : xs) + ] instance FromJSON MatrixExprJSON where parseJSON (String "unit") = pure $ MatrixExprJSON UnitExpr @@ -105,28 +117,24 @@ parseJSON (Object o) = do parses <- sequenceA [ (o .:? "times") <&> fmap @Maybe - \(MatrixExprJSON x, MatrixExprJSON y) -> TimesExpr x y + (foldl1 @NonEmpty TimesExpr . fmap \(MatrixExprJSON x) -> x) , (o .:? "add") <&> fmap @Maybe - \(MatrixExprJSON x, MatrixExprJSON y) -> AddExpr x y + (foldl1 @NonEmpty AddExpr . fmap \(MatrixExprJSON x) -> x) , (o .:? "subtract") <&> fmap @Maybe - \(MatrixExprJSON x, MatrixExprJSON y) -> SubtractExpr x y + (foldl1 @NonEmpty SubtractExpr . fmap \(MatrixExprJSON x) -> x) , (o .:? "seq") <&> fmap @Maybe - \(MatrixExprJSON x, MatrixExprJSON y) -> SeqExpr x y + (foldl1 @NonEmpty SeqExpr . fmap \(MatrixExprJSON x) -> x) , (o .:? "compilers") <&> fmap @Maybe (CompilersExpr . map Compiler) , (o .:? "prefer") <&> fmap @Maybe (PreferExpr . map \(PreferJSON value) -> value) - , do - mPackage <- o .:? "package" - mVersions <- o .:? "versions" - case (mPackage, mVersions) of - (Nothing, Nothing) -> pure Nothing - (Just package, Just versions) -> pure $ Just $ PackageVersionExpr - (mkPackageName package) - (versions <&> \(VersionJSON version) -> version) - (Nothing, Just _) -> fail - "Expected \"versions\" to be accompanied by \"package\"" - (Just _, Nothing) -> fail - "Expected \"package\" to be accompanied by \"versions\"" + , o .:? "package" >>= \case + Nothing -> pure Nothing + Just package -> do + versions <- o .:? "versions" <&> \case + Nothing -> AllVersions + Just versions -> SomeVersions + $ versions <&> \(VersionJSON version) -> version + pure $ Just $ PackageVersionExpr (mkPackageName package) versions , o .:? "custom_unordered" >>= \case Nothing -> pure Nothing Just key -> o .:? "options" >>= \case diff --git a/src/Cabal/Matrix/Matrix.hs b/src/Cabal/Matrix/Matrix.hs --- a/src/Cabal/Matrix/Matrix.hs +++ b/src/Cabal/Matrix/Matrix.hs @@ -6,6 +6,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text +import Data.Traversable import Distribution.Client.Config import Distribution.Client.GlobalFlags import Distribution.Client.IndexUtils @@ -105,6 +106,10 @@ ) ] +data VersionExpr + = AllVersions + | SomeVersions [Either Version VersionRange] + -- | An unevaluated build matrix expression. Matrices can contain exponentially -- many rows in the worst case, so it makes sense to delay converting into an -- evaluated representation. @@ -116,7 +121,7 @@ | UnitExpr | CompilersExpr [Compiler] | PreferExpr [Prefer] - | PackageVersionExpr PackageName [Either Version VersionRange] + | PackageVersionExpr PackageName VersionExpr | CustomUnorderedExpr Text [Text] | CustomOrderedExpr Text [Text] @@ -145,11 +150,14 @@ verbosity = Verbosity.silent evalVersionRanges - :: PackageName -> [Either Version VersionRange] -> EvalM [Version] -evalVersionRanges package = fmap concat . traverse \case - Left version -> pure [version] - Right range -> EvalWithDB \db -> packageVersion - <$> PackageIndex.lookupDependency db.packageIndex package range + :: PackageName -> VersionExpr -> EvalM [Version] +evalVersionRanges package = \case + AllVersions -> EvalWithDB \db -> packageVersion + <$> PackageIndex.lookupDependency db.packageIndex package anyVersion + SomeVersions versions -> concat <$> for versions \case + Left version -> pure [version] + Right range -> EvalWithDB \db -> packageVersion + <$> PackageIndex.lookupDependency db.packageIndex package range evalMatrixExpr :: MatrixExpr -> IO Matrix evalMatrixExpr = runEvalM . go @@ -181,7 +189,7 @@ e@(CompilersExpr _) -> pure e e@(PreferExpr _) -> pure e PackageVersionExpr package versions - -> PackageVersionExpr package . map Left + -> PackageVersionExpr package . SomeVersions . map Left <$> evalVersionRanges package versions e@(CustomUnorderedExpr _ _) -> pure e e@(CustomOrderedExpr _ _) -> pure e diff --git a/src/Cabal/Matrix/ProcessRunner.hs b/src/Cabal/Matrix/ProcessRunner.hs --- a/src/Cabal/Matrix/ProcessRunner.hs +++ b/src/Cabal/Matrix/ProcessRunner.hs @@ -73,6 +73,7 @@ cmd :| args -> (Process.proc cmd args) { Process.std_out = Process.CreatePipe , Process.std_err = Process.CreatePipe + , Process.create_group = True } _ <- forkIOWithUnmask \unmask -> do for_ mOut (\out -> unmask $ readLoop out Stdout) diff --git a/src/Cabal/Matrix/Scheduler.hs b/src/Cabal/Matrix/Scheduler.hs --- a/src/Cabal/Matrix/Scheduler.hs +++ b/src/Cabal/Matrix/Scheduler.hs @@ -84,8 +84,14 @@ { flavorIndex :: FlavorIndex } -- ^ Move the given flavor the front of the priority queue, if it hasn't -- been started yet + | RestartFlavor + { flavorIndex :: FlavorIndex + } -newtype SchedulerHandle = SchedulerHandle (MVar SchedulerState) +data SchedulerHandle = SchedulerHandle + { state :: MVar SchedulerState + , queueFilled :: MVar () + } data SchedulerState = SchedulerState { processes :: Map FlavorIndex ProcessHandle @@ -111,16 +117,17 @@ -> IO SchedulerHandle startScheduler input flavors cb = do sem <- newQSem input.jobs - mvar <- newMVar SchedulerState + stateVar <- newMVar SchedulerState { processes = Map.empty , stopRequested = Set.empty , queue = [0 .. sizeofArray flavors - 1] } + queueVar <- newEmptyMVar let waitForNext :: IO () waitForNext = do waitQSem sem - done <- modifyMVar mvar \state -> case state.queue of + done <- modifyMVar stateVar \state -> case state.queue of [] -> do doneWithFlavor pure (state, True) @@ -130,7 +137,7 @@ pure ( state { processes - = Map.update (\_ -> mProcess) flavorIndex state.processes + = Map.alter (\_ -> mProcess) flavorIndex state.processes , queue = queue' } , False @@ -178,39 +185,45 @@ takeMVar stdoutClosed takeMVar stderrClosed cb OnStepFinished { flavorIndex, step, exitCode } - case exitCode of - ExitFailure _ -> doneWithFlavor - ExitSuccess -> modifyMVar_ mvar \state + modifyMVar_ stateVar \state -> case exitCode of + ExitSuccess -- It's possible that an interrupt signal has been received after -- the process has already exited (successfully), but before we got -- the 'OnProcessExit' message. So we must check this flag to see if -- we shouldn't start subsequent steps. - -> if flavorIndex `Set.member` state.stopRequested - then do - doneWithFlavor - pure state - { processes = Map.delete flavorIndex state.processes - , stopRequested = Set.delete flavorIndex state.stopRequested - } - else do - mProcess <- startSteps flavorIndex nextSteps - pure state - { processes - = Map.update (\_ -> mProcess) flavorIndex state.processes - } + | flavorIndex `Set.notMember` state.stopRequested + -> do + mProcess <- startSteps flavorIndex nextSteps + pure state + { processes + = Map.alter (\_ -> mProcess) flavorIndex state.processes + } + _ -> do + doneWithFlavor + pure state + { processes = Map.delete flavorIndex state.processes + , stopRequested = Set.delete flavorIndex state.stopRequested + } waitForDone :: IO () waitForDone = do -- Once the queue has become empty, wait for all running jobs to finish replicateM_ input.jobs $ waitQSem sem cb OnDone + -- Restart the process if someone touches the queueVar + takeMVar queueVar + replicateM_ input.jobs $ signalQSem sem + waitForNext _ <- forkIO waitForNext - pure $ SchedulerHandle mvar + pure $ SchedulerHandle + { state = stateVar + , queueFilled = queueVar + } signalScheduler :: SchedulerHandle -> SchedulerSignal -> IO () -signalScheduler (SchedulerHandle mvar) = \case - InterruptFlavor{ flavorIndex } -> modifyMVar_ mvar \state -> if +signalScheduler hdl = \case + InterruptFlavor{ flavorIndex } -> modifyMVar_ hdl.state \state -> if | flavorIndex `elem` state.queue -> pure state { queue = delete flavorIndex state.queue } | Just processHdl <- Map.lookup flavorIndex state.processes @@ -219,7 +232,7 @@ pure state { stopRequested = Set.insert flavorIndex state.stopRequested } | otherwise -> pure state - TerminateFlavor{ flavorIndex } -> modifyMVar_ mvar \state -> if + TerminateFlavor{ flavorIndex } -> modifyMVar_ hdl.state \state -> if | flavorIndex `elem` state.queue -> pure state { queue = delete flavorIndex state.queue } | Just processHdl <- Map.lookup flavorIndex state.processes @@ -228,9 +241,17 @@ pure state { stopRequested = Set.insert flavorIndex state.stopRequested } | otherwise -> pure state - PrioritizeFlavor{ flavorIndex } -> modifyMVar_ mvar \state -> if + PrioritizeFlavor{ flavorIndex } -> modifyMVar_ hdl.state \state -> if | flavorIndex `elem` state.queue -> pure state { queue = flavorIndex : delete flavorIndex state.queue } -- ^ TODO: leak? we accumulate 'delete' thunks? | otherwise -> pure state + RestartFlavor{ flavorIndex } -> do + modifyMVar_ hdl.state \state -> if + | flavorIndex `notElem` state.queue + , flavorIndex `Map.notMember` state.processes + -> pure state { queue = flavorIndex : state.queue } + | otherwise + -> pure state + void $ tryPutMVar hdl.queueFilled () diff --git a/src/Cabal/Matrix/Tui.hs b/src/Cabal/Matrix/Tui.hs --- a/src/Cabal/Matrix/Tui.hs +++ b/src/Cabal/Matrix/Tui.hs @@ -141,46 +141,75 @@ appHandleEvent :: TuiMatrix -> PerCabalStep Bool + -> Maybe SchedulerHandle -> AppEvent -> AppState - -> Maybe AppState -appHandleEvent matrix enabledSteps aev ast = case aev of - AppTimerEvent ev -> Just ast + -> IO (Maybe AppState) +appHandleEvent matrix enabledSteps mScheduler aev ast = case aev of + AppTimerEvent ev -> pure $ Just ast { flavorStates = IntMap.map (flavorHandleTimerEvent ev) ast.flavorStates } VtyEvent (EvKey (isExitKey -> True) _) | Just _ <- ast.openedCell - -> Just ast { openedCell = Nothing } + -> pure $ Just ast { openedCell = Nothing } | Just _ <- ast.headerEditor - -> Just ast { headerEditor = Nothing } + -> pure $ Just ast { headerEditor = Nothing } | Nothing <- ast.headerEditor - -> Nothing + -> pure Nothing VtyEvent ev | Just (flavorIndex, os) <- ast.openedCell - -> Just ast - { openedCell = Just (flavorIndex, outputHandleEvent enabledSteps ev os) } + -> case ev of + EvKey (KChar 'c') (elem MCtrl -> True) -> do + for_ mScheduler $ flip signalScheduler InterruptFlavor { flavorIndex } + pure $ Just ast + EvKey (KChar '\\') (elem MCtrl -> True) -> do + for_ mScheduler $ flip signalScheduler TerminateFlavor { flavorIndex } + pure $ Just ast + EvKey (KChar 'p') _ -> do + for_ mScheduler $ flip signalScheduler PrioritizeFlavor { flavorIndex } + pure $ Just ast + EvKey (KChar 'r') _ -> do + for_ mScheduler $ flip signalScheduler RestartFlavor { flavorIndex } + pure $ Just ast + _ -> pure $ Just ast + { openedCell = Just (flavorIndex, outputHandleEvent enabledSteps ev os) + } | Just headerEditor <- ast.headerEditor , (headerEditor', headers') <- headerEditorHandleEvent matrix ev (headerEditor, ast.headers) - -> Just ast + -> pure $ Just ast { headers = headers' , headerEditor = Just headerEditor' , layout = mkTableLayout headers' } VtyEvent (EvKey (KChar 'x') _) - -> Just ast { headerEditor = Just initHeaderEditorState } + -> pure $ Just ast { headerEditor = Just initHeaderEditorState } VtyEvent (EvKey (isEnterKey -> True) _) - | ast.table.activeSelection == SelectionNormal - , ast.table.normalSelectionCol < sizeofArray - (Rectangle.rows ast.headers.horizontalHeader) - , ast.table.normalSelectionRow < sizeofArray - (Rectangle.rows ast.headers.verticalHeader) - , Just flavorIndex <- Rectangle.indexCell ast.headers.gridToFlavor - ast.table.normalSelectionCol ast.table.normalSelectionRow + | Just flavorIndex <- astSelectedCell ast , Just fs <- IntMap.lookup flavorIndex ast.flavorStates - -> Just ast { openedCell = Just (flavorIndex, initOutputState fs)} - | otherwise -> Just ast + -> pure $ Just ast { openedCell = Just (flavorIndex, initOutputState fs) } + | otherwise -> pure $ Just ast + VtyEvent (EvKey (KChar 'c') (elem MCtrl -> True)) + | Just flavorIndex <- astSelectedCell ast + -> do + for_ mScheduler $ flip signalScheduler InterruptFlavor { flavorIndex } + pure $ Just ast + VtyEvent (EvKey (KChar '\\') (elem MCtrl -> True)) + | Just flavorIndex <- astSelectedCell ast + -> do + for_ mScheduler $ flip signalScheduler TerminateFlavor { flavorIndex } + pure $ Just ast + VtyEvent (EvKey (KChar 'p') _) + | Just flavorIndex <- astSelectedCell ast + -> do + for_ mScheduler $ flip signalScheduler PrioritizeFlavor { flavorIndex } + pure $ Just ast + VtyEvent (EvKey (KChar 'r') _) + | Just flavorIndex <- astSelectedCell ast + -> do + for_ mScheduler $ flip signalScheduler RestartFlavor { flavorIndex } + pure $ Just ast VtyEvent ev - -> Just ast + -> pure $ Just ast { table = tableHandleEvent (mkTableMeta ast.headers) ev ast.table } where isExitKey = \case @@ -192,24 +221,37 @@ KEnter -> True _ -> False +astSelectedCell :: AppState -> Maybe FlavorIndex +astSelectedCell ast = do + guard $ ast.table.activeSelection == SelectionNormal + guard $ ast.table.normalSelectionCol < sizeofArray + (Rectangle.rows ast.headers.horizontalHeader) + guard $ ast.table.normalSelectionRow < sizeofArray + (Rectangle.rows ast.headers.verticalHeader) + Rectangle.indexCell ast.headers.gridToFlavor + ast.table.normalSelectionCol ast.table.normalSelectionRow + appKeybinds :: AppState -> [(Text, Text)] appKeybinds ast | Just _ <- ast.openedCell - = [("/Q", "back")] <> outputKeybinds + = [("/Q", "back")] <> outputKeybinds <> + [ ("^C", "interrupt") + , ("^\\", "terminate") + , ("P", "prioritize") + , ("R", "restart") + ] | Just _ <- ast.headerEditor = [("/Q", "back")] <> headerEditorKeybinds | otherwise - = (if - | ast.table.activeSelection == SelectionNormal - , ast.table.normalSelectionCol < sizeofArray - (Rectangle.rows ast.headers.horizontalHeader) - , ast.table.normalSelectionRow < sizeofArray - (Rectangle.rows ast.headers.verticalHeader) - , Just _ <- Rectangle.indexCell ast.headers.gridToFlavor - ast.table.normalSelectionCol ast.table.normalSelectionRow - -> [("/", "output")] - | otherwise - -> []) + = (if isJust (astSelectedCell ast) + then + [ ("/", "output") + , ("^C", "interrupt") + , ("^\\", "terminate") + , ("P", "prioritize") + , ("R", "restart") + ] + else []) <> [("/Q", "quit")] <> [("X", "axes")] <> tableKeybinds @@ -223,8 +265,9 @@ -> AppState -> PerCabalStep Bool -> TBQueue (Either SchedulerMessage AppEvent) + -> Maybe SchedulerHandle -> IO () -tuiMainLoop tuiMatrix ast0 steps queue = do +tuiMainLoop tuiMatrix ast0 steps queue mScheduler = do vty <- mkVty defaultConfig _ <- forkIO $ forever do @@ -239,7 +282,7 @@ go !ast = atomically (readTBQueue queue) >>= \case Left msg -> go (appHandleSchedulerMessage msg ast) - Right ev -> case appHandleEvent tuiMatrix steps ev ast of + Right ev -> appHandleEvent tuiMatrix steps mScheduler ev ast >>= \case Just ast' -> goDisplay ast' Nothing -> vty.shutdown @@ -261,10 +304,11 @@ _ <- forkIO $ forever do threadDelay 100000 atomically . writeTBQueue queue . Right . AppTimerEvent $ TimerEvent - _hdl <- startScheduler schedulerConfig flavors + scheduler <- startScheduler schedulerConfig flavors (atomically . writeTBQueue queue . Left) tuiMainLoop tuiMatrix (initAppState tuiMatrix) options.steps queue + (Just scheduler) -- TODO: should probably kill the processes in _hdl @@ -306,4 +350,4 @@ tuiMainLoop tuiMatrix (addOutputFromRecording results $ initAppState tuiMatrix) - steps queue + steps queue Nothing diff --git a/src/Cabal/Matrix/Tui/Flavor.hs b/src/Cabal/Matrix/Tui/Flavor.hs --- a/src/Cabal/Matrix/Tui/Flavor.hs +++ b/src/Cabal/Matrix/Tui/Flavor.hs @@ -110,7 +110,10 @@ stepHandleSchedulerEvent :: SchedulerMessage -> StepState -> StepState stepHandleSchedulerEvent ev ss = case ev of - OnStepStarted{} -> ss { started = True } + OnStepStarted{} -> ss + { started = True + , exit = Nothing -- in case this is a restart + } OnStepFinished{ exitCode } -> ss { exit = Just exitCode } OnOutput{ channel, output } -> ss { revOutput = (channel, output):ss.revOutput