diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 `` and then `` to view and follow the output of +the build, and `q` or `` 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 + │ + │ + │ + │ +/Q: quit │ X: axes │ ◀▲▼▶: select cell │ : 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 `` 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 +/Q: quit │ X: axes │ ◀▲▼▶: select cell │ : 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 +/Q: quit │ X: axes │ ◀▲▼▶: select cell │ : 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 +/Q: quit │ X: axes │ ◀▲▼▶: select cell │ : focus cells/cols/rows +``` +Using arrow keys to navigate to each `build fail` and `` 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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,1 @@ +import Cabal.Matrix.Main (main) diff --git a/cabal-matrix.cabal b/cabal-matrix.cabal new file mode 100644 --- /dev/null +++ b/cabal-matrix.cabal @@ -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 diff --git a/src/Cabal/Matrix/CabalArgs.hs b/src/Cabal/Matrix/CabalArgs.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/CabalArgs.hs @@ -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" diff --git a/src/Cabal/Matrix/Cli.hs b/src/Cabal/Matrix/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Cli.hs @@ -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 diff --git a/src/Cabal/Matrix/Files.hs b/src/Cabal/Matrix/Files.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Files.hs @@ -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 diff --git a/src/Cabal/Matrix/Main.hs b/src/Cabal/Matrix/Main.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Main.hs @@ -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 diff --git a/src/Cabal/Matrix/Matrix.hs b/src/Cabal/Matrix/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Matrix.hs @@ -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 diff --git a/src/Cabal/Matrix/ProcessRunner.hs b/src/Cabal/Matrix/ProcessRunner.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/ProcessRunner.hs @@ -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 + + diff --git a/src/Cabal/Matrix/Record.hs b/src/Cabal/Matrix/Record.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Record.hs @@ -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{..} diff --git a/src/Cabal/Matrix/Rectangle.hs b/src/Cabal/Matrix/Rectangle.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Rectangle.hs @@ -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 diff --git a/src/Cabal/Matrix/Scheduler.hs b/src/Cabal/Matrix/Scheduler.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Scheduler.hs @@ -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 diff --git a/src/Cabal/Matrix/Tui.hs b/src/Cabal/Matrix/Tui.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Tui.hs @@ -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 + = [("/Q", "back")] <> outputKeybinds + | Just _ <- ast.headerEditor + = [("/Q", "back")] <> headerEditorKeybinds + | otherwise + = (if + | ast.table.activeSelection == SelectionNormal + , ast.table.normalSelectionCol < sizeofArray + (Rectangle.rows ast.headers.horizontalHeader) + , ast.table.normalSelectionRow < sizeofArray + (Rectangle.rows ast.headers.verticalHeader) + , Just _ <- Rectangle.indexCell ast.headers.gridToFlavor + ast.table.normalSelectionCol ast.table.normalSelectionRow + -> [("/", "output")] + | otherwise + -> []) + <> [("/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 diff --git a/src/Cabal/Matrix/Tui/Common.hs b/src/Cabal/Matrix/Tui/Common.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Tui/Common.hs @@ -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 diff --git a/src/Cabal/Matrix/Tui/Flavor.hs b/src/Cabal/Matrix/Tui/Flavor.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Tui/Flavor.hs @@ -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) diff --git a/src/Cabal/Matrix/Tui/Headers.hs b/src/Cabal/Matrix/Tui/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Tui/Headers.hs @@ -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") + , ("/", "toggle vertical/horizontal axis") + ] diff --git a/src/Cabal/Matrix/Tui/Table.hs b/src/Cabal/Matrix/Tui/Table.hs new file mode 100644 --- /dev/null +++ b/src/Cabal/Matrix/Tui/Table.hs @@ -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") + , ("", "focus cells/cols/rows") + ]