cabal-matrix (empty) → 1.0.0.0
raw patch · 17 files changed
+3461/−0 lines, 17 filesdep +Cabaldep +Cabal-syntaxdep +aeson
Dependencies added: Cabal, Cabal-syntax, aeson, base, bytestring, cabal-install, cabal-install-solver, cabal-matrix, containers, directory, filepath, hashable, optparse-applicative, primitive, process, safe-exceptions, split, stm, text, transformers, vty, vty-crossplatform, word-wrap
Files
- README.md +313/−0
- app/Main.hs +1/−0
- cabal-matrix.cabal +95/−0
- src/Cabal/Matrix/CabalArgs.hs +186/−0
- src/Cabal/Matrix/Cli.hs +353/−0
- src/Cabal/Matrix/Files.hs +282/−0
- src/Cabal/Matrix/Main.hs +56/−0
- src/Cabal/Matrix/Matrix.hs +187/−0
- src/Cabal/Matrix/ProcessRunner.hs +101/−0
- src/Cabal/Matrix/Record.hs +135/−0
- src/Cabal/Matrix/Rectangle.hs +390/−0
- src/Cabal/Matrix/Scheduler.hs +236/−0
- src/Cabal/Matrix/Tui.hs +309/−0
- src/Cabal/Matrix/Tui/Common.hs +63/−0
- src/Cabal/Matrix/Tui/Flavor.hs +266/−0
- src/Cabal/Matrix/Tui/Headers.hs +105/−0
- src/Cabal/Matrix/Tui/Table.hs +383/−0
+ README.md view
@@ -0,0 +1,313 @@+# cabal-matrix++`cabal-matrix` is a matrix builder for cabal. It lets you specify in a flexible+way a list of configurations in which something can be built, such as compiler+versions, or dependency version restrictions. It will then run the builds in+parallel (locally), and present the results in a TUI table where the specific+outcomes can be more closely examined. This is useful for inventing and+correcting dependency bounds for your package, as well as finding dependency+issues in other packages and fixing them.++This README is a tutorial that walks through some example use cases. A reference+of CLI options can be obtained by running `cabal-matrix --help`.++# Installation++```sh+cabal install cabal-matrix+```++# Building Your Package++Suppose you have a package `foo` that you're developing as part of a cabal+project (with a `cabal.project` file in current directory), such that your+package can be built by running:+```sh+cabal build foo+```++You can then build your package with `cabal-matrix` using:+```sh+cabal-matrix -j1 foo --default+```++This will open a TUI with a single cell representing the single build you're+doing. You can use `<Tab>` and then `<Space>` to view and follow the output of+the build, and `q` or `<Esc>` to exit.++# Inventing Dependency Bounds++Suppose your package build-depends on `bytestring`, but you don't have any+version bounds in the cabal file, because you're not sure which to put. To+figure this out, we can simply try building our package with each version of+`bytestring` and see if it works or not! This can be achieved by running:+```sh+cabal-matrix -j1 foo --package bytestring=">= 0"+```++This may take a while to complete, and you can try using a higher value of `-j`+to run multiple builds in parallel, but in the end your table will look like+this (you can use arrow keys to scroll around):+```+bytestring│0.9 0.9.0.1 0.9.0.2 0.9.0.3 0.9.0.4 0.9.1.0 0.9+──────────┼────────────────────────────────────────────────────────────────────▶+ │+──────────┼────────────────────────────────────────────────────────────────────▶+ │no plan no plan no plan no plan no plan no plan no+ │+ │+ │+ │+<Esc>/Q: quit │ X: axes │ ◀▲▼▶: select cell │ <Tab>: focus cells/cols/rows+```++- A `build ok` result in a particular column means that your package built+ successfully against that version of `bytestring`, meaning your package de+ facto supports it.+- A `no plan` result is considered a tentative success. It means cabal could not+ come up with a build plan, because dependency bounds have prevented this+ configuration from being usable.+- A `build fail` result means that we tried building but there was an error.+ You can select the cell with arrow keys, and use `<Space>` to view the build+ output to see what the error was.+- A `deps fail` result means there was a problem building the dependencies.+ This could indicate a bug in `bytestring`, or in a package that is between+ `foo` and `bytestring` in the dependency graph. Or it could be that your build+ environment is not working properly.++The goal of setting version bounds is turning `build fail`s into `no plan`s:+you can choose the `bytestring` version range to be one that includes all the+`build ok`s, and excludes all `build fail`s.++You could also change your package to avoid whatever it was that caused the+`build fail`s in the first place, and thus widen the possible version range.++# Validating Dependency Bounds++Once you add bounds in the cabal file, or if you had pre-existing bounds, you+can verify that these bounds are not too loose. Suppose your bounds were+`build-depends: bytestring >=0.11.4 && <0.13`. You can then run:+```sh+cabal-matrix -j1 foo --package bytestring=">=0.11.4 && <0.13"+```+You could even run the same command as before (`bytestring=">= 0"`), but this+will save time (and table space!) by not focusing on configurations that are+definitely outside the possible range.++In the result, you should expect to see only `build ok`s and `no plan`s. As+before, `build fail` suggests that your bounds aren't tight enough, and+`deps fail` suggests an issue upstream (but you should verify).++Note however that `no plan` is only a tentative success. It could be caused by+bounds created by you, or by constraints not created by you. In the latter case+you run the risk of those constraints disappearing, and uncovering a+`build fail` underneath. A very common way this can happen is with compiler+versions, for example if you're using GHC 9.12.2, then any configuration+involving `bytestring-0.11.4.0` will be `no-plan` because `bytestring` itself+doesn't support that compiler. If I switch to GHC 9.8.4, `bytestring-0.11.4.0`+becomes buildable.++If you intend to support multiple compilers in your package, and you have e.g.+`ghc-9.8.4` and `ghc-9.12.2` on your `PATH`, you can test this scenario using:+```sh+cabal-matrix -j1 foo \+ --compiler ghc-9.8.4,ghc-9.12.2 \+ --times \+ --package bytestring=">=0.11.4 && <0.13"+```++This will create a build matrix that looks like this:+```+ COMPILER│ghc-9.8.4 ghc-9.12.2+──────────┼─────────────────────────────────────────────────────────────────────+bytestring│+──────────┼─────────────────────────────────────────────────────────────────────+0.11.4.0 │build ok no plan+0.11.5.0 │build ok no plan+0.11.5.1 │build ok no plan+0.11.5.2 │build ok no plan+0.11.5.3 ▼build ok build ok+<Esc>/Q: quit │ X: axes │ ◀▲▼▶: select cell │ <Tab>: focus cells/cols/rows+```++If you like the view transposed, you can press `X` and configure "COMPILER" to+use the Vertical axis and "bytestring" to use the Horizontal axis instead.++Note that in the invocation above, `--compiler ...` produces a list of+compilers, and `--package bytestring=...` produces a list of `bytestring`+versions, and the `--times` operator between them combines the two lists using a+cartesian product.++If your package also depends on e.g. `text`, you may want to similarly check+which versions of `text` it actually builds with, with e.g.+```sh+cabal-matrix -j1 foo \+ --compiler ghc-9.8.4,ghc-9.12.2 \+ --times \+ --package bytestring="==0.11.5.*" \+ --times \+ --package text="==2.0.*"+```+This will run a build for each of the 2 compilers, for each of the 5 selected+`bytestring` versions, and each of the 3 selected `text` versions for a total+of 2 * 5 * 3 = 30 builds.++For most situations this is wasteful though, as independent packages don't+usually interact in a way that will only cause a problem for a combination of+versions. For dependent packages, such as `text` depending on `bytestring`, the+incompatibility will usually manifest when building `text`, which is why+`text` will have its own dependency bounds for `bytestring`. And if those are+incorrect then that's a problem in `text`.++So instead it is usually sufficient to only constrain one package at a time.+You can do this with `cabal-matrix` like so:+```sh+cabal-matrix -j1 foo \+ --compiler ghc-9.8.4,ghc-9.12.2 \+ --times \+ --[ \+ --package bytestring="==0.11.5.*" \+ --add \+ --package text="==2.0.*" \+ --]+```+Note the use of `--add` here instead of `--times` -- this concatenates the two+lists instead of taking their cartesian product. Also note the use of `--[`+`--]` to group the operands together, otherwise operations are executed from+left to right (a.k.a. left associatively).++The above invocation will run 2 * (5 + 3) = 16 builds instead. You can press `X`+and configure "bytestring" and "text" to use the Vertical axis, and then the+table will look like this:+```+ COMPILER│ghc-9.8.4 ghc-9.12.2+────────────────┼───────────────────────────────────────────────────────────────+bytestring text │+────────────────┼───────────────────────────────────────────────────────────────+0.11.5.0 │build ok no plan+0.11.5.1 │build ok no plan+0.11.5.2 │build ok no plan+0.11.5.3 │build ok build ok+0.11.5.4 │build ok build ok+ 2.0 │no plan no plan+ 2.0.1│build ok no plan+ 2.0.2│no plan no plan+<Esc>/Q: quit │ X: axes │ ◀▲▼▶: select cell │ <Tab>: focus cells/cols/rows+```++Note that there are unusual circumstances where a simple `--add` will be+insufficient, particularly if you use `#ifdef`s or cabal flags to faciliate a+migration for some breaking change. It's your job to know whether your package+uses such mechanisms, to decide how much they should be tested, and to find a+balance between practicality and the combinatorial explosion of configurations.++# Parallelism++There are two ways to specify parallelism: you can specify `-jN` to tell+`cabal-matrix` to run N cabals in parallel, and you can also use `--option -jM`+to tell `cabal-matrix` to *forward* the option `-jM` to cabal, causing cabal to+use M threads in turn. In combination this may require up to N * M cores.++I recommend the combination `-jN --option -j1`, where `N` is the number of cores+on your machine; because planning isn't threaded, and because `--option -j1`+also causes cabal to log each module being compiled, rather than only entire+packages.++# Building Someone Else's Package++If you run into `deps fail`, or otherwise find a package on Hackage that fails+to build because its dependency bounds are incorrect, you can easily debug this+with `cabal-matrix` too.++You could run e.g.:+```sh+cabal-matrix -j1 text --package text=">=0" --times --package bytestring=">=0"+```+to try every `text` version against every `bytestring` version. However if+you're running this from your project folder, then the constraints coming from+your project's packages will prevent some versions from being available,+possibly masking some `build fail`s as `no plan`s.++Instead you can move out of your project folder into a temporary directory, and+use `--install-lib`:+```sh+cd /tmp+cabal-matrix -j1 --install-lib text \+ --package text=">=0" --times --package bytestring=">=0"+```++For a typical yet concrete example, we can time travel to the past using+`--option --index-state=2025-10-01T00:00:00Z`, and try building `tar` against+`directory`:+```sh+cabal-matrix -j1 --install-lib tar \+ --option --index-state=2025-10-01T00:00:00Z \+ --compiler ghc-9.2.8 \+ --times \+ --package tar='>=0.6' \+ --times \+ --package directory='>=1.3'+```++There is a clear cut corner of `build fail`s at `tar >=0.6.4` and+`directory <1.3.8`:+```+ COMPILER│ghc-9.2.8 ghc-9.2.8 ghc-9.2.8 ghc-9.2.8 ghc-9.2.8 ghc-9.2.8+ tar │0.6.0.0 0.6.1.0 0.6.2.0 0.6.3.0 0.6.4.0 0.7.0.0+─────────┼──────────────────────────────────────────────────────────────────────+directory│+─────────┼──────────────────────────────────────────────────────────────────────+1.3.5.0 ▲no plan no plan no plan no plan no plan no plan+1.3.6.0 │no plan no plan no plan no plan no plan no plan+1.3.6.1 │no plan no plan no plan no plan no plan no plan+1.3.6.2 │build ok build ok build ok build ok build fail build fail+1.3.7.0 │build ok build ok build ok build ok build fail build fail+1.3.7.1 │build ok build ok build ok build ok build fail build fail+1.3.8.0 │build ok build ok build ok build ok build ok build ok+1.3.8.1 │build ok build ok build ok build ok build ok build ok+1.3.8.2 ▼build ok build ok build ok build ok build ok build ok+<Esc>/Q: quit │ X: axes │ ◀▲▼▶: select cell │ <Tab>: focus cells/cols/rows+```+Using arrow keys to navigate to each `build fail` and `<Space>` to view the+output, we see that they are all caused by the same issue of importing+`System.Directory.OsPath`. Double checking with the documentation we see that+the module was added in `directory-1.3.8.0`, and the fact that `tar` uses it+without declaring `build-depends: directory >=1.3.8` is a mistake.++This specific issue has been already reported in+https://github.com/haskell/tar/issues/103 and fixed.++Note that we chose to use a sufficiently old compiler to cover a wide range of+`directory` versions. If we had used GHC 9.8.4, we would have noticed a+`build fail` but our investigation would have been complicated by the fact that+`directory-1.3.8.0` is not buildable, and it's not immediately clear whether the+fix is `directory >=1.3.8` or `directory >=1.3.8.1`. If we had used GHC 9.12.2,+we would not have noticed the problem at all, as `directory <1.3.8` is not+buildable.++In general, some fiddling with GHC versions may be required, even mixing+different GHC versions in the same build, e.g.:+```+--[ --compiler ghc-7.10.3 --times --package directory="<1.3.8" --] \+--add \+--[ --compiler ghc-9.6.7 --times --package directory=">=1.3.8" --]+```++# Loosening Dependency Bounds++If you have dependency bounds, but you're unsure if they're too tight and+can/should be relaxed, you can forward (using `--option`) `--allow-newer` and+`--allow-older` to cabal:+```sh+cabal-matrix -j1 foo --package bytestring=">= 0" \+ --option --allow-newer=foo:bytestring --option --allow-older=foo:bytestring+```+This will tell cabal to ignore the `build-depends` constraints that your package+`foo` has declared on `bytestring`.++With these options, some configurations that were previously `no plan`s may+become `build fail`s, meaning the constraint was correct in excluding those.+Other configurations may become `build ok`, meaning the constraint could be+relaxed to include those. Finally, some `no plan`s may remain as such, meaning+the configuration was excluded for some other reason. You can read the `no plan`+output to find out in more detail.
+ app/Main.hs view
@@ -0,0 +1,1 @@+import Cabal.Matrix.Main (main)
+ cabal-matrix.cabal view
@@ -0,0 +1,95 @@+cabal-version: 3.0+name: cabal-matrix+version: 1.0.0.0+author: mniip+maintainer: mniip+license: BSD-3-Clause+category: Development+synopsis: Matrix builds for cabal+description:+ @cabal-matrix@ is a matrix builder for cabal. It lets you specify in a+ flexible way a list of configurations in which something can be built, such as+ compiler versions, or dependency version restrictions. It will then run the+ builds in parallel (locally), and present the results in a TUI table where the+ specific outcomes can be more closely examined. This is useful for inventing+ and correcting dependency bounds for your package, as well as finding+ dependency issues in other packages and fixing them.++homepage: https://github.com/mniip/cabal-matrix+build-type: Simple+extra-doc-files: README.md++source-repository HEAD+ type: git+ location: https://github.com/mniip/cabal-matrix.git++common common+ default-language: GHC2021+ default-extensions:+ BlockArguments+ DeriveAnyClass+ DeriveTraversable+ DerivingStrategies+ DuplicateRecordFields+ LambdaCase+ MultiWayIf+ NoFieldSelectors+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ ViewPatterns++library+ import: common+ build-depends:+ , aeson >=2.0 && <2.3+ , base >=4.16 && <4.22+ , bytestring >=0.11 && <0.13+ , Cabal >=3.8 && <3.17+ , cabal-install >=3.8 && <3.17+ , cabal-install-solver >=3.8 && <3.17+ , Cabal-syntax >=3.8 && <3.17+ , containers >=0.6 && <0.9+ , directory >=1.3 && <1.4+ , filepath >=1.3 && <1.6+ , hashable >=1.3 && <1.6+ , optparse-applicative >=0.19.0.0 && <0.20+ , primitive >=0.7 && <0.10+ , process >=1.6 && <1.7+ , safe-exceptions >=0.1 && <0.2+ , split >=0.1 && <0.3+ , stm >=2.5 && <2.6+ , text >=2.0 && <2.2+ , transformers >=0.5 && <0.7+ , vty >=6.0 && <6.5+ , vty-crossplatform >=0.1 && <0.5+ , word-wrap >=0.3 && <0.6++ hs-source-dirs: src+ exposed-modules:+ Cabal.Matrix.CabalArgs+ Cabal.Matrix.Cli+ Cabal.Matrix.Files+ Cabal.Matrix.Main+ Cabal.Matrix.Matrix+ Cabal.Matrix.ProcessRunner+ Cabal.Matrix.Record+ Cabal.Matrix.Rectangle+ Cabal.Matrix.Scheduler+ Cabal.Matrix.Tui+ Cabal.Matrix.Tui.Common+ Cabal.Matrix.Tui.Flavor+ Cabal.Matrix.Tui.Headers+ Cabal.Matrix.Tui.Table++executable cabal-matrix+ import: common+ build-depends:+ , base+ , cabal-matrix++ -- -threaded is required so that waiting for child processes does not block+ -- the RTS+ ghc-options: -threaded+ hs-source-dirs: app+ main-is: Main.hs
+ src/Cabal/Matrix/CabalArgs.hs view
@@ -0,0 +1,186 @@+-- | Converting high-level build matrix concepts into @cabal@ commandlines.+module Cabal.Matrix.CabalArgs+ ( CabalArgs(..)+ , CabalStep(..)+ , PerCabalStep(..)+ , indexCabalStep+ , tabulateCabalStep'+ , modifyCabalStep+ , setCabalStep+ , CabalMode(..)+ , Flavor(..)+ , renderCabalArgs+ , environmentFilePath+ ) where++import Data.Hashable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics+import System.FilePath+++-- | Cabal allows interrupting the build process at multiple points, which is+-- useful to know which stage the build failed at.+data CabalStep+ = DryRun+ -- ^ Run with @--dry-run@, only creating a plan.+ | OnlyDownload+ -- ^ Run with @--only-download@, creating a plan and only downloading+ -- dependencies.+ | OnlyDependencies+ -- ^ Run with @--only-dependencies@, creating a plan, downloading and+ -- building only the dependencies.+ | FullBuild+ -- ^ Run without any of the aforementioned options, fully building the+ -- selected targets.+ deriving stock (Eq, Ord, Show, Enum, Bounded)++-- | A collection of values per each 'CabalStep'. Useful for "memoizing" a+-- function @'CabalStep' -> a@.+data PerCabalStep a = PerCabalStep+ { dryRun :: a+ , onlyDownload :: a+ , onlyDependencies :: a+ , fullBuild :: a+ } deriving stock (Functor, Foldable, Traversable)++indexCabalStep :: PerCabalStep a -> CabalStep -> a+indexCabalStep pcs = \case+ DryRun -> pcs.dryRun+ OnlyDownload -> pcs.onlyDownload+ OnlyDependencies -> pcs.onlyDependencies+ FullBuild -> pcs.fullBuild++-- | Note: the function is evaluated (to WHNF) at each input.+tabulateCabalStep' :: (CabalStep -> a) -> PerCabalStep a+tabulateCabalStep' f = PerCabalStep{..}+ where+ !dryRun = f DryRun+ !onlyDownload = f OnlyDownload+ !onlyDependencies = f OnlyDependencies+ !fullBuild = f FullBuild++modifyCabalStep :: CabalStep -> (a -> a) -> PerCabalStep a -> PerCabalStep a+modifyCabalStep step f pcs = case step of+ DryRun | !dryRun <- f pcs.dryRun+ -> pcs { dryRun }+ OnlyDownload | !onlyDownload <- f pcs.onlyDownload+ -> pcs { onlyDownload }+ OnlyDependencies | !onlyDependencies <- f pcs.onlyDependencies+ -> pcs { onlyDependencies }+ FullBuild | !fullBuild <- f pcs.fullBuild+ -> pcs { fullBuild }++setCabalStep :: CabalStep -> a -> PerCabalStep a -> PerCabalStep a+setCabalStep step value pcs = case step of+ DryRun -> pcs { dryRun = value }+ OnlyDownload -> pcs { onlyDownload = value }+ OnlyDependencies -> pcs { onlyDependencies = value }+ FullBuild -> pcs { fullBuild = value }++-- | In either case if we are in a cabal project then we can only install+-- packages that are in the dependency closure of the project, and they will be+-- subject to constraints defined in the project file, if any.+data CabalMode+ = ProjectBuild -- | Assume that we're in a cabal project and run @cabal build@+ -- targeting the project's packages and their dependencies.+ | InstallLib -- | Use @cabal install --lib@, which doesn't require to be in a+ -- cabal project. If we are in a project, the project's packages will be+ -- sdisted first.++-- | Options defining what cell in the build matrix we're in.+data Flavor = Flavor+ { unorderedOptions :: Set Text+ , orderedOptions :: [Text]+ } deriving stock (Eq, Show, Generic)+ deriving anyclass (Hashable)++instance Semigroup Flavor where+ f1 <> f2 = Flavor+ { unorderedOptions = Set.union f1.unorderedOptions f2.unorderedOptions+ , orderedOptions = f1.orderedOptions ++ f2.orderedOptions+ }++instance Monoid Flavor where+ mempty = Flavor+ { unorderedOptions = Set.empty+ , orderedOptions = []+ }++-- | A single invocation of @cabal@.+data CabalArgs = CabalArgs+ { cabalExecutable :: FilePath+ , mode :: CabalMode+ , step :: CabalStep+ , options :: [Text]+ , targets :: [Text]+ , flavor :: Flavor+ }++data CabalRawArgs = CabalRawArgs+ { cabalExecutable :: FilePath+ , buildDir :: FilePath+ -- ^ @--builddir@, where build artifacts will be placed. Different+ -- flavors using the same compiler must use different 'buildDir'.+ , mode :: CabalMode+ , envFile :: Maybe FilePath+ -- ^ An environment file to use with @install --lib@. The file needs to not+ -- yet exist, so that its contents don't conflict with the install plan, but+ -- running cabal will bring this file into existence. So we basically have+ -- to remove this file every time.+ , step :: CabalStep+ , options :: [Text]+ , targets :: [Text]+ }++renderRawCabalArgs :: CabalRawArgs -> NonEmpty Text+renderRawCabalArgs ca = "cabal" :| mconcat+ [ case ca.mode of+ ProjectBuild -> ["build"]+ InstallLib -> ["install", "--lib"]+ , case ca.envFile of+ Nothing -> []+ Just path -> ["--package-env", Text.pack path]+ , ["--builddir", Text.pack ca.buildDir]+ , case ca.step of+ DryRun -> ["--dry-run"]+ OnlyDownload -> ["--only-download"]+ OnlyDependencies -> ["--only-dependencies"]+ FullBuild -> []+ , ca.options+ , ["--" | not $ null ca.targets]+ , ca.targets+ ]++argsToRaw :: CabalArgs -> CabalRawArgs+argsToRaw args@CabalArgs{..} = CabalRawArgs+ { cabalExecutable+ , buildDir = buildDirFor flavor+ , mode+ , envFile = environmentFilePath args+ , step+ , options = concat+ [ options+ , Set.toList flavor.unorderedOptions+ , flavor.orderedOptions+ ]+ , targets+ }++-- TODO: there probably needs to be some mechanism to clean up these at some+-- point.+buildDirFor :: Flavor -> FilePath+buildDirFor f = "dist-newstyle" </>+ ("cabal-matrix-" <> show (fromIntegral @Int @Word $ hash f))++renderCabalArgs :: CabalArgs -> NonEmpty Text+renderCabalArgs = renderRawCabalArgs . argsToRaw++environmentFilePath :: CabalArgs -> Maybe FilePath+environmentFilePath CabalArgs{..} = case mode of+ ProjectBuild -> Nothing+ InstallLib -> Just $ buildDirFor flavor </> "env"
+ src/Cabal/Matrix/Cli.hs view
@@ -0,0 +1,353 @@+module Cabal.Matrix.Cli+ ( CliOptions(..)+ , getSchedulerConfig+ , ExprSource(..)+ , RunOptions(..)+ , cliParser+ ) where++import Control.Applicative+import Cabal.Matrix.CabalArgs+import Cabal.Matrix.Matrix+import Cabal.Matrix.Scheduler+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Data.Char+import Data.List.Split+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Traversable+import Distribution.Package+import Distribution.Parsec+import Distribution.Version+import Options.Applicative+import Options.Applicative.Help.Pretty+import Options.Applicative.Types+import System.Environment+++data ExprSource+ = ExprArgs (Either Text MatrixExpr)+ | ExprFile FilePath++data RunOptions = RunOptions+ { jobs :: Int+ , cabalOverride :: Maybe FilePath+ , steps :: PerCabalStep Bool+ , options :: [Text]+ , targets :: [Text]+ , mode :: CabalMode+ }++getSchedulerConfig :: RunOptions -> IO SchedulerConfig+getSchedulerConfig RunOptions{..} = do+ cabalExecutable <- case cabalOverride of+ Just override -> pure override+ Nothing -> fromMaybe "cabal" <$> lookupEnv "CABAL"+ pure SchedulerConfig{..}++data CliOptions+ = ExprToExpr+ { exprSource :: ExprSource+ , outFile :: FilePath+ }+ | ExprToMatrix+ { exprSource :: ExprSource+ , outFile :: FilePath+ }+ | ExprToRecord+ { exprSource :: ExprSource+ , runParams :: RunOptions+ , outFile :: FilePath+ }+ | ExprToTui+ { exprSource :: ExprSource+ , runParams :: RunOptions+ }+ | MatrixToRecord+ { matrixFile :: FilePath+ , runParams :: RunOptions+ , outFile :: FilePath+ }+ | MatrixToTui+ { matrixFile :: FilePath+ , runParams :: RunOptions+ }+ | RecordToTui+ { recordFile :: FilePath+ }++data Source+ = FromExpr ExprSource+ | FromMatrix FilePath+ | FromRecord FilePath++data Target+ = ToExpr FilePath+ | ToMatrix FilePath+ | ToRecord FilePath+ | ToTui++cliParser :: ParserInfo (Either Text CliOptions)+cliParser = info (optionsAsCommand <|> options) mempty+ where+ -- Cabal external commands will invoke us as "cabal-matrix matrix $ARGS",+ -- see https://github.com/haskell/cabal/issues/10275 . Using an+ -- optparse-applicative 'command' we can swallow this "matrix" exactly when+ -- it's the first argument -- otherwise we interpret "matrix" as a target.+ -- 'internal' makes it hidden from all help texts.+ optionsAsCommand = subparser+ (internal <> command "matrix" (info options mempty))++ options = mkOptions+ <$> sourceOption+ <*> optional runOptions+ <*> targetOption+ <**> helper+ sourceOption = (FromExpr <$> exprSourceOption)+ <|> (FromMatrix <$> fromMatrixOption)+ <|> (FromRecord <$> fromRecordOption)+ exprSourceOption = (ExprArgs <$> frameOptions)+ <|> (ExprFile <$> exprFileOption)+ targetOption = (ToExpr <$> toExprOption)+ <|> (ToMatrix <$> toMatrixOption)+ <|> (ToRecord <$> toRecordOption)+ <|> (pure ToTui)++ mkOptions source mRunParams target = case (source, target) of+ (FromExpr exprSource, ToExpr outFile)+ -> Right ExprToExpr{..}+ (FromExpr exprSource, ToMatrix outFile)+ -> Right ExprToMatrix{..}+ (FromExpr exprSource, ToRecord outFile) -> case mRunParams of+ Just runParams -> Right ExprToRecord{..}+ Nothing -> noRunOptions+ (FromExpr exprSource, ToTui) -> case mRunParams of+ Just runParams -> Right ExprToTui{..}+ Nothing -> noRunOptions+ (FromMatrix matrixFile, ToRecord outFile) -> case mRunParams of+ Just runParams -> Right MatrixToRecord{..}+ Nothing -> noRunOptions+ (FromMatrix matrixFile, ToTui) -> case mRunParams of+ Just runParams -> Right MatrixToTui{..}+ Nothing -> noRunOptions+ (FromRecord recordFile, ToTui)+ -> Right RecordToTui{..}++ (FromMatrix _, ToExpr _) -> Left+ "--from-matrix cannot be used with --to-expr"+ (FromMatrix _, ToMatrix _) -> Left+ "--from-matrix cannot be used with --to-matrix"+ (FromRecord _, ToExpr _) -> Left+ "--from-record cannot be used with --to-expr"+ (FromRecord _, ToMatrix _) -> Left+ "--from-record cannot be used with --to-matrix"+ (FromRecord _, ToRecord _) -> Left+ "--from-record cannot be used with --to-record"++ exprFileOption = filesGroup+ $ option str (long "from-expr" <> metavar "FILE"+ <> help "Read the expression from FILE previously created by --to-expr")+ toExprOption = filesGroup+ $ option str (long "to-expr" <> metavar "FILE"+ <> help "Instead of running the TUI, resolve the versions in the given \+ \expression and save it to FILE")+ fromMatrixOption = filesGroup+ $ option str (long "from-matrix" <> metavar "FILE"+ <> help "Load the build matrix from FILE previously created by \+ \--to-matrix")+ toMatrixOption = filesGroup+ $ option str (long "to-matrix" <> metavar "FILE"+ <> help "Instead of running the TUI, compute the build matrix and save \+ \it to FILE")+ fromRecordOption = filesGroup+ $ option str (long "from-record" <> metavar "FILE"+ <> help "View the results from FILE previously collected by \+ \--to-record")+ toRecordOption = filesGroup+ $ option str (long "to-record" <> metavar "FILE"+ <> help "Instead of running the TUI, run the builds and collect their \+ \results into FILE")++ noRunOptions = Left "-j|--jobs N is required when not using --from-record, \+ \--to-expr, or --to-matrix"+ filesGroup = parserOptionGroup "Working with files:"++runOptions :: Parser RunOptions+runOptions = parserOptionGroup "Running Cabal:" $ RunOptions+ <$> jobsOption+ <*> cabalExecutableOption+ <*> stepsOptions+ <*> optionsOptions+ <*> targetsOptions+ <*> modeOption+ where+ modeOption = flag ProjectBuild InstallLib (long "install-lib"+ <> help "Use cabal install --lib instead of cabal build, allowing \+ \targeting libraries directly from hackage, without a local project")+ jobsOption = option auto (long "jobs" <> short 'j' <> metavar "N"+ <> help "How many instances of cabal to run concurrently")+ optionsOptions = many $ option str (long "option" <> metavar "--OPTION"+ <> help "Pass an option to cabal in all configurations")+ targetsOptions = many $ argument str (metavar "TARGET"+ <> help "Targets to tell cabal to build")+ stepsOptions = PerCabalStep+ <$> flag True False (long "no-dry-run"+ <> help "Skip the --dry-run build step, where only a plan is created")+ <*> flag True False (long "no-only-download"+ <> help "Skip the --only-download step, where a plan is created and \+ \packages are only downloaded")+ <*> flag True False (long "no-only-dependencies"+ <> help "Skip the --only-dependencies step, where a plan is created \+ \but only the dependencies are built")+ <*> flag True False (long "no-full-build"+ <> help "Skip the normal build, where the selected targets are fully \+ \built")+ cabalExecutableOption = optional $ option auto (metavar "PATH"+ <> help "Use the specified cabal executable. Defaults to $CABAL or \+ \whichever \"cabal\" exists in $PATH.")++data MatrixOption+ = OpenParen+ | CloseParen+ | Expr Text MatrixExpr+ | BinOp Text (MatrixExpr -> MatrixExpr -> MatrixExpr)++unflatten :: [MatrixOption] -> Either Text MatrixExpr+unflatten input = case runStateT (term False) input of+ Left err -> Left err+ Right (output, []) -> Right output+ Right (_, CloseParen:_) -> Left "More closing parens than open"+ Right (_, opt:_) -> Left $ "Unexpected " <> describe opt <> " at end of input"+ where+ term paren = atom >>= termSuffix paren+ termSuffix paren e = StateT \case+ BinOp _ b:xs -> do+ (e', xs') <- runStateT atom xs+ runStateT (termSuffix paren (b e e')) xs'+ xs@(CloseParen:_) -> pure (e, xs)+ xs@[] -> pure (e, xs)+ opt:_ -> Left $ "Expected " <> describeBinOp+ <> (if paren then ", " <> describe CloseParen <> ", " else " ")+ <> "or end of input after list expression, got " <> describe opt+ atom = StateT \case+ OpenParen:xs -> do+ (e, xs') <- runStateT (term True) xs+ case xs' of+ CloseParen:xs'' -> pure (e, xs'')+ [] -> Left "More open parens than closing parens"+ opt:_ -> Left+ $ "Unexpected " <> describe opt <> " after list expression"+ Expr _ e:xs -> pure (e, xs)+ opt:_ -> Left $ "Expecting " <> describeExpr <> " or "+ <> describe OpenParen <> ", got " <> describe opt+ [] -> Left $ "Expecting " <> describeExpr <> " or "+ <> describe OpenParen <> ", got end of input"++ describe = \case+ OpenParen -> "open paren (--[)"+ CloseParen -> "closing paren (--])"+ Expr name _ -> "list option (" <> name <> ")"+ BinOp name _ -> "binary operator option (" <> name <> ")"+ describeExpr = "list option (--compiler, --package, etc)"+ describeBinOp = "binary operator option (--times, --add, etc)"++frameOptions :: Parser (Either Text MatrixExpr)+frameOptions = parserOptionGroup "Specifying configurations:"+ $ unflatten <$> many frameOption+ where+ frameOption = asum+ [ asum+ [ Expr "--compiler" . CompilersExpr <$> option readCompilers+ (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,..."+ <> 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'")+ , Expr "--prefer" . PreferExpr <$> option readPrefer+ (long "prefer" <> metavar "[newest],[oldest]"+ <> help "Specify whether to try newest or oldest versions of \+ \packages, or both")+ ]+ , asum+ [ flag' (BinOp "--times" TimesExpr)+ (long "times" <> style (\doc -> "LIST" <+> doc <+> "LIST")+ <> help "Take the cartesian product of two lists")+ , flag' (BinOp "--add" AddExpr)+ (long "add" <> style (\doc -> "LIST" <+> doc <+> "LIST")+ <> help "Append the two lists, merging common fields")+ , flag' (BinOp "--subtract" SubtractExpr)+ (long "subtract" <> style (\doc -> "LIST" <+> doc <+> "LIST")+ <> help "Remove from the first list everything that is covered by \+ \the second list")+ , flag' (BinOp "--seq" SeqExpr)+ (long "seq" <> style (\doc -> "LIST" <+> doc <+> "LIST")+ <> help "Append the two lists, appending columns even if common")+ ]+ , asum+ [ flag' (Expr "--default" UnitExpr)+ (long "default"+ <> help "A single build without any additional options")+ , Expr "--custom-options" . uncurry CustomUnorderedExpr+ <$> option readCustom+ (long "custom-options" <> metavar "NAME=--opt1,--opt2,..."+ <> help "A single build with all of the provided options. NAME is \+ \the field name, which defines how this build is categorized in \+ \the matrix. --add'ing multiple --custom-options with the same \+ \NAME can be used to create a list.")+ , Expr "--custom-ordered-options" . uncurry CustomOrderedExpr+ <$> option readCustom+ (long "custom-ordered-options" <> metavar "NAME=--opt1,--opt2,..."+ <> help "A single build with the provided options, for options \+ \that are order-sensitive. The provided options are appended \+ \after all other options.")+ ]+ , flag' OpenParen+ (long "[" <> style (\_ -> "--[ LIST --]")+ <> help "Operations are evaluated from left to right \+ \(left-associative). Brackets can be used to correct the order of \+ \operations")+ , flag' CloseParen (long "]" <> hidden)+ ]++readCompilers :: ReadM [Compiler]+readCompilers+ = map Compiler . filter (not . null) <$> commaSeparated (strip <$> str)++readPrefer :: ReadM [Prefer]+readPrefer = commaSeparated $ maybeReader \(map toLower . strip -> s) -> if+ | s `elem` ["newest", "newer", "new"] -> Just PreferNewest+ | s `elem` ["oldest", "older", "old"] -> Just PreferOldest+ | otherwise -> Nothing++readPackage :: ReadM (PackageName, [Either Version VersionRange])+readPackage = byEquals+ (mkPackageName . strip <$> str)+ (commaSeparated versionOrRange)+ where+ versionOrRange = ReadM $ ReaderT \s -> case eitherParsec @Version s of+ Right ver -> pure $ Left ver+ Left err1 -> case eitherParsec @VersionRange s of+ Right range -> pure $ Right range+ Left err2 -> throwE $ ErrorMsg $ unlines+ ["Expected a version or a version range: ", err1, err2]++readCustom :: ReadM (Text, [Text])+readCustom = byEquals+ (Text.strip <$> str)+ (filter (not . Text.null) <$> commaSeparated (Text.strip <$> str))++byEquals :: ReadM a -> ReadM b -> ReadM (a, b)+byEquals (ReadM (ReaderT pk)) (ReadM (ReaderT pv)) = ReadM $ ReaderT \s -> if+ | (prefix, _:suffix) <- break (=='=') s -> (,) <$> pk prefix <*> pv suffix+ | otherwise -> throwE $ ErrorMsg "Expected key=value pair"++commaSeparated :: ReadM a -> ReadM [a]+commaSeparated (ReadM (ReaderT p)) = ReadM $ ReaderT \s -> for (splitOn "," s) p++strip :: String -> String+strip = Text.unpack . Text.strip . Text.pack
+ src/Cabal/Matrix/Files.hs view
@@ -0,0 +1,282 @@+module Cabal.Matrix.Files+ ( writeExprFile+ , readExprFile+ , writeMatrixFile+ , readMatrixFile+ , writeRecordFile+ , readRecordFile+ ) where++import Cabal.Matrix.CabalArgs+import Cabal.Matrix.Matrix+import Cabal.Matrix.Record+import Cabal.Matrix.Rectangle qualified as Rectangle+import Data.Aeson+import Data.Aeson qualified as Aeson+import Data.Aeson.Encoding qualified as Encoding+import Data.Aeson.Types+import Data.Foldable+import Data.Functor+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Distribution.Parsec+import Distribution.Pretty+import Distribution.Types.PackageName+import Distribution.Types.Version+import Distribution.Types.VersionRange+import System.Exit+++newtype PreferJSON = PreferJSON Prefer++instance ToJSON PreferJSON where+ toJSON = \case+ PreferJSON PreferOldest -> "old"+ PreferJSON PreferNewest -> "new"++instance FromJSON PreferJSON where+ parseJSON = withText "Prefer" \case+ "old" -> pure $ PreferJSON PreferOldest+ "new" -> pure $ PreferJSON PreferNewest+ _ -> fail "Expected \"old\" or \"new\""++newtype VersionJSON = VersionJSON (Either Version VersionRange)++instance ToJSON VersionJSON where+ toJSON = \case+ VersionJSON (Left version) -> toJSON $ prettyShow version+ VersionJSON (Right range) -> toJSON $ prettyShow range++instance FromJSON VersionJSON where+ parseJSON = withText "Version" \(Text.unpack -> s)+ -> VersionJSON <$> case eitherParsec @Version s of+ Right ver -> pure $ Left ver+ Left err1 -> case eitherParsec @VersionRange s of+ Right range -> pure $ Right range+ Left err2 -> fail $ unlines+ ["Expected a version or a version range: ", err1, err2]++newtype MatrixExprJSON = MatrixExprJSON MatrixExpr++instance ToJSON MatrixExprJSON where+ 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)+ ]+ UnitExpr -> "unit"+ CompilersExpr compilers -> object+ [ "compilers" .= toJSON+ (compilers <&> \(Compiler compiler) -> compiler)+ ]+ PreferExpr values -> object+ [ "prefer" .= toJSON (PreferJSON <$> values)+ ]+ PackageVersionExpr packageName versions -> object+ [ "package" .= unPackageName packageName+ , "versions" .= toJSON (VersionJSON <$> versions)+ ]+ CustomUnorderedExpr key options -> object+ [ "custom_unordered" .= key+ , "options" .= toJSON options+ ]+ CustomOrderedExpr key options -> object+ [ "custom_ordered" .= key+ , "options" .= toJSON options+ ]++instance FromJSON MatrixExprJSON where+ parseJSON (String "unit") = pure $ MatrixExprJSON UnitExpr+ parseJSON (String _) = fail "Expected string to be \"unit\""+ parseJSON (Object o) = do+ parses <- sequenceA+ [ (o .:? "times") <&> fmap @Maybe+ \(MatrixExprJSON x, MatrixExprJSON y) -> TimesExpr x y+ , (o .:? "add") <&> fmap @Maybe+ \(MatrixExprJSON x, MatrixExprJSON y) -> AddExpr x y+ , (o .:? "subtract") <&> fmap @Maybe+ \(MatrixExprJSON x, MatrixExprJSON y) -> SubtractExpr x y+ , (o .:? "seq") <&> fmap @Maybe+ \(MatrixExprJSON x, MatrixExprJSON y) -> SeqExpr x y+ , (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 .:? "custom_unordered" >>= \case+ Nothing -> pure Nothing+ Just key -> o .:? "options" >>= \case+ Just options -> pure $ Just $ CustomUnorderedExpr key options+ Nothing -> fail+ "Expected \"custom_unordered\" to be accompanied by \"options\""+ , o .:? "custom_ordered" >>= \case+ Nothing -> pure Nothing+ Just key -> o .:? "options" >>= \case+ Just options -> pure $ Just $ CustomOrderedExpr key options+ Nothing -> fail+ "Expected \"custom_ordered\" to be accompanied by \"options\""+ ]+ case catMaybes parses of+ [x] -> pure $ MatrixExprJSON x+ _ -> fail "Expected exactly one of: \"times\", \"add\", \"subtract\", \+ \\"seq\", \"compilers\", \"prefer\", \"package\", \+ \\"custom_unordered\", \"custom_ordered\""+ parseJSON v = typeMismatch "Object or String" v++writeExprFile :: FilePath -> MatrixExpr -> IO ()+writeExprFile file = Aeson.encodeFile @MatrixExprJSON file . MatrixExprJSON++readExprFile :: FilePath -> IO MatrixExpr+readExprFile file = Aeson.eitherDecodeFileStrict @MatrixExprJSON file >>= \case+ Left err -> fail err+ Right (MatrixExprJSON expr) -> pure expr++newtype MatrixRowJSON = MatrixRowJSON (Flavor, Map Text Text)++instance ToJSON MatrixRowJSON where+ toJSON (MatrixRowJSON (flavor, row)) = object+ [ "ordered_options" .= flavor.orderedOptions+ , "unordered_options" .= flavor.unorderedOptions+ , "flavor" .= row+ ]++instance FromJSON MatrixRowJSON where+ parseJSON = withObject "MatrixRow" \o -> do+ orderedOptions <- o .: "ordered_options"+ unorderedOptions <- o .: "unordered_options"+ flavor <- o .: "flavor"+ pure $ MatrixRowJSON (Flavor{..}, flavor)++newtype MatrixJSON = MatrixJSON Matrix++instance ToJSON MatrixJSON where+ toJSON (MatrixJSON matrix) = toJSON+ [ MatrixRowJSON (flavor, Map.fromList $ mapMaybe sequenceA row)+ | (flavor, row) <- Rectangle.toRowMajor matrix+ ]++instance FromJSON MatrixJSON where+ parseJSON v = MatrixJSON <$> do+ !rows <- parseJSON v+ let+ !cols = Set.toList $ Set.unions+ [ Map.keysSet row+ | MatrixRowJSON (_, row) <- rows+ ]+ !matrix = Rectangle.fromRowMajor cols+ [ ( flavor+ , [Map.lookup col row | col <- cols]+ )+ | MatrixRowJSON (flavor, row) <- rows+ ]+ pure matrix++writeMatrixFile :: FilePath -> Matrix -> IO ()+writeMatrixFile file = Aeson.encodeFile @MatrixJSON file . MatrixJSON++readMatrixFile :: FilePath -> IO Matrix+readMatrixFile file = Aeson.eitherDecodeFileStrict @MatrixJSON file >>= \case+ Left err -> fail err+ Right (MatrixJSON matrix) -> pure matrix++newtype StepResultJSON = StepResultJSON StepResult++instance ToJSON StepResultJSON where+ toJSON (StepResultJSON result) = object+ [ "cmdline" .= result.cmdline+ , "output" .= result.output+ , "exit_code" .= case result.exitCode of+ ExitSuccess -> 0+ ExitFailure code -> code+ ]+ -- Have to manually define toEncoding to force field ordering.+ toEncoding (StepResultJSON result) = Encoding.pairs $ mconcat+ [ Encoding.pair "cmdline" $ toEncoding result.cmdline+ , Encoding.pair "output" $ toEncoding result.output+ , Encoding.pair "exit_code" $ toEncoding case result.exitCode of+ ExitSuccess -> 0+ ExitFailure code -> code+ ]++instance FromJSON StepResultJSON where+ parseJSON = Aeson.withObject "StepResult" \o -> do+ cmdline <- o Aeson..: "cmdline"+ output <- o Aeson..: "output"+ exitCode <- o Aeson..: "exit_code" <&> \case+ 0 -> ExitSuccess+ code -> ExitFailure code+ pure $ StepResultJSON StepResult{..}++newtype FlavorResultJSON = FlavorResultJSON FlavorResult++instance ToJSON FlavorResultJSON where+ toJSON (FlavorResultJSON result) = object $ catMaybes+ [ ("flavor" .=) <$> Just result.flavor+ , ("dry_run" .=) . StepResultJSON+ <$> result.steps.dryRun+ , ("only_download" .=) . StepResultJSON+ <$> result.steps.onlyDownload+ , ("only_dependencies" .=) . StepResultJSON+ <$> result.steps.onlyDependencies+ , ("full_build" .=) . StepResultJSON+ <$> result.steps.fullBuild+ ]+ -- Have to manually define toEncoding to force field ordering.+ toEncoding (FlavorResultJSON result) = Encoding.pairs $ fold+ [ Encoding.pair "flavor" $ toEncoding result.flavor+ , foldMap (Encoding.pair "dry_run" . toEncoding)+ $ StepResultJSON <$> result.steps.dryRun+ , foldMap (Encoding.pair "only_download" . toEncoding)+ $ StepResultJSON <$> result.steps.onlyDownload+ , foldMap (Encoding.pair "only_dependencies" . toEncoding)+ $ StepResultJSON <$> result.steps.onlyDependencies+ , foldMap (Encoding.pair "full_build" . toEncoding)+ $ StepResultJSON <$> result.steps.fullBuild+ ]++instance FromJSON FlavorResultJSON where+ parseJSON = withObject "FlavorResult" \o -> do+ flavor <- o .: "flavor"+ dryRun <- o .:? "dry_run"+ onlyDownload <- o .:? "only_download"+ onlyDependencies <- o .:? "only_dependencies"+ fullBuild <- o .:? "full_build"+ pure $ FlavorResultJSON FlavorResult+ { flavor+ , steps = PerCabalStep{..}+ <&> fmap @Maybe \(StepResultJSON result) -> result+ }++writeRecordFile :: FilePath -> [FlavorResult] -> IO ()+writeRecordFile file = Aeson.encodeFile @[FlavorResultJSON] file+ . map FlavorResultJSON++readRecordFile :: FilePath -> IO [FlavorResult]+readRecordFile file = Aeson.eitherDecodeFileStrict @[FlavorResultJSON] file+ >>= \case+ Left err -> fail err+ Right results -> pure $ results <&> \(FlavorResultJSON result) -> result
+ src/Cabal/Matrix/Main.hs view
@@ -0,0 +1,56 @@+module Cabal.Matrix.Main+ ( main+ ) where++import Cabal.Matrix.Cli+import Cabal.Matrix.Files+import Cabal.Matrix.Matrix+import Cabal.Matrix.Record+import Cabal.Matrix.Tui+import Data.Text (Text)+import Data.Text qualified as Text+import Options.Applicative++main :: IO ()+main = do+ cliOptions <- execParser cliParser+ case cliOptions of+ Left err -> showCliError err+ Right ExprToExpr{ exprSource, outFile } -> do+ expr <- getExpr exprSource+ expr' <- resolveMatrixExpr expr+ writeExprFile outFile expr'+ Right ExprToMatrix{ exprSource, outFile } -> do+ expr <- getExpr exprSource+ matrix <- evalMatrixExpr expr+ writeMatrixFile outFile matrix+ Right ExprToRecord{ exprSource, runParams, outFile } -> do+ expr <- getExpr exprSource+ matrix <- evalMatrixExpr expr+ results <- record matrix runParams+ writeRecordFile outFile results+ Right ExprToTui{ exprSource, runParams } -> do+ expr <- getExpr exprSource+ matrix <- evalMatrixExpr expr+ tuiLive matrix runParams+ Right MatrixToRecord{ matrixFile, runParams, outFile } -> do+ matrix <- readMatrixFile matrixFile+ results <- record matrix runParams+ writeRecordFile outFile results+ Right MatrixToTui{ matrixFile, runParams } -> do+ matrix <- readMatrixFile matrixFile+ tuiLive matrix runParams+ Right RecordToTui{ recordFile } -> do+ results <- readRecordFile recordFile+ tuiRecording results++getExpr :: ExprSource -> IO MatrixExpr+getExpr = \case+ ExprArgs (Left err) -> showCliError err+ ExprArgs (Right expr) -> pure expr+ ExprFile file -> readExprFile file++showCliError :: Text -> IO a+showCliError err = handleParseResult+ $ Failure $ parserFailure defaultPrefs cliParser+ (ErrorMsg $ Text.unpack err) mempty
+ src/Cabal/Matrix/Matrix.hs view
@@ -0,0 +1,187 @@+module Cabal.Matrix.Matrix where++import Cabal.Matrix.CabalArgs+import Cabal.Matrix.Rectangle (Rectangle)+import Cabal.Matrix.Rectangle qualified as Rectangle+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Distribution.Client.Config+import Distribution.Client.GlobalFlags+import Distribution.Client.IndexUtils+import Distribution.Client.Sandbox+import Distribution.Client.Types.SourcePackageDb+import Distribution.Package+import Distribution.Pretty+import Distribution.Solver.Types.PackageIndex qualified as PackageIndex+import Distribution.Verbosity qualified as Verbosity+import Distribution.Version+++-- | A build matrix is represented by a rectangle, where properties that we+-- iterate over correspond to columns (first 'Text'), and desired combinations+-- of values of those properties (second 'Text') correspond to rows. Each row is+-- then marked with the collection of options that this combination of choices+-- produces (the 'Flavor').+type Matrix = Rectangle Flavor Text (Maybe Text)++timesMatrix :: Matrix -> Matrix -> Matrix+timesMatrix = Rectangle.productRows (<>)++addMatrix :: Matrix -> Matrix -> Matrix+addMatrix = Rectangle.appendRowsUnioningColumns Nothing++subtractMatrix :: Matrix -> Matrix -> Matrix+subtractMatrix = Rectangle.subtractRowsBySubsetColumns++seqMatrix :: Matrix -> Matrix -> Matrix+seqMatrix m1 m2 = Rectangle.blockDiagonal m1 Nothing Nothing m2++unitMatrix :: Matrix+unitMatrix = Rectangle.unitRow mempty++newtype Compiler = Compiler FilePath+ deriving newtype (Show)++compilersMatrix :: [Compiler] -> Matrix+compilersMatrix compilers = Rectangle.vertical "COMPILER"+ [ ( Flavor+ { unorderedOptions = Set.singleton ("--with-compiler=" <> compiler)+ , orderedOptions = []+ }+ , Just compiler+ )+ | Compiler (Text.pack -> compiler) <- compilers+ ]++data Prefer = PreferOldest | PreferNewest+ deriving stock (Eq, Show)++preferMatrix :: [Prefer] -> Matrix+preferMatrix values = Rectangle.vertical "PREFER"+ [ ( Flavor+ { unorderedOptions = if value == PreferOldest+ then Set.singleton "--prefer-oldest"+ else Set.empty+ , orderedOptions = []+ }+ , Just case value of+ PreferOldest -> "oldest"+ PreferNewest -> "newest"+ )+ | value <- values+ ]++packageVersionMatrix :: PackageName -> [Version] -> Matrix+packageVersionMatrix (Text.pack . unPackageName -> package) versions+ = Rectangle.vertical package+ [ ( Flavor+ { unorderedOptions = Set.singleton+ $ "--constraint=" <> package <> "==" <> version+ , orderedOptions = []+ }+ , Just version+ )+ | version <- Text.pack . prettyShow <$> versions+ ]++customUnorderedOptions :: Text -> [Text] -> Matrix+customUnorderedOptions name options = Rectangle.vertical name+ [ ( Flavor+ { unorderedOptions = Set.fromList options+ , orderedOptions = []+ }+ , Just $ Text.unwords options+ )+ ]++customOrderedOptions :: Text -> [Text] -> Matrix+customOrderedOptions name options = Rectangle.vertical name+ [ ( Flavor+ { unorderedOptions = Set.empty+ , orderedOptions = options+ }+ , Just $ Text.unwords options+ )+ ]++-- | 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.+data MatrixExpr+ = TimesExpr MatrixExpr MatrixExpr+ | AddExpr MatrixExpr MatrixExpr+ | SubtractExpr MatrixExpr MatrixExpr+ | SeqExpr MatrixExpr MatrixExpr+ | UnitExpr+ | CompilersExpr [Compiler]+ | PreferExpr [Prefer]+ | PackageVersionExpr PackageName [Either Version VersionRange]+ | CustomUnorderedExpr Text [Text]+ | CustomOrderedExpr Text [Text]++-- | Evaluating the build matrix expression may require access to the source+-- package DB, but if it doesn't, we'd like to avoid loading it.+data EvalM a = EvalPure a | EvalWithDB (SourcePackageDb -> a)+ deriving stock (Functor)++instance Applicative EvalM where+ pure = EvalPure+ EvalPure f <*> EvalPure x = EvalPure (f x)+ EvalPure f <*> EvalWithDB x = EvalWithDB \db -> f (x db)+ EvalWithDB f <*> EvalPure x = EvalWithDB \db -> f db x+ EvalWithDB f <*> EvalWithDB x = EvalWithDB \db -> f db (x db)++runEvalM :: EvalM a -> IO a+runEvalM = \case+ EvalPure x -> pure $! x+ EvalWithDB f -> withDB \db -> pure $! f db+ where+ withDB :: (SourcePackageDb -> IO a) -> IO a+ withDB k = do+ config <- loadConfigOrSandboxConfig verbosity defaultGlobalFlags+ withRepoContext verbosity config.savedGlobalFlags \repo -> do+ getSourcePackages verbosity repo >>= k+ 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++evalMatrixExpr :: MatrixExpr -> IO Matrix+evalMatrixExpr = runEvalM . go+ where+ go = \case+ TimesExpr m1 m2 -> timesMatrix <$> go m1 <*> go m2+ AddExpr m1 m2 -> addMatrix <$> go m1 <*> go m2+ SubtractExpr m1 m2 -> subtractMatrix <$> go m1 <*> go m2+ SeqExpr m1 m2 -> seqMatrix <$> go m1 <*> go m2+ UnitExpr -> EvalPure unitMatrix+ CompilersExpr compilers -> EvalPure $ compilersMatrix compilers+ PreferExpr values -> EvalPure $ preferMatrix values+ PackageVersionExpr package versions+ -> packageVersionMatrix package <$> evalVersionRanges package versions+ CustomUnorderedExpr name values+ -> EvalPure $ customUnorderedOptions name values+ CustomOrderedExpr name values+ -> EvalPure $ customOrderedOptions name values++resolveMatrixExpr :: MatrixExpr -> IO MatrixExpr+resolveMatrixExpr = runEvalM . go+ where+ go = \case+ TimesExpr m1 m2 -> TimesExpr <$> go m1 <*> go m2+ AddExpr m1 m2 -> AddExpr <$> go m1 <*> go m2+ SubtractExpr m1 m2 -> SubtractExpr <$> go m1 <*> go m2+ SeqExpr m1 m2 -> SeqExpr <$> go m1 <*> go m2+ e@UnitExpr -> pure e+ e@(CompilersExpr _) -> pure e+ e@(PreferExpr _) -> pure e+ PackageVersionExpr package versions+ -> PackageVersionExpr package . map Left+ <$> evalVersionRanges package versions+ e@(CustomUnorderedExpr _ _) -> pure e+ e@(CustomOrderedExpr _ _) -> pure e
+ src/Cabal/Matrix/ProcessRunner.hs view
@@ -0,0 +1,101 @@+-- | Run a single process and provide a live view of its output and termination.+module Cabal.Matrix.ProcessRunner+ ( startProcess+ , ProcessMessage(..)+ , OutputChannel(..)+ , ProcessHandle+ , signalProcess+ , ProcessSignal(..)+ ) where++import Control.Concurrent+import Control.Exception.Safe+import Control.Monad+import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.Foldable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics+import System.Exit+import System.IO+import System.Process qualified as Process+++data OutputChannel = Stdout | Stderr+ deriving stock (Eq, Show, Generic)++instance ToJSON OutputChannel where+ toJSON = \case+ Stdout -> "stdout"+ Stderr -> "stderr"++instance FromJSON OutputChannel where+ parseJSON = Aeson.withText "OutputChannel" \case+ "stdout" -> pure Stdout+ "stderr" -> pure Stderr+ v -> fail $ "Unexpected value: " <> show v+++data ProcessMessage+ = OnProcessOutput OutputChannel ByteString+ -- ^ Note: Always sequenced before 'OnChannelClosed', but may be sequenced+ -- after 'OnProcessExit'.+ | OnChannelClosed OutputChannel+ -- ^ Note: may be sequenced after 'OnProcessExit'.+ | OnProcessExit ExitCode++data ProcessSignal+ = SignalInterrupt+ -- ^ Attempt to interrupt the process with @SIGINT@.+ | SignalTerminate+ -- ^ Attempt to interrupt the process with @SIGTERM@.++newtype ProcessHandle = ProcessHandle Process.ProcessHandle++-- | Start a process with the given commandline arguments in the background.+-- The provided callback will be called (from other threads) when things happen+-- to the process.+--+-- Note: if the current program should be compiled with @-threaded@, see+-- 'Process.waitForProcess'.+--+-- A process can be considered finished and its resources cleaned up after+-- receiving all three of @'OnChannelClosed' 'Stdout'@,+-- @'OnChannelClosed' 'Stderr'@, and 'OnProcessExit'.+startProcess :: NonEmpty Text -> (ProcessMessage -> IO ()) -> IO ProcessHandle+startProcess cmdline cb = mask_ do+ (_mIn, mOut, mErr, processHdl) <- Process.createProcess+ case Text.unpack <$> cmdline of+ cmd :| args -> (Process.proc cmd args)+ { Process.std_out = Process.CreatePipe+ , Process.std_err = Process.CreatePipe+ }+ _ <- forkIOWithUnmask \unmask -> do+ for_ mOut (\out -> unmask $ readLoop out Stdout)+ `finally` cb (OnChannelClosed Stdout)+ _ <- forkIOWithUnmask \unmask -> do+ for_ mErr (\err -> unmask $ readLoop err Stderr)+ `finally` cb (OnChannelClosed Stderr)+ _ <- forkIOWithUnmask \unmask -> do+ unmask (Process.waitForProcess processHdl >>= cb . OnProcessExit)+ `onException` Process.terminateProcess processHdl+ pure $ ProcessHandle processHdl+ where+ readLoop :: Handle -> OutputChannel -> IO ()+ readLoop hdl chan = do+ bs <- ByteString.hGetSome hdl 0x10000+ unless (ByteString.null bs) do+ cb $ OnProcessOutput chan bs+ readLoop hdl chan++-- | Send a signal to the process.+signalProcess :: ProcessHandle -> ProcessSignal -> IO ()+signalProcess (ProcessHandle processHdl) = \case+ SignalInterrupt -> Process.interruptProcessGroupOf processHdl+ SignalTerminate -> Process.terminateProcess processHdl++
+ src/Cabal/Matrix/Record.hs view
@@ -0,0 +1,135 @@+module Cabal.Matrix.Record+ ( RunOptions(..)+ , record+ , StepResult(..)+ , FlavorResult(..)+ ) where++import Cabal.Matrix.CabalArgs+import Cabal.Matrix.Cli+import Cabal.Matrix.Matrix+import Cabal.Matrix.ProcessRunner+import Cabal.Matrix.Rectangle qualified as Rectangle+import Cabal.Matrix.Scheduler+import Control.Concurrent+import Control.Monad+import Data.ByteString (ByteString)+import Data.Foldable+import Data.Function+import Data.IORef+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Primitive+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Text.IO qualified as Text+import System.Exit+import System.IO+++data StaticFlavorResult = StaticFlavorResult+ { flavor :: Map Text Text+ , cmdlines :: PerCabalStep (NonEmpty Text)+ }++data StepState = StepState+ { started :: Bool+ , revOutput :: [(OutputChannel, ByteString)]+ , exit :: Maybe ExitCode+ }++collapseOutput :: [(OutputChannel, ByteString)] -> [(OutputChannel, ByteString)]+collapseOutput = map (\grp -> (fst $ NonEmpty.head grp, foldMap snd grp))+ . NonEmpty.groupBy ((==) `on` fst)++record :: Matrix -> RunOptions -> IO [FlavorResult]+record matrix options = do+ schedulerConfig <- getSchedulerConfig options+ let+ !flavors = Rectangle.rows matrix+ !statics = arrayFromListN (sizeofArray flavors)+ [ StaticFlavorResult+ { flavor = Map.fromList $ mapMaybe sequenceA pairs+ , cmdlines = tabulateCabalStep' \step+ -> renderCabalArgs $ mkCabalArgs schedulerConfig step flavor+ }+ | (flavor, pairs) <- Rectangle.toRowMajor matrix+ ]++ results <- flip traverseArrayP flavors+ \_ -> sequenceA $ tabulateCabalStep' \_ -> newIORef StepState+ { started = False+ , revOutput = []+ , exit = Nothing+ }+ doneVar <- newEmptyMVar+ _ <- startScheduler schedulerConfig flavors+ \case+ OnDone -> putMVar doneVar ()+ OnStepStarted{ flavorIndex, step } -> atomicModifyIORef'+ (indexCabalStep (indexArray results flavorIndex) step)+ \state -> (state { started = True }, ())+ OnStepFinished{ flavorIndex, step, exitCode } -> do+ atomicModifyIORef'+ (indexCabalStep (indexArray results flavorIndex) step)+ \state -> (state { exit = Just exitCode }, ())+ Text.hPutStrLn stderr $ prettyStepFinished+ (snd $ Rectangle.indexRow matrix flavorIndex) step exitCode+ OnOutput{ flavorIndex, step, channel, output } -> atomicModifyIORef'+ (indexCabalStep (indexArray results flavorIndex) step)+ \state+ -> (state { revOutput = (channel, output):state.revOutput }, ())++ takeMVar doneVar+ frozenResults <- traverseArrayP (traverse readIORef) results+ pure $ zipWith mkFlavorResult (toList statics) (toList frozenResults)++prettyStepFinished :: [(Text, Maybe Text)] -> CabalStep -> ExitCode -> Text+prettyStepFinished flavor step exit+ = prettyStep <> " " <> prettyExit <> " for {" <> prettyFlavor <> "}"+ where+ prettyStep = case step of+ DryRun -> "plan"+ OnlyDownload -> "download"+ OnlyDependencies -> "dependencies"+ FullBuild -> "build"+ prettyExit = case exit of+ ExitSuccess -> "ok"+ ExitFailure _ -> "failed"+ prettyFlavor = Text.intercalate ","+ [ Text.pack (show key) <> ": " <> Text.pack (show value)+ | (key, Just value) <- flavor+ ]++-- | The ultimate result of having completed a single step of a single flavor.+data StepResult = StepResult+ { cmdline :: NonEmpty Text+ , output :: [(OutputChannel, Text)]+ , exitCode :: ExitCode+ }++data FlavorResult = FlavorResult+ { flavor :: Map Text Text+ , steps :: PerCabalStep (Maybe StepResult)+ }++mkFlavorResult :: StaticFlavorResult -> PerCabalStep StepState -> FlavorResult+mkFlavorResult StaticFlavorResult{..} pcs = FlavorResult+ { flavor+ , steps = tabulateCabalStep' mk+ }+ where+ mk step+ | !state <- indexCabalStep pcs step+ , !cmdline <- indexCabalStep cmdlines step+ = do+ guard state.started+ exitCode <- state.exit+ let+ output = map (fmap Text.decodeUtf8Lenient)+ $ collapseOutput $ reverse state.revOutput+ pure StepResult{..}
+ src/Cabal/Matrix/Rectangle.hs view
@@ -0,0 +1,390 @@+-- | Designed for qualified import. Operations are strict.+module Cabal.Matrix.Rectangle+ ( Rectangle(..)+ , rows+ , indexRow+ , toRowMajor+ , fromRowMajor+ , mapRows+ , columns+ , indexColumn+ , toColumnMajor+ , mapColumns+ , indexCell++ , unitRow+ , empty+ , vertical++ , productRows+ , blockDiagonal+ , appendRowsUnioningColumns+ , subtractRowsBySubsetColumns+ , unCartesianProduct+ ) where++import Control.Monad.ST+import Data.Foldable+import Data.IntSet qualified as IntSet+import Data.Map.Strict qualified as Map+import Data.Primitive+import Data.Set qualified as Set+++-- | A rectangle is a collection of rows of type @a@, columns of type @b@, and+-- for each row and column pair a cell of type @c@.+data Rectangle a b c = Rectangle+ {-# UNPACK #-} !(Array a)+ {-# UNPACK #-} !(Array b)+ {-# UNPACK #-} !(Array c)+ -- ^ INVARIANT: length of the third array is the product of the lengths of the+ -- first two+ deriving stock (Show, Functor)++rows :: Rectangle a b c -> Array a+rows (Rectangle rs _ _) = rs++indexRow :: Rectangle a b c -> Int -> (a, [(b, c)])+indexRow (Rectangle rs cs cells) y =+ ( indexArray rs y+ , [ (indexArray cs x, indexArray cells (y * width + x))+ | x <- [0 .. width - 1]+ ]+ )+ where+ !width = sizeofArray cs++toRowMajor :: Rectangle a b c -> [(a, [(b, c)])]+toRowMajor rect@(Rectangle rs _ _)+ = [indexRow rect y | y <- [0 .. height - 1]]+ where+ !height = sizeofArray rs++fromRowMajor :: [b] -> [(a, [c])] -> Rectangle a b c+fromRowMajor cols pairs = Rectangle rs cs cells+ where+ !cs = arrayFromList cols+ !width = sizeofArray cs+ !height = length pairs+ !rs = arrayFromListN height $ fst <$> pairs+ !cells = arrayFromListN (width * height)+ [ x+ | (_, row) <- pairs+ , x <- if length row == width+ then row+ else error "fromRowMajor: incorrect row width"+ ]++mapRows :: (a -> a') -> Rectangle a b c -> Rectangle a' b c+mapRows f (Rectangle rs cs cells) = Rectangle (mapArray' f rs) cs cells++columns :: Rectangle a b c -> Array b+columns (Rectangle _ cs _) = cs++indexColumn :: Rectangle a b c -> Int -> (b, [(a, c)])+indexColumn (Rectangle rs cs cells) x =+ ( indexArray cs x+ , [ (indexArray rs y, indexArray cells (y * width + x))+ | y <- [0 .. height - 1]+ ]+ )+ where+ !width = sizeofArray cs+ !height = sizeofArray rs++toColumnMajor :: Rectangle a b c -> [(b, [(a, c)])]+toColumnMajor rect@(Rectangle _ cs _)+ = [indexColumn rect x | x <- [0 .. width - 1]]+ where+ !width = sizeofArray cs++mapColumns :: (b -> b') -> Rectangle a b c -> Rectangle a b' c+mapColumns f (Rectangle rs cs cells) = Rectangle rs (mapArray' f cs) cells++indexCell :: Rectangle a b c -> Int -> Int -> c+indexCell (Rectangle _ cs cells) x y = indexArray cells (y * width + x)+ where+ !width = sizeofArray cs++unitRow :: a -> Rectangle a b c+unitRow !x = Rectangle (arrayFromListN 1 [x]) emptyArray emptyArray++empty :: Rectangle a b c+empty = Rectangle emptyArray emptyArray emptyArray++vertical :: b -> [(a, c)] -> Rectangle a b c+vertical c pairs = Rectangle+ (arrayFromList $ fst <$> pairs)+ (arrayFromListN 1 [c])+ (arrayFromList $ snd <$> pairs)++-- | Applies the function strictly+productRows+ :: (a -> a' -> a'')+ -> Rectangle a b c+ -> Rectangle a' b c+ -> Rectangle a'' b c+productRows combine (Rectangle rs cs cells) (Rectangle rs' cs' cells') =+ Rectangle+ (createArray height'' (error "urk") \m -> do+ for_ [0 .. height - 1] \y -> do+ let !r = (indexArray rs y)+ for_ [0 .. height' - 1] \y' -> do+ writeArray m (y * height' + y')+ $! combine r (indexArray rs' y'))+ (cs <> cs')+ (createArray (width'' * height'') (error "urk") \m -> do+ for_ [0 .. height - 1] \y -> do+ for_ [0 .. height' - 1] \y' -> do+ copyArray m ((y * height' + y') * width'')+ cells (y * width) width+ copyArray m ((y * height' + y') * width'' + width)+ cells' (y' * width') width')+ where+ !width = sizeofArray cs+ !width' = sizeofArray cs'+ !width'' = width + width'+ !height = sizeofArray rs+ !height' = sizeofArray rs'+ !height'' = height * height'++blockDiagonal :: Rectangle a b c -> c -> c -> Rectangle a b c -> Rectangle a b c+blockDiagonal (Rectangle rs cs cells) !tl !br (Rectangle rs' cs' cells') =+ Rectangle+ (rs <> rs')+ (cs <> cs')+ (createArray (width'' * height'') (error "urk") \m -> do+ for_ [0 .. height - 1] \y -> do+ copyArray m (y * width'')+ cells (y * width) width+ for_ [0 .. width' - 1] \x' -> do+ writeArray m (y * width'' + width + x') tl+ for_ [0 .. height' - 1] \y' -> do+ for_ [0 .. width - 1] \x -> do+ writeArray m ((height + y') * width'' + x) br+ copyArray m ((height + y') * width'' + width)+ cells' (y' * width') width'+ )+ where+ !width = sizeofArray cs+ !width' = sizeofArray cs'+ !width'' = width + width'+ !height = sizeofArray rs+ !height' = sizeofArray rs'+ !height'' = height + height'++data Source b c+ = FromNeither !b !c+ | FromLeft {-# UNPACK #-} !Int !c+ | FromRight {-# UNPACK #-} !Int !c+ | FromBoth {-# UNPACK #-} !Int {-# UNPACK #-} !Int (b -> b -> b)++appendRowsWithPairing+ :: Array (Source b c) -> Rectangle a b c -> Rectangle a b c -> Rectangle a b c+appendRowsWithPairing pairing (Rectangle rs cs cells) (Rectangle rs' cs' cells')+ = Rectangle+ (rs <> rs')+ (flip mapArray' pairing \case+ FromNeither c _ -> c+ FromLeft x _ -> indexArray cs x+ FromRight x' _ -> indexArray cs' x'+ FromBoth x x' combine -> combine (indexArray cs x) (indexArray cs' x'))+ (createArray (width'' * height'') (error "urk") \m -> do+ for_ [0 .. height - 1] \y -> do+ for_ [0 .. width'' - 1] \x'' -> do+ writeArray m (y * width'' + x'')+ $! case indexArray pairing x'' of+ FromNeither _ cell -> cell+ FromLeft x _ -> indexArray cells (y * width + x)+ FromRight _ cell -> cell+ FromBoth x _ _ -> indexArray cells (y * width + x)+ for_ [0 .. height' - 1] \y' -> do+ for_ [0 .. width'' - 1] \x'' -> do+ writeArray m ((height + y') * width'' + x'')+ $! case indexArray pairing x'' of+ FromNeither _ cell -> cell+ FromLeft _ cell -> cell+ FromRight x' _ -> indexArray cells' (y' * width' + x')+ FromBoth _ x' _ -> indexArray cells' (y' * width' + x'))+ where+ !width = sizeofArray cs+ !width' = sizeofArray cs'+ !width'' = sizeofArray pairing+ !height = sizeofArray rs+ !height' = sizeofArray rs'+ !height'' = height + height'++makePairing :: Ord b => c -> Array b -> Array b -> Array (Source b c)+makePairing dflt left right = arrayFromList $ go initMap initSet 0+ where+ !leftSize = sizeofArray left+ !rightSize = sizeofArray right+ !initMap = Map.fromListWith IntSet.union+ [ (indexArray right i, IntSet.singleton i)+ | i <- [0 .. rightSize - 1]+ ]+ !initSet = IntSet.fromDistinctAscList [0 .. rightSize - 1]++ go !m !s !i+ | i >= leftSize = (`FromRight` dflt) <$> IntSet.toAscList s+ | !l <- indexArray left i+ , Just js <- Map.lookup l m+ , (j, js') <- IntSet.deleteFindMin js+ = FromBoth i j const : go+ (if IntSet.null js' then Map.delete l m else Map.insert l js' m)+ (IntSet.delete j s) (i + 1)+ | otherwise = FromLeft i dflt : go m s (i + 1)++appendRowsUnioningColumns+ :: Ord b => c -> Rectangle a b c -> Rectangle a b c -> Rectangle a b c+appendRowsUnioningColumns dflt left right = appendRowsWithPairing+ (makePairing dflt (columns left) (columns right)) left right++filterRowsBySelector+ :: Array Int -> (Array c -> Bool) -> Rectangle a b c -> Rectangle a b c+filterRowsBySelector selector predicate (Rectangle rs cs cells) = runST do+ mrs' <- newArray height (error "urk")+ mcells' <- newArray (width * height) (error "urk")+ let+ go !y !y'+ | y >= height+ = do+ rs' <- freezeArray mrs' 0 y'+ cells' <- freezeArray mcells' 0 (y' * width)+ pure $ Rectangle rs' cs cells'+ | predicate $ mapArray' (\x -> indexArray cells (y * width + x)) selector+ = do+ writeArray mrs' y' (indexArray rs y)+ copyArray mcells' (y' * width) cells (y * width) width+ go (y + 1) (y' + 1)+ | otherwise+ = go (y + 1) y'+ go 0 0+ where+ !width = sizeofArray cs+ !height = sizeofArray rs++makeSelector :: Ord b => Array b -> Array b -> Maybe (Array Int)+makeSelector left right = go initMap 0 []+ where+ !leftSize = sizeofArray left+ !rightSize = sizeofArray right+ !initMap = Map.fromListWith IntSet.union+ [ (indexArray left i, IntSet.singleton i)+ | i <- [0 .. leftSize - 1]+ ]++ go !m !i out+ | i >= rightSize = Just $ arrayFromListN rightSize $ reverse out+ | !r <- indexArray right i+ , Just js <- Map.lookup r m+ , (!j, !js') <- IntSet.deleteFindMin js+ = go+ (if IntSet.null js' then Map.delete r m else Map.insert r js' m)+ (i + 1) (j:out)+ | otherwise = Nothing++cellsRowMajorArr :: Rectangle a b c -> [Array c]+cellsRowMajorArr (Rectangle rs cs cells) =+ [ cloneArray cells (y * width) width+ | y <- [0 .. height - 1]+ ]+ where+ !width = sizeofArray cs+ !height = sizeofArray rs++subtractRowsBySubsetColumns+ :: (Ord b, Ord c) => Rectangle a b c -> Rectangle a' b c -> Rectangle a b c+subtractRowsBySubsetColumns !rect !rect'+ = case makeSelector (columns rect) (columns rect') of+ Nothing -> rect+ Just selector+ | !rowSet <- Set.fromList $ cellsRowMajorArr rect'+ -> filterRowsBySelector selector (`Set.notMember` rowSet) rect++partitionByBitmaskAtOffset :: Array Bool -> Array a -> Int -> (Array a, Array a)+partitionByBitmaskAtOffset !bitmask !input !offset = runST do+ mfalses <- newArray len (error "urk")+ mtrues <- newArray len (error "urk")+ let+ go !f !t !i+ | i >= len = (,)+ <$> freezeArray mfalses 0 f+ <*> freezeArray mtrues 0 t+ | indexArray bitmask i = do+ writeArray mtrues t $ indexArray input (offset + i)+ go f (t + 1) (i + 1)+ | otherwise = do+ writeArray mfalses f $ indexArray input (offset + i)+ go (f + 1) t (i + 1)+ go 0 0 0+ where+ !len = sizeofArray bitmask++unCartesianProduct+ :: Ord c+ => Array Bool+ -> Rectangle a b c+ -> (Rectangle () b c, Rectangle () b c, Rectangle () () (Maybe Int))+unCartesianProduct bitmask (Rectangle rs cs cells) = runST do+ mfalses <- newArray (fwidth * height) (error "urk")+ mtrues <- newArray (twidth * height) (error "urk")+ mfis <- newPrimArray height+ mtis <- newPrimArray height+ let+ go !y !fMap !tMap+ | y >= height = do+ fcells <- freezeArray mfalses 0 (fwidth * fSize)+ tcells <- freezeArray mtrues 0 (twidth * tSize)+ let !frs = createArray fSize () \_ -> pure ()+ let !trs = createArray tSize () \_ -> pure ()+ icells <- do+ m <- newArray (fSize * tSize) Nothing+ for_ [0 .. height - 1] \i -> do+ fi <- readPrimArray mfis i+ ti <- readPrimArray mtis i+ writeArray m (ti * fSize + fi) (Just i)+ unsafeFreezeArray m+ pure+ ( Rectangle+ frs+ fcs+ fcells+ , Rectangle+ trs+ tcs+ tcells+ , Rectangle+ trs+ frs+ icells+ )+ | (!fc, !tc) <- partitionByBitmaskAtOffset bitmask cells (y * width)+ = do+ !fMap' <- case Map.lookup fc fMap of+ Nothing -> do+ copyArray mfalses (fSize * fwidth) fc 0 fwidth+ writePrimArray mfis y fSize+ pure $ Map.insert fc fSize fMap+ Just i -> do+ writePrimArray mfis y i+ pure fMap+ !tMap' <- case Map.lookup tc tMap of+ Nothing -> do+ copyArray mtrues (tSize * twidth) tc 0 twidth+ writePrimArray mtis y tSize+ pure $ Map.insert tc tSize tMap+ Just i -> do+ writePrimArray mtis y i+ pure tMap+ go (y + 1) fMap' tMap'+ where+ !fSize = Map.size fMap+ !tSize = Map.size tMap+ go 0 Map.empty Map.empty+ where+ !width = sizeofArray cs+ !height = sizeofArray rs+ (!fcs, !tcs) = partitionByBitmaskAtOffset bitmask cs 0+ !fwidth = sizeofArray fcs+ !twidth = sizeofArray tcs
+ src/Cabal/Matrix/Scheduler.hs view
@@ -0,0 +1,236 @@+-- | Execute multiple build steps on multiple 'Flavor's of a build, with live+-- progress and output updates.+--+-- The scheduler maintains a job queue of flavors (not steps), so that when it+-- starts work on a flavor, it goes through all of its steps. The scheduler can+-- be told to reprioritize a flavor that hasn't been started yet.+--+-- The scheduler is given an 'Array' of 'Flavor's, and subsequent communication+-- refers to flavors from this array by their index.+module Cabal.Matrix.Scheduler+ ( SchedulerConfig(..)+ , mkCabalArgs+ , FlavorIndex+ , startScheduler+ , SchedulerMessage(..)+ , SchedulerHandle+ , signalScheduler+ , SchedulerSignal(..)+ ) where++import Cabal.Matrix.CabalArgs+import Cabal.Matrix.ProcessRunner+import Control.Concurrent+import Control.Exception.Safe+import Control.Monad+import Data.ByteString (ByteString)+import Data.Foldable+import Data.List+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Primitive+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import System.Directory+import System.Exit+++data SchedulerConfig = SchedulerConfig+ { jobs :: Int+ -- ^ Number of flavors that could be building in parallel at a time.+ , options :: [Text]+ -- ^ Options to use in all builds.+ , targets :: [Text]+ , cabalExecutable :: FilePath+ , mode :: CabalMode+ , steps :: PerCabalStep Bool+ -- ^ Which build steps to run or skip.+ }++-- | Index into 'flavors' of 'SchedulerInput'+type FlavorIndex = Int++data SchedulerMessage+ = OnStepStarted+ { flavorIndex :: FlavorIndex+ , step :: CabalStep+ } -- ^ Either the first message for this flavor, or sequenced after+ -- 'OnStepFinished' for this flavor.+ | OnStepFinished+ { flavorIndex :: FlavorIndex+ , step :: CabalStep+ , exitCode :: ExitCode+ } -- ^ Always sequenced after 'OnOutput' for this flavor.+ | OnOutput+ { flavorIndex :: FlavorIndex+ , step :: CabalStep+ , channel :: OutputChannel+ , output :: ByteString+ } -- ^ Sequenced after 'OnStepStarted' for this flavor.+ | OnDone -- ^ Sequenced after all events.+ deriving stock (Show)++data SchedulerSignal+ = InterruptFlavor+ { flavorIndex :: FlavorIndex+ } -- ^ Try to interrupt the current step (if any) with SIGINT and don't+ -- start subsequent steps (if any).+ | TerminateFlavor+ { flavorIndex :: FlavorIndex+ } -- ^ Try to interrupt the current step (if any) with SIGTERM and don't+ -- start subsequent steps (if any).+ | PrioritizeFlavor+ { flavorIndex :: FlavorIndex+ } -- ^ Move the given flavor the front of the priority queue, if it hasn't+ -- been started yet++newtype SchedulerHandle = SchedulerHandle (MVar SchedulerState)++data SchedulerState = SchedulerState+ { processes :: Map FlavorIndex ProcessHandle+ , stopRequested :: Set FlavorIndex+ , queue :: [FlavorIndex]+ -- ^ INVARIANT: disjoint from 'stopRequested' and from keys of 'processes'+ }++mkCabalArgs :: SchedulerConfig -> CabalStep -> Flavor -> CabalArgs+mkCabalArgs input step flavor = CabalArgs+ { cabalExecutable = input.cabalExecutable+ , step+ , mode = input.mode+ , options = input.options+ , targets = input.targets+ , flavor+ }++startScheduler+ :: SchedulerConfig+ -> Array Flavor+ -> (SchedulerMessage -> IO ())+ -> IO SchedulerHandle+startScheduler input flavors cb = do+ sem <- newQSem input.jobs+ mvar <- newMVar SchedulerState+ { processes = Map.empty+ , stopRequested = Set.empty+ , queue = [0 .. sizeofArray flavors - 1]+ }+ let+ waitForNext :: IO ()+ waitForNext = do+ waitQSem sem+ done <- modifyMVar mvar \state -> case state.queue of+ [] -> do+ doneWithFlavor+ pure (state, True)+ flavorIndex:queue' -> do+ mProcess <- startSteps flavorIndex+ (filter (indexCabalStep input.steps) [minBound..maxBound])+ pure+ ( state+ { processes+ = Map.update (\_ -> mProcess) flavorIndex state.processes+ , queue = queue'+ }+ , False+ )++ if done+ then waitForDone+ else waitForNext++ doneWithFlavor :: IO ()+ doneWithFlavor = signalQSem sem++ startSteps :: FlavorIndex -> [CabalStep] -> IO (Maybe ProcessHandle)+ startSteps flavorIndex = \case+ [] -> Nothing <$ doneWithFlavor+ step:nextSteps -> Just <$> do+ stdoutClosed <- newEmptyMVar+ stderrClosed <- newEmptyMVar+ cb OnStepStarted { flavorIndex, step }+ let args = mkCabalArgs input step (indexArray flavors flavorIndex)+ for_ (environmentFilePath args) $ void . try @_ @IOError . removeFile+ startProcess (renderCabalArgs args)+ (reactStep flavorIndex step nextSteps stdoutClosed stderrClosed)++ reactStep+ :: FlavorIndex+ -> CabalStep+ -> [CabalStep]+ -> MVar ()+ -> MVar ()+ -> ProcessMessage+ -> IO ()+ reactStep flavorIndex step nextSteps stdoutClosed stderrClosed = \case+ OnProcessOutput channel output -> cb OnOutput+ { flavorIndex+ , step+ , channel+ , output+ }+ OnChannelClosed Stdout -> putMVar stdoutClosed ()+ OnChannelClosed Stderr -> putMVar stderrClosed ()+ OnProcessExit exitCode -> do+ -- Synchronize OnStepFinished to be sequenced after OnOutput.+ -- Perhaps ProcessRunner should do this.+ takeMVar stdoutClosed+ takeMVar stderrClosed+ cb OnStepFinished { flavorIndex, step, exitCode }+ case exitCode of+ ExitFailure _ -> doneWithFlavor+ ExitSuccess -> modifyMVar_ mvar \state+ -- 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+ }++ waitForDone :: IO ()+ waitForDone = do+ -- Once the queue has become empty, wait for all running jobs to finish+ replicateM_ input.jobs $ waitQSem sem+ cb OnDone++ _ <- forkIO waitForNext+ pure $ SchedulerHandle mvar++signalScheduler :: SchedulerHandle -> SchedulerSignal -> IO ()+signalScheduler (SchedulerHandle mvar) = \case+ InterruptFlavor{ flavorIndex } -> modifyMVar_ mvar \state -> if+ | flavorIndex `elem` state.queue+ -> pure state { queue = delete flavorIndex state.queue }+ | Just processHdl <- Map.lookup flavorIndex state.processes+ -> do+ signalProcess processHdl SignalInterrupt+ pure state { stopRequested = Set.insert flavorIndex state.stopRequested }+ | otherwise+ -> pure state+ TerminateFlavor{ flavorIndex } -> modifyMVar_ mvar \state -> if+ | flavorIndex `elem` state.queue+ -> pure state { queue = delete flavorIndex state.queue }+ | Just processHdl <- Map.lookup flavorIndex state.processes+ -> do+ signalProcess processHdl SignalTerminate+ pure state { stopRequested = Set.insert flavorIndex state.stopRequested }+ | otherwise+ -> pure state+ PrioritizeFlavor{ flavorIndex } -> modifyMVar_ mvar \state -> if+ | flavorIndex `elem` state.queue+ -> pure state { queue = flavorIndex : delete flavorIndex state.queue }+ -- ^ TODO: leak? we accumulate 'delete' thunks?+ | otherwise+ -> pure state
+ src/Cabal/Matrix/Tui.hs view
@@ -0,0 +1,309 @@+module Cabal.Matrix.Tui+ ( tuiLive+ , tuiRecording+ ) where++import Cabal.Matrix.CabalArgs+import Cabal.Matrix.Cli+import Cabal.Matrix.Matrix+import Cabal.Matrix.Record+import Cabal.Matrix.Rectangle (Rectangle)+import Cabal.Matrix.Rectangle qualified as Rectangle+import Cabal.Matrix.Scheduler+import Cabal.Matrix.Tui.Common+import Cabal.Matrix.Tui.Flavor+import Cabal.Matrix.Tui.Headers+import Cabal.Matrix.Tui.Table+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Data.Foldable+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.List+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Primitive+import Data.Set qualified as Set+import Data.Text (Text)+import Graphics.Vty+import Graphics.Vty.CrossPlatform+++data AppState = AppState+ { headers :: HeaderState+ , headerEditor :: Maybe HeaderEditorState+ , flavorStates :: IntMap FlavorState+ , openedCell :: Maybe (FlavorIndex, OutputState)+ , layout :: TableLayout+ , table :: TableState+ }++type TuiMatrix = Rectangle (PerCabalStep (NonEmpty Text)) Text (Maybe Text)++initAppState :: TuiMatrix -> AppState+initAppState matrix = AppState+ { headers+ , headerEditor = Nothing+ , flavorStates = IntMap.fromList+ $ zip [0..] $ map initFlavorState $ toList $ Rectangle.rows matrix+ , openedCell = Nothing+ , layout = mkTableLayout headers+ , table = initTableState+ }+ where+ !numColumns = sizeofArray $ Rectangle.columns matrix+ !vertical = arrayFromListN numColumns+ [i * 2 >= numColumns | i <- [0 .. numColumns - 1]]+ !headers = mkHeaderState matrix vertical++mkTableMeta :: HeaderState -> TableMeta+mkTableMeta headers = TableMeta+ { frozenRows = sizeofArray $ Rectangle.columns headers.horizontalHeader+ , normalRows = sizeofArray $ Rectangle.rows headers.verticalHeader+ , frozenColumns = sizeofArray $ Rectangle.columns headers.verticalHeader+ , normalColumns = sizeofArray $ Rectangle.rows headers.horizontalHeader+ }++mkTableHeaders :: HeaderState -> TableHeaders+mkTableHeaders headers = TableHeaders+ { frozenRowHeader = indexArray $ Rectangle.columns headers.horizontalHeader+ , frozenRowCell = \x y -> Rectangle.indexCell headers.horizontalHeader y x+ , frozenColumnHeader = indexArray $ Rectangle.columns headers.verticalHeader+ , frozenColumnCell = \x y -> Rectangle.indexCell headers.verticalHeader x y+ }++mkTableLayout :: HeaderState -> TableLayout+mkTableLayout headers+ = tableLayout (mkTableMeta headers) (mkTableHeaders headers)++appWidget+ :: DisplayRegion+ -> TuiMatrix+ -> PerCabalStep Bool+ -> AppState+ -> (AppState, Image)+appWidget (width, height) matrix enabledSteps ast+ = (ast', contents <-> keybinds)+ where+ (ast', contents)+ | Just (flavorIndex, os) <- ast.openedCell+ , Just fs <- IntMap.lookup flavorIndex ast.flavorStates+ = (ast,) $ outputWidget (width, height - 1) enabledSteps fs os+ | Just hes <- ast.headerEditor+ , (hes', editor) <- headerEditorWidget (width, height - 1)+ matrix ast.headers hes+ , (ts', tbl) <- tableWidget (width - imageWidth editor - 1, height - 1)+ (mkTableMeta ast.headers) table ast.layout ast.table+ = (ast { headerEditor = Just hes', table = ts' },) $ horizCat+ [ editor+ , charFill defAttr borderNS 1 (height - 1)+ , tbl+ ]+ | (ts', tbl) <- tableWidget (width, height - 1)+ (mkTableMeta ast.headers) table ast.layout ast.table+ = (ast { table = ts' },) $ tbl++ table = TableContents+ { normalCell = \x y -> do+ i <- Rectangle.indexCell ast.headers.gridToFlavor x y+ IntMap.lookup i ast.flavorStates+ }++ blueBg = defAttr `withBackColor` blue+ keybinds = resizeWidthFill blueBg ' ' width $ horizCat $+ intersperse (char blueBg ' ' <|> char blueBg borderNS <|> char blueBg ' ')+ [ text' (blueBg `withForeColor` brightYellow) bind+ <|> text' blueBg (": " <> desc)+ | (bind, desc) <- appKeybinds ast+ ]++appHandleSchedulerMessage+ :: SchedulerMessage+ -> AppState+ -> AppState+appHandleSchedulerMessage ev ast = case ev of+ OnStepStarted{ flavorIndex } -> ast+ { flavorStates = IntMap.adjust (flavorHandleSchedulerEvent ev)+ flavorIndex ast.flavorStates+ }+ OnStepFinished{ flavorIndex } -> ast+ { flavorStates = IntMap.adjust (flavorHandleSchedulerEvent ev)+ flavorIndex ast.flavorStates+ }+ OnOutput{ flavorIndex } -> ast+ { flavorStates = IntMap.adjust (flavorHandleSchedulerEvent ev)+ flavorIndex ast.flavorStates+ }+ OnDone -> ast++appHandleEvent+ :: TuiMatrix+ -> PerCabalStep Bool+ -> AppEvent+ -> AppState+ -> Maybe AppState+appHandleEvent matrix enabledSteps aev ast = case aev of+ AppTimerEvent ev -> Just ast+ { flavorStates = IntMap.map (flavorHandleTimerEvent ev) ast.flavorStates }+ VtyEvent (EvKey (isExitKey -> True) _)+ | Just _ <- ast.openedCell+ -> Just ast { openedCell = Nothing }+ | Just _ <- ast.headerEditor+ -> Just ast { headerEditor = Nothing }+ | Nothing <- ast.headerEditor+ -> Nothing+ VtyEvent ev+ | Just (flavorIndex, os) <- ast.openedCell+ -> Just ast+ { openedCell = Just (flavorIndex, outputHandleEvent enabledSteps ev os) }+ | Just headerEditor <- ast.headerEditor+ , (headerEditor', headers')+ <- headerEditorHandleEvent matrix ev (headerEditor, ast.headers)+ -> Just ast+ { headers = headers'+ , headerEditor = Just headerEditor'+ , layout = mkTableLayout headers'+ }+ VtyEvent (EvKey (KChar 'x') _)+ -> 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 fs <- IntMap.lookup flavorIndex ast.flavorStates+ -> Just ast { openedCell = Just (flavorIndex, initOutputState fs)}+ | otherwise -> Just ast+ VtyEvent ev+ -> Just ast+ { table = tableHandleEvent (mkTableMeta ast.headers) ev ast.table }+ where+ isExitKey = \case+ KEsc -> True+ KChar 'q' -> True+ _ -> False+ isEnterKey = \case+ KChar ' ' -> True+ KEnter -> True+ _ -> False++appKeybinds :: AppState -> [(Text, Text)]+appKeybinds ast+ | Just _ <- ast.openedCell+ = [("<Esc>/Q", "back")] <> outputKeybinds+ | 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+ -> [])+ <> [("<Esc>/Q", "quit")]+ <> [("X", "axes")]+ <> tableKeybinds++data AppEvent+ = VtyEvent Event+ | AppTimerEvent TimerEvent++tuiMainLoop+ :: TuiMatrix+ -> AppState+ -> PerCabalStep Bool+ -> TBQueue (Either SchedulerMessage AppEvent)+ -> IO ()+tuiMainLoop tuiMatrix ast0 steps queue = do+ vty <- mkVty defaultConfig++ _ <- forkIO $ forever do+ atomically . writeTBQueue queue . Right . VtyEvent =<< vty.nextEvent++ let+ goDisplay !ast = do+ bounds <- vty.outputIface.displayBounds+ let (!ast', !image) = appWidget bounds tuiMatrix steps ast+ vty.update $ picForImage image+ go ast'++ go !ast = atomically (readTBQueue queue) >>= \case+ Left msg -> go (appHandleSchedulerMessage msg ast)+ Right ev -> case appHandleEvent tuiMatrix steps ev ast of+ Just ast' -> goDisplay ast'+ Nothing -> vty.shutdown++ goDisplay ast0++tuiMatrixLive :: SchedulerConfig -> Matrix -> TuiMatrix+tuiMatrixLive schedulerConfig+ = Rectangle.mapRows \flavor -> tabulateCabalStep' \step+ -> renderCabalArgs $ mkCabalArgs schedulerConfig step flavor++tuiLive :: Matrix -> RunOptions -> IO ()+tuiLive matrix options = do+ schedulerConfig <- getSchedulerConfig options+ let+ !tuiMatrix = tuiMatrixLive schedulerConfig matrix+ !flavors = Rectangle.rows matrix++ queue <- newTBQueueIO 1+ _ <- forkIO $ forever do+ threadDelay 100000+ atomically . writeTBQueue queue . Right . AppTimerEvent $ TimerEvent+ _hdl <- startScheduler schedulerConfig flavors+ (atomically . writeTBQueue queue . Left)++ tuiMainLoop tuiMatrix (initAppState tuiMatrix) options.steps queue++ -- TODO: should probably kill the processes in _hdl++tuiMatrixRecording :: [FlavorResult] -> TuiMatrix+tuiMatrixRecording results = matrix+ where+ !cols = Set.toList $ Set.unions+ [ Map.keysSet result.flavor+ | result <- results+ ]+ !matrix = Rectangle.fromRowMajor cols+ [ ( tabulateCabalStep' \step+ -> maybe noCmdline (.cmdline) $ indexCabalStep result.steps step+ , [Map.lookup col result.flavor | col <- cols]+ )+ | result <- results+ ]+ noCmdline = pure "" -- TODO: better representation?++addOutputFromRecording :: [FlavorResult] -> AppState -> AppState+addOutputFromRecording results ast = ast+ { flavorStates = foldl'+ (\im (i, result) -> IntMap.adjust (flavorFromRecording result) i im)+ ast.flavorStates+ (zip [0..] results)+ }++stepsRecording :: [FlavorResult] -> PerCabalStep Bool+stepsRecording results = tabulateCabalStep' \step+ -> any (\res -> isJust $ indexCabalStep res.steps step) results++tuiRecording :: [FlavorResult] -> IO ()+tuiRecording results = do+ let+ !tuiMatrix = tuiMatrixRecording results+ !steps = stepsRecording results++ queue <- newTBQueueIO 1++ tuiMainLoop tuiMatrix+ (addOutputFromRecording results $ initAppState tuiMatrix)+ steps queue
+ src/Cabal/Matrix/Tui/Common.hs view
@@ -0,0 +1,63 @@+module Cabal.Matrix.Tui.Common where++import Data.Foldable+import Data.Functor+import Data.Text (Text)+import Graphics.Vty+import Text.Wrap+++borderNS :: Char+borderNS = '\x2502'++borderEW :: Char+borderEW = '\x2500'++borderNESW :: Char+borderNESW = '\x253C'++triangleN :: Char+triangleN = '\x25B2'++triangleE :: Char+triangleE = '\x25B6'++triangleS :: Char+triangleS = '\x25BC'++triangleW :: Char+triangleW = '\x25C0'++wrap :: Int -> Text -> [Text]+wrap = wrapTextToLines defaultWrapSettings { breakLongWords = True }++resizeWidthFill :: Attr -> Char -> Int -> Image -> Image+resizeWidthFill attr ch width image+ = case compare (imageWidth image) width of+ GT -> cropRight width image+ EQ -> image+ LT -> image+ <|> charFill attr ch (width - imageWidth image) (imageHeight image)++resizeHeightFill :: Attr -> Char -> Int -> Image -> Image+resizeHeightFill attr ch height image+ = case compare (imageHeight image) height of+ GT -> cropBottom height image+ EQ -> image+ LT -> image+ <-> charFill attr ch (imageWidth image) (height - imageHeight image)++padToCommonWidth :: (Foldable t, Functor t) => t (Attr, Char, Image) -> t Image+padToCommonWidth xs+ = xs <&> \(attr, ch, image) -> resizeWidthFill attr ch width image+ where+ width = maximum $ 0 : toList (xs <&> \(_, _, image) -> imageWidth image)++padToCommonHeight :: (Foldable t, Functor t) => t (Attr, Char, Image) -> t Image+padToCommonHeight xs+ = xs <&> \(attr, ch, image) -> resizeHeightFill attr ch height image+ where+ height = maximum $ 0 : toList (xs <&> \(_, _, image) -> imageHeight image)++clamp :: Ord a => a -> a -> a -> a+clamp lower upper = max lower . min upper
+ src/Cabal/Matrix/Tui/Flavor.hs view
@@ -0,0 +1,266 @@+module Cabal.Matrix.Tui.Flavor+ ( FlavorState+ , initFlavorState+ , flavorFromRecording+ , TimerEvent(..)+ , flavorHandleTimerEvent+ , flavorHandleSchedulerEvent+ , OutputState(..)+ , initOutputState+ , outputWidget+ , outputHandleEvent+ , outputKeybinds+ , matrixCellWidth+ , matrixCellHeight+ , cellWidget+ ) where++import Cabal.Matrix.CabalArgs+import Cabal.Matrix.ProcessRunner+import Cabal.Matrix.Record+import Cabal.Matrix.Scheduler+import Cabal.Matrix.Tui.Common+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.Function+import Data.List+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Graphics.Vty+import System.Exit+++data StepState = StepState+ { cmdline :: NonEmpty Text+ , started :: Bool+ , revOutput :: [(OutputChannel, ByteString)]+ , lastTickOutputCount :: !Int+ , outputCount :: !Int+ , exit :: Maybe ExitCode+ }++initStepState :: NonEmpty Text -> StepState+initStepState cmdline = StepState+ { cmdline+ , started = False+ , revOutput = []+ , lastTickOutputCount = 0+ , outputCount = 0+ , exit = Nothing+ }++stepFromRecording :: StepResult -> StepState -> StepState+stepFromRecording result ss = ss+ { started = True+ , revOutput = reverse $ second Text.encodeUtf8 <$> result.output+ , exit = Just result.exitCode+ }++statusColor :: StepState -> Color+statusColor ss = case ss.exit of+ _ | not ss.started -> white+ Nothing -> brightYellow+ Just ExitSuccess -> brightGreen+ Just (ExitFailure _) -> brightRed++stepOutputWidget :: DisplayRegion -> StepState -> Image+stepOutputWidget (width, height) ss = header <-> output+ where+ commandText = "Command: "+ headerBg = defAttr `withBackColor` blue+ status = headerBg `withForeColor` statusColor ss+ header = vertCat+ [ horizCat $ padToCommonHeight+ [ ( headerBg+ , ' '+ , text' (headerBg `withForeColor` brightYellow) commandText+ )+ , ( headerBg+ , ' '+ , vertCat+ [ resizeWidthFill headerBg ' ' (width - safeWctwidth commandText)+ $ text' headerBg line+ | line <- wrap (width - safeWctwidth commandText)+ $ Text.unwords $ NonEmpty.toList ss.cmdline+ ]+ )+ ]+ , resizeWidthFill headerBg ' ' width+ $ text' (headerBg `withForeColor` brightYellow) "Status: " <|>+ case ss.exit of+ _ | not ss.started -> text' status "Pending"+ Nothing -> text' status "Running"+ Just ExitSuccess -> text' status "Completed successfully"+ Just (ExitFailure code) -> text' status+ $ "Failed with exit code " <> Text.pack (show code)+ , charFill (headerBg `withForeColor` brightYellow) borderEW width 1+ ]+ output = resize width (height - imageHeight header) $ vertCat+ [ text' defAttr line+ | line <- reverse . take (height - imageHeight header) . reverse+ $ wrap width+ $ Text.concat $ Text.decodeUtf8Lenient . snd <$> reverse ss.revOutput+ ]++data TimerEvent = TimerEvent++stepHandleSchedulerEvent :: SchedulerMessage -> StepState -> StepState+stepHandleSchedulerEvent ev ss = case ev of+ OnStepStarted{} -> ss { started = True }+ OnStepFinished{ exitCode } -> ss { exit = Just exitCode }+ OnOutput{ channel, output } -> ss+ { revOutput = (channel, output):ss.revOutput+ , outputCount = ss.lastTickOutputCount + 1+ }+ OnDone{} -> ss++stepHandleTimerEvent :: TimerEvent -> StepState -> StepState+stepHandleTimerEvent ev ss = case ev of+ TimerEvent -> ss { lastTickOutputCount = ss.outputCount }++type FlavorState = PerCabalStep StepState++initFlavorState :: PerCabalStep (NonEmpty Text) -> FlavorState+initFlavorState = fmap initStepState++flavorFromRecording :: FlavorResult -> FlavorState -> FlavorState+flavorFromRecording result fs = tabulateCabalStep'+ \step -> maybe id stepFromRecording+ (indexCabalStep result.steps step) (indexCabalStep fs step)++flavorHandleSchedulerEvent :: SchedulerMessage -> FlavorState -> FlavorState+flavorHandleSchedulerEvent ev fs = case ev of+ OnStepStarted{ step }+ -> modifyCabalStep step (stepHandleSchedulerEvent ev) fs+ OnStepFinished{ step }+ -> modifyCabalStep step (stepHandleSchedulerEvent ev) fs+ OnOutput{ step }+ -> modifyCabalStep step (stepHandleSchedulerEvent ev) fs+ OnDone{} -> fs++flavorHandleTimerEvent :: TimerEvent -> FlavorState -> FlavorState+flavorHandleTimerEvent ev fs+ = tabulateCabalStep' \step -> stepHandleTimerEvent ev $ indexCabalStep fs step++newtype OutputState = OutputState+ { selectedStep :: CabalStep+ }++initOutputState :: FlavorState -> OutputState+initOutputState fs = OutputState+ { selectedStep = fromMaybe FullBuild $ find+ (\step -> indexCabalStep fs step+ & \ss -> ss.started && ss.exit /= Just ExitSuccess)+ [minBound..maxBound]+ }++outputWidget+ :: DisplayRegion -> PerCabalStep Bool -> FlavorState -> OutputState -> Image+outputWidget (width, height) enabledSteps fs os = tabSwitcher <-> output+ where+ stepName = \case+ DryRun -> "Planning"+ OnlyDownload -> "Download"+ OnlyDependencies -> "Dependencies"+ FullBuild -> "Build"+ tabSwitcher = horizCat+ [ char defAttr ' ' <|> text'+ (if step == os.selectedStep+ then defAttr `withBackColor` blue+ else defAttr `withBackColor` brightBlack)+ (if ss.started && isNothing ss.exit+ then stepName step <> " " <> outputSpinner ss+ else stepName step)+ | step <- [minBound..maxBound]+ , indexCabalStep enabledSteps step || step == os.selectedStep+ , let ss = indexCabalStep fs step+ ]+ output = stepOutputWidget (width, height - imageHeight tabSwitcher)+ (indexCabalStep fs os.selectedStep)++outputSpinner :: StepState -> Text+outputSpinner ss = Text.singleton $ "|/-\\" !! (ss.outputCount `mod` 4)++outputHandleEvent+ :: PerCabalStep Bool -> Event -> OutputState -> OutputState+outputHandleEvent enabledSteps ev os = case ev of+ -- Make sure to do something sensible if all steps are disabled+ EvKey KLeft _ -> os+ { selectedStep = fromMaybe os.selectedStep $ listToMaybe+ [ step+ | step <- reverse [minBound..maxBound]+ , indexCabalStep enabledSteps step+ , step < os.selectedStep+ ]+ }+ EvKey KRight _ -> os+ { selectedStep = fromMaybe os.selectedStep $ listToMaybe+ [ step+ | step <- [minBound..maxBound]+ , indexCabalStep enabledSteps step+ , step > os.selectedStep+ ]+ }+ _ -> os++outputKeybinds :: [(Text, Text)]+outputKeybinds =+ [ (Text.pack [triangleW, triangleE], "switch build steps")+ ]++matrixCellWidth :: Int+matrixCellWidth = 10++matrixCellHeight :: Int+matrixCellHeight = 1++cellWidget :: Bool -> Maybe FlavorState -> Image+cellWidget focused Nothing = charFill+ (if focused then defAttr `withBackColor` brightBlack else defAttr)+ ' ' matrixCellWidth matrixCellHeight+cellWidget focused (Just pcs) = resizeWidthFill attr ' ' matrixCellWidth if+ | Just ExitSuccess <- pcs.fullBuild.exit+ -> go FullBuild "build ok"+ | Just (ExitFailure _) <- pcs.fullBuild.exit+ -> go FullBuild "build fail"+ | pcs.fullBuild.started+ -> go FullBuild $ "build " <> outputSpinner pcs.fullBuild++ | Just ExitSuccess <- pcs.onlyDependencies.exit+ -> go OnlyDependencies "deps ok"+ | Just (ExitFailure _) <- pcs.onlyDependencies.exit+ -> go OnlyDependencies "deps fail"+ | pcs.onlyDependencies.started+ -> go OnlyDependencies $ "deps " <> outputSpinner pcs.onlyDependencies++ | Just ExitSuccess <- pcs.onlyDownload.exit+ -> go OnlyDownload "DL ok"+ | Just (ExitFailure _) <- pcs.onlyDownload.exit+ -> go OnlyDownload "DL fail"+ | pcs.onlyDownload.started+ -> go OnlyDownload $ "DL " <> outputSpinner pcs.onlyDownload++ | Just ExitSuccess <- pcs.dryRun.exit+ -> go DryRun "plan ok"+ | Just (ExitFailure _) <- pcs.dryRun.exit+ -> go DryRun "no plan"+ | pcs.dryRun.started+ -> go DryRun $ "plan " <> outputSpinner pcs.dryRun++ | otherwise+ -> text' attr "..."+ where+ attr = if focused then defAttr `withBackColor` blue else defAttr+ go step = text' $ attr `withForeColor` if+ -- A failure to --dry-run, that is, to solve package constraints is often+ -- not considered a failure. Rather it indicates that the package bounds+ -- are set up correctly.+ | DryRun <- step+ , Just (ExitFailure _) <- (indexCabalStep pcs step).exit+ -> cyan+ | otherwise+ -> statusColor (indexCabalStep pcs step)
+ src/Cabal/Matrix/Tui/Headers.hs view
@@ -0,0 +1,105 @@+module Cabal.Matrix.Tui.Headers+ ( HeaderState(..)+ , mkHeaderState+ , HeaderEditorState+ , initHeaderEditorState+ , headerEditorWidget+ , headerEditorHandleEvent+ , headerEditorKeybinds+ ) where++import Cabal.Matrix.Rectangle (Rectangle)+import Cabal.Matrix.Rectangle qualified as Rectangle+import Cabal.Matrix.Tui.Common+import Data.Foldable+import Data.Primitive+import Data.Text (Text)+import Data.Text qualified as Text+import Graphics.Vty+++data HeaderState = HeaderState+ { vertical :: Array Bool+ -- ^ INVARIANT: must have the same length as the number of columns in the+ -- build matrix in use+ , horizontalHeader :: Rectangle () Text (Maybe Text)+ , verticalHeader :: Rectangle () Text (Maybe Text)+ , gridToFlavor :: Rectangle () () (Maybe Int)+ }++mkHeaderState :: Rectangle flavor Text (Maybe Text) -> Array Bool -> HeaderState+mkHeaderState matrix vertical = HeaderState{..}+ where+ (horizontalHeader, verticalHeader, gridToFlavor)+ = Rectangle.unCartesianProduct vertical matrix++data HeaderEditorState = HeaderEditorState+ { index :: Int+ , scroll :: Int+ }++initHeaderEditorState :: HeaderEditorState+initHeaderEditorState = HeaderEditorState+ { index = 0+ , scroll = 0+ }++headerEditorWidget+ :: DisplayRegion+ -> Rectangle flavor Text (Maybe Text)+ -> HeaderState+ -> HeaderEditorState+ -> (HeaderEditorState, Image)+headerEditorWidget (_, height) matrix hs hes =+ ( hes { scroll = scroll' }+ , vertCat $ padToCommonWidth+ [ ( attr+ , ' '+ , text' (attr `withForeColor` yellow)+ (if indexArray hs.vertical i then "[V] " else "[H] ")+ <|> text' attr column+ )+ | (i, column) <- take height $ drop scroll'+ $ zip [0..] $ toList $ Rectangle.columns matrix+ , let+ attr = if i == hes.index+ then defAttr `withBackColor` blue+ else defAttr+ ]+ )+ where+ -- make it so that 1 <= hes.index - hes.scroll < height - 1+ scroll' = clamp (hes.index - height + 2) (hes.index - 1) hes.scroll++headerEditorHandleEvent+ :: Rectangle flavor Text (Maybe Text)+ -> Event+ -> (HeaderEditorState, HeaderState)+ -> (HeaderEditorState, HeaderState)+headerEditorHandleEvent matrix ev (hes, hs) = case ev of+ EvKey KUp _ ->+ ( hes { index = clamp 0 (sizeofArray hs.vertical - 1) $ pred hes.index }+ , hs+ )+ EvKey KDown _ ->+ ( hes { index = clamp 0 (sizeofArray hs.vertical - 1) $ succ hes.index }+ , hs+ )+ EvKey (isToggleKey -> True) _ | hes.index < sizeofArray hs.vertical+ -> (hes, mkHeaderState matrix $ toggleArray hes.index hs.vertical)+ _ -> (hes, hs)+ where+ isToggleKey = \case+ KChar ' ' -> True+ KEnter -> True+ _ -> False+ toggleArray i arr = runArray do+ m <- thawArray arr 0 (sizeofArray arr)+ writeArray m i . not =<< readArray m i+ pure m++headerEditorKeybinds :: [(Text, Text)]+headerEditorKeybinds =+ [ (Text.pack [triangleN, triangleS], "select field")+ , ("<Enter>/<Space>", "toggle vertical/horizontal axis")+ ]
+ src/Cabal/Matrix/Tui/Table.hs view
@@ -0,0 +1,383 @@+module Cabal.Matrix.Tui.Table+ ( TableMeta(..)+ , TableHeaders(..)+ , TableContents(..)+ , tableLayout+ , TableLayout+ , TableState(..)+ , ActiveSelection(..)+ , initTableState+ , tableWidget+ , tableHandleEvent+ , tableKeybinds+ ) where++import Cabal.Matrix.Tui.Common+import Cabal.Matrix.Tui.Flavor+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.List+import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe+import Data.Primitive.Array+import Data.Text (Text)+import Data.Text qualified as Text+import Graphics.Vty+++data TableMeta = TableMeta+ { frozenRows :: Int+ , normalRows :: Int+ , frozenColumns :: Int+ , normalColumns :: Int+ }++data TableHeaders = TableHeaders+ { frozenRowHeader :: Int -> Text+ , frozenRowCell :: Int -> Int -> Maybe Text+ , frozenColumnHeader :: Int -> Text+ , frozenColumnCell :: Int -> Int -> Maybe Text+ }++newtype TableContents = TableContents+ { normalCell :: Int -> Int -> Maybe FlavorState+ }++data ActiveSelection+ = SelectionLeft+ | SelectionTop+ | SelectionNormal+ | SelectionNone+ deriving stock (Eq)++data TableState = TableState+ { frozenScrollX :: Int+ , frozenScrollY :: Int+ , normalScrollX :: Int+ , normalScrollY :: Int+ , frozenSelectionCol :: Int+ , frozenSelectionRow :: Int+ , normalSelectionCol :: Int+ , normalSelectionRow :: Int+ , activeSelection :: ActiveSelection+ }++initTableState :: TableState+initTableState = TableState+ { frozenScrollX = 0+ , frozenScrollY = 0+ , normalScrollX = 0+ , normalScrollY = 0+ , frozenSelectionCol = 0+ , frozenSelectionRow = 0+ , normalSelectionCol = 0+ , normalSelectionRow = 0+ , activeSelection = SelectionNone+ }++data TopHeaderLayout = TopHeaderLayout+ { rowIndex :: !Int+ , rowHeader :: !Image+ , columns :: !(Array (NonEmpty Text))+ , height :: !Int+ }++data LeftHeaderLayout = LeftHeaderLayout+ { columnIndex :: !Int+ , columnHeader :: !Image+ , rows :: !(Array Text)+ , width :: !Int+ }++data TableLayout = TableLayout+ { rowHeaderWidth :: !Int+ , top :: !(Map Int TopHeaderLayout)+ , topHeight :: !Int+ , left :: !(Map Int LeftHeaderLayout)+ , leftWidth :: !Int+ }++tableLayout :: TableMeta -> TableHeaders -> TableLayout+tableLayout meta headers = TableLayout+ { rowHeaderWidth+ , top+ , topHeight+ , left+ , leftWidth = max 0 (pred leftWidth')+ -- ^ Remove the width of the trailing separator if there were any columns,+ -- but don't underflow to negative if there weren't.+ }+ where+ (topHeight, Map.fromAscList -> top) = mapAccumL mkTop 0+ [ TopHeaderLayout+ { rowIndex = row+ , rowHeader = resizeHeight height rowHeader+ , columns = arrayFromListN meta.normalColumns+ [ fmap (padTextToWidth matrixCellWidth)+ $ fromMaybe (NonEmpty.singleton "") $ NonEmpty.nonEmpty+ $ column <> replicate (height - length columns) ""+ | column <- columns+ ]+ , height+ }+ | row <- [0 .. meta.frozenRows - 1]+ , let+ rowHeader = text' defAttr $ headers.frozenRowHeader row+ columns =+ [ foldMap (wrap matrixCellWidth) $ headers.frozenRowCell col row+ | col <- [0 .. meta.normalColumns - 1]+ ]+ !height = maximum (imageHeight rowHeader :| (length <$> columns))+ ]+ mkTop !startY !layout+ | !endY <- startY + layout.height = (endY, (endY, layout))++ rowHeaderWidth = maximum+ $ 0 :| (imageWidth . (.rowHeader) <$> Map.elems top)++ (leftWidth', Map.fromAscList -> left) = mapAccumL mkLeft 0+ [ LeftHeaderLayout+ { columnIndex = col+ , columnHeader = resizeWidth width columnHeader+ , rows = arrayFromListN meta.normalRows $ padTextToWidth width <$> rows+ , width+ }+ | col <- [0 .. meta.frozenColumns - 1]+ , let+ columnHeader = text' defAttr $ headers.frozenColumnHeader col+ rows =+ [ fromMaybe "" $ headers.frozenColumnCell col row+ | row <- [0 .. meta.normalRows - 1]+ ]+ !width = maximum (imageWidth columnHeader :| (wctwidth <$> rows))+ ]+ mkLeft !startX layout+ | !endX <- startX + layout.width+ , !nextStartX <- endX + 1 = (nextStartX, (endX, layout))++padTextToWidth :: Int -> Text -> Text+padTextToWidth !width !t = t <> Text.replicate (width - Text.length t) " "++tableWidget+ :: DisplayRegion+ -> TableMeta+ -> TableContents+ -> TableLayout+ -> TableState+ -> (TableState, Image)+tableWidget (outputWidth, outputHeight) meta table layout state =+ ( state { frozenScrollX, frozenScrollY, normalScrollX, normalScrollY }+ , image+ )+ where+ topLeftWidth = max layout.rowHeaderWidth layout.leftWidth++ frozenWidth = min topLeftWidth ((outputWidth - 1) `div` 2)+ normalWidth = outputWidth - 1 - frozenWidth+ frozenHeight = min layout.topHeight ((outputHeight - 3) `div` 2)+ normalHeight = outputHeight - 3 - frozenHeight++ frozenScrollX+ | state.frozenSelectionCol < Map.size layout.left+ , (endX, col) <- Map.elemAt state.frozenSelectionCol layout.left+ = clamp (endX - frozenWidth) (endX - col.width) state.frozenScrollX+ | otherwise = state.frozenScrollX+ frozenScrollY+ | state.frozenSelectionRow < Map.size layout.top+ , (endY, row) <- Map.elemAt state.frozenSelectionRow layout.top+ = clamp (endY - frozenHeight) (endY - row.height) state.frozenScrollY+ | otherwise = state.frozenScrollY+ normalScrollX = clamp+ ((state.normalSelectionCol + 1) * (matrixCellWidth + 1) - 1 - normalWidth)+ (state.normalSelectionCol * (matrixCellWidth + 1))+ state.normalScrollX+ normalScrollY = clamp+ ((state.normalSelectionRow + 1) * matrixCellHeight - normalHeight)+ (state.normalSelectionRow * matrixCellHeight)+ state.normalScrollY++ normalTransX = -(normalScrollX `mod` (matrixCellWidth + 1))+ normalStartCol = normalScrollX `div` (matrixCellWidth + 1)+ normalEndCol = min (meta.normalColumns - 1)+ $ -((-normalScrollX - normalWidth) `div` (matrixCellWidth + 1))+ normalTransY = -(normalScrollY `mod` matrixCellHeight)+ normalStartRow = normalScrollY `div` matrixCellHeight+ normalEndRow = min (meta.normalRows - 1)+ $ -((-normalScrollY - normalHeight) `div` matrixCellHeight)+ (frozenTransX, leftVisible) =+ case Map.dropWhileAntitone (<= frozenScrollX) layout.left of+ leftTail@(Map.lookupMin -> Just (firstEndX, firstCol)) ->+ ( firstEndX - firstCol.width - frozenScrollX+ , snd <$> takeWhile+ (\(endX, col) -> endX - col.width < frozenScrollX + frozenWidth)+ (Map.toList leftTail)+ )+ _ -> (0, [])+ (frozenTransY, topVisible) =+ case Map.dropWhileAntitone (<= frozenScrollY) layout.top of+ topTail@(Map.lookupMin -> Just (firstEndY, firstRow)) ->+ ( firstEndY - firstRow.height - frozenScrollY+ , snd <$> takeWhile+ (\(endY, row) -> endY - row.height < frozenScrollY + frozenHeight)+ (Map.toList topTail)+ )+ _ -> (0, [])++ topLeft = cropBottom frozenHeight+ $ translate (frozenWidth - layout.rowHeaderWidth) frozenTransY+ $ vertCat+ [row.rowHeader | row <- topVisible]+ top = crop normalWidth frozenHeight+ $ translate normalTransX frozenTransY+ $ vertCat+ [ horizCat $ intersperse (backgroundFill 1 1)+ [ vertCat $ text' attr <$> NonEmpty.toList (indexArray row.columns col)+ | col <- [normalStartCol..normalEndCol]+ , let+ attr = if state.normalSelectionCol == col+ && state.frozenSelectionRow == row.rowIndex+ && state.activeSelection == SelectionTop+ then defAttr `withBackColor` blue+ else defAttr+ ]+ | row <- topVisible+ ]+ leftTop = resizeWidth frozenWidth $ translateX frozenTransX+ $ horizCat $ intersperse (backgroundFill 1 1)+ [col.columnHeader | col <- leftVisible]+ left = resize frozenWidth normalHeight+ $ translate frozenTransX normalTransY+ $ horizCat $ intersperse (backgroundFill 1 1)+ [ vertCat+ [ text' attr $ indexArray col.rows row+ | row <- [normalStartRow..normalEndRow]+ , let+ attr = if state.frozenSelectionCol == col.columnIndex+ && state.normalSelectionRow == row+ && state.activeSelection == SelectionLeft+ then defAttr `withBackColor` blue+ else defAttr+ ]+ | col <- leftVisible+ ]+ normal = crop normalWidth normalHeight+ $ translate normalTransX normalTransY+ $ vertCat+ [ horizCat $ intersperse (backgroundFill 1 1)+ [ cellWidget+ (state.normalSelectionCol == col+ && state.normalSelectionRow == row+ && state.activeSelection == SelectionNormal)+ $ table.normalCell col row+ | col <- [normalStartCol..normalEndCol]+ ]+ | row <- [normalStartRow..normalEndRow]+ ]++ canFrozenScrollW = frozenScrollX > 0+ canFrozenScrollE = frozenScrollX < topLeftWidth - frozenWidth+ canFrozenScrollN = frozenScrollY > 0+ canFrozenScrollS = frozenScrollY < layout.topHeight - frozenHeight+ canNormalScrollW = normalScrollX > 0+ canNormalScrollE = normalScrollX <+ meta.normalColumns * (matrixCellWidth + 1) - 1 - normalWidth+ canNormalScrollN = normalScrollY > 0+ canNormalScrollS = normalScrollY <+ meta.normalRows * matrixCellHeight - normalHeight++ image = vertCat+ [ topLeft+ <|> scrollBorderY canFrozenScrollN canFrozenScrollS frozenHeight+ <|> top+ , scrollBorderX canFrozenScrollW canFrozenScrollE frozenWidth+ <|> char defAttr borderNESW+ <|> scrollBorderX canNormalScrollW canNormalScrollE normalWidth+ , leftTop+ <|> char defAttr borderNS+ , scrollBorderX canFrozenScrollW canFrozenScrollE frozenWidth+ <|> char defAttr borderNESW+ <|> scrollBorderX canNormalScrollW canNormalScrollE normalWidth+ , left+ <|> scrollBorderY canNormalScrollN canNormalScrollS normalHeight+ <|> normal+ ]++scrollBorderX :: Bool -> Bool -> Int -> Image+scrollBorderX left right width+ | width > 2 = horizCat+ [ char defAttr (if left then triangleW else borderEW)+ , charFill defAttr borderEW (width - 2) 1+ , char defAttr (if right then triangleE else borderEW)+ ]+ | otherwise = charFill defAttr borderEW width 1++scrollBorderY :: Bool -> Bool -> Int -> Image+scrollBorderY up down height+ | height > 2 = vertCat+ [ char defAttr (if up then triangleN else borderNS)+ , charFill defAttr borderNS 1 (height - 2)+ , char defAttr (if down then triangleS else borderNS)+ ]+ | otherwise = charFill defAttr borderNS 1 height++tableHandleEvent :: TableMeta -> Event -> TableState -> TableState+tableHandleEvent meta ev ts = case ev of+ EvKey (KChar '\t') _ -> ts+ { activeSelection = case ts.activeSelection of+ SelectionNone -> SelectionNormal+ SelectionNormal -> SelectionTop+ SelectionTop -> SelectionLeft+ SelectionLeft -> SelectionNone+ }+ EvKey KLeft _+ | ts.activeSelection `elem` [SelectionNormal, SelectionTop] -> ts+ { normalSelectionCol = clamp 0 (meta.normalColumns - 1)+ $ pred ts.normalSelectionCol+ }+ | ts.activeSelection == SelectionLeft -> ts+ { frozenSelectionCol = clamp 0 (meta.frozenColumns - 1)+ $ pred ts.frozenSelectionCol+ }+ | ts.activeSelection == SelectionNone+ -> ts { activeSelection = SelectionNormal }+ EvKey KRight _+ | ts.activeSelection `elem` [SelectionNormal, SelectionTop] -> ts+ { normalSelectionCol = clamp 0 (meta.normalColumns - 1)+ $ succ ts.normalSelectionCol+ }+ | ts.activeSelection == SelectionLeft -> ts+ { frozenSelectionCol = clamp 0 (meta.frozenColumns - 1)+ $ succ ts.frozenSelectionCol+ }+ | ts.activeSelection == SelectionNone+ -> ts { activeSelection = SelectionNormal }+ EvKey KUp _+ | ts.activeSelection `elem` [SelectionNormal, SelectionLeft] -> ts+ { normalSelectionRow = clamp 0 (meta.normalRows - 1)+ $ pred ts.normalSelectionRow+ }+ | ts.activeSelection == SelectionTop -> ts+ { frozenSelectionRow = clamp 0 (meta.frozenRows - 1)+ $ pred ts.frozenSelectionRow+ }+ | ts.activeSelection == SelectionNone+ -> ts { activeSelection = SelectionNormal }+ EvKey KDown _+ | ts.activeSelection `elem` [SelectionNormal, SelectionLeft] -> ts+ { normalSelectionRow = clamp 0 (meta.normalRows - 1)+ $ succ ts.normalSelectionRow+ }+ | ts.activeSelection == SelectionTop -> ts+ { frozenSelectionRow = clamp 0 (meta.frozenRows - 1)+ $ succ ts.frozenSelectionRow+ }+ | ts.activeSelection == SelectionNone+ -> ts { activeSelection = SelectionNormal }+ _ -> ts++tableKeybinds :: [(Text, Text)]+tableKeybinds =+ [ (Text.pack [triangleW, triangleN, triangleS, triangleE], "select cell")+ , ("<Tab>", "focus cells/cols/rows")+ ]