cabal-matrix 1.0.0.0 → 1.0.1.0

raw patch · 9 files changed

+215/−106 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• cabal-matrix.cabal +4/−2
• src/Cabal/Matrix/Cli.hs +11/−6
• src/Cabal/Matrix/Files.hs +37/−29
• src/Cabal/Matrix/Matrix.hs +15/−7
• src/Cabal/Matrix/ProcessRunner.hs +1/−0
• src/Cabal/Matrix/Scheduler.hs +46/−25
• src/Cabal/Matrix/Tui.hs +80/−36
• src/Cabal/Matrix/Tui/Flavor.hs +4/−1

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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 ()

@@ -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-  = [("<Esc>/Q", "back")] <> outputKeybinds+  = [("<Esc>/Q", "back")] <> outputKeybinds <>+    [ ("^C", "interrupt")+    , ("^\\", "terminate")+    , ("P", "prioritize")+    , ("R", "restart")+    ]   | Just _ <- ast.headerEditor   = [("<Esc>/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-      -> [("<Enter>/<Space>", "output")]-      | otherwise-      -> [])+  = (if isJust (astSelectedCell ast)+      then+        [ ("<Enter>/<Space>", "output")+        , ("^C", "interrupt")+        , ("^\\", "terminate")+        , ("P", "prioritize")+        , ("R", "restart")+        ]+      else [])     <> [("<Esc>/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

@@ -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