diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,24 @@ +# 1.0.2.0 + +- `--blank-project` is a new mode for building packages directly from hackage, + and is a much faster alternative to `--install-lib`. It works by creating a + temporary `cabal.project` file, whose contents are simply + ``` + extra-packages: target1, target2, ... + ``` + This causes `target1`... to be interpreted as simultaneously a package to be + downloaded from hackage, and a package to be considered local, i.e. included + in the "build" step and excluded from the "deps" step. +- `--constraints` is a new option for specifying build constraints. It allows + specifying one or more constraints on package versions with + `--constraints "foo >1 , bar <2"`. It also allows specifying implication + constraints such as `--constraints "foo >1 :- bar <2"` e.g. as if all versions + `foo >1` were revised to include a `bar <2` constraint. More generally it + allows specifying disjunction constraints separated with `;`, such as + `--constraints "foo >1 ; bar <2 ; baz ==3"`. Disjunction/implication + constraints are translated to constraints guarded behind automatic cabal + flags. + # 1.0.1.0 - Binary operator options can now be parsed/formatted as JSON in a more compact diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -42,7 +42,7 @@ 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" +cabal-matrix -j1 foo --package bytestring ``` This may take a while to complete, and you can try using a higher value of `-j` @@ -90,7 +90,7 @@ ```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 +You could even run the same command as before (`--package bytestring`), but this will save time (and table space!) by not focusing on configurations that are definitely outside the possible range. @@ -221,32 +221,31 @@ You could run e.g.: ```sh -cabal-matrix -j1 text --package text=">=0" --times --package bytestring=">=0" +cabal-matrix -j1 text --package text --times --package bytestring ``` 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`: +Instead you can ask `cabal-matrix` to create a blank project for building `text` +using `--blank-project`: ```sh -cd /tmp -cabal-matrix -j1 --install-lib text \ - --package text=">=0" --times --package bytestring=">=0" +cabal-matrix -j1 --blank-project text \ + --package text --times --package bytestring ``` 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 \ +cabal-matrix -j1 --blank-project tar \ --option --index-state=2025-10-01T00:00:00Z \ --compiler ghc-9.2.8 \ --times \ - --package tar='>=0.6' \ + --package tar=">=0.6" \ --times \ - --package directory='>=1.3' + --package directory=">=1.3" ``` There is a clear cut corner of `build fail`s at `tar >=0.6.4` and @@ -299,7 +298,7 @@ can/should be relaxed, you can forward (using `--option`) `--allow-newer` and `--allow-older` to cabal: ```sh -cabal-matrix -j1 foo --package bytestring=">= 0" \ +cabal-matrix -j1 foo --package bytestring \ --option --allow-newer=foo:bytestring --option --allow-older=foo:bytestring ``` This will tell cabal to ignore the `build-depends` constraints that your package @@ -311,3 +310,38 @@ 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. + +# Validating Hackage Revisions + +If you have a hackage revision that you would like to apply, you can see how it +would affect the build plans by using a `--constraints` option with an +implication constraint. If as in the above example, we would like to revise +`tar >=0.6.4.0 && <=0.7.0.0` to tighten the bound on `directory` to `>=1.3.8`, +we can do so with: +```sh +cabal-matrix -j1 --blank-project tar \ + --option --index-state=2025-10-01T00:00:00Z \ + --compiler ghc-9.2.8 \ + --times \ + --package tar=">=0.6" \ + --times \ + --package directory=">=1.3" \ + --times \ + --constraints "tar >=0.6.4.0 && <=0.7.0.0 :- directory >=1.3.8" +``` + +Note that `--constraints` acts as a singleton list, so it needs to be +`--times`'ed with the rest of the build matrix. This allows, if necessary, to +apply different fixes to different parts of the build matrix. + +This implication constraint will work even when we're not directly enumerating +every `tar` or `directory` version, and even when neither of them is our build +target. So if you're trying to build your package `foo`, and encouter a +`deps fail` because of e.g. `tar`/`directory`, after figuring out which versions +of `tar` and `directory` are conflicting, you can get back to building your +`foo` package by adding the same +`--constraints "tar >=0.6.4.0 && <=0.7.0.0 :- directory >=1.3.8"` option to your +build. + +Note that there's currently no easy way to preview a revision that *relaxes* a +constraint. diff --git a/cabal-matrix.cabal b/cabal-matrix.cabal --- a/cabal-matrix.cabal +++ b/cabal-matrix.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cabal-matrix -version: 1.0.1.0 +version: 1.0.2.0 author: mniip maintainer: mniip license: BSD-3-Clause diff --git a/src/Cabal/Matrix/CabalArgs.hs b/src/Cabal/Matrix/CabalArgs.hs --- a/src/Cabal/Matrix/CabalArgs.hs +++ b/src/Cabal/Matrix/CabalArgs.hs @@ -1,4 +1,6 @@ -- | Converting high-level build matrix concepts into @cabal@ commandlines. +-- Some instructions cannot be passed via the command line, and instead have to +-- be passed through a temporary @cabal.project@ file. module Cabal.Matrix.CabalArgs ( CabalArgs(..) , CabalStep(..) @@ -9,18 +11,34 @@ , setCabalStep , CabalMode(..) , Flavor(..) + , Conjunction(..) + , Disjunction(..) + , Constraint(..) , renderCabalArgs - , environmentFilePath + , UserProjectFiles + , detectUserProjectFiles + , prepareFilesForCabal ) where +import Control.Exception.Safe +import Control.Monad +import Data.Either +import Data.Foldable +import Data.Functor import Data.Hashable import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty qualified as NonEmpty import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Distribution.Package +import Distribution.Pretty +import Distribution.Version import GHC.Generics import System.FilePath +import System.Directory -- | Cabal allows interrupting the build process at multiple points, which is @@ -88,32 +106,69 @@ data CabalMode = ProjectBuild -- | Assume that we're in a cabal project and run @cabal build@ -- targeting the project's packages and their dependencies. + | BlankProjectBuild -- | Create a temporary cabal project containing the + -- targets as @extra-packages@ (meaning they are considered local packages, + -- not included in 'OnlyDependencies') and run @cabal build@ with that + -- project. This is a much faster alternative to 'InstallLib', because cabal + -- doesn't need to read the installed package store. | 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. + deriving stock (Eq) +data Constraint = Constraint + { package :: PackageName + , versions :: VersionRange + } deriving stock (Eq, Show, Generic) + +-- Cabal-syntax 3.8 doesn't have @Ord Constraint@ +instance Ord Constraint where + compare c1 c2 = compare c1.package c2.package + <> compare (prettyShow c1.versions) (prettyShow c2.versions) + +instance Hashable Constraint where + hashWithSalt salt constr = salt + `hashWithSalt` unPackageName constr.package + `hashWithSalt` prettyShow constr.versions + +-- | All of these must be satisfied. +newtype Conjunction a = Conjunction { unConjunction :: Set a } + deriving newtype (Eq, Ord, Hashable) + deriving stock (Show) + +-- | Any of these must be satisfied. To specify a disjunction of cabal +-- constraints we have to express them as cabal flags on a fake package. +newtype Disjunction a = Disjunction { unDisjunction :: Set a } + deriving newtype (Eq, Ord, Hashable) + deriving stock (Show) + -- | Options defining what cell in the build matrix we're in. data Flavor = Flavor - { unorderedOptions :: Set Text + { constraints :: Conjunction (Disjunction (Conjunction Constraint)) + , 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 + { constraints = Conjunction + $ Set.union f1.constraints.unConjunction f2.constraints.unConjunction + , unorderedOptions = Set.union f1.unorderedOptions f2.unorderedOptions , orderedOptions = f1.orderedOptions ++ f2.orderedOptions } instance Monoid Flavor where mempty = Flavor - { unorderedOptions = Set.empty + { constraints = Conjunction Set.empty + , unorderedOptions = Set.empty , orderedOptions = [] } -- | A single invocation of @cabal@. data CabalArgs = CabalArgs { cabalExecutable :: FilePath + , userProjectFiles :: UserProjectFiles , mode :: CabalMode , step :: CabalStep , options :: [Text] @@ -127,6 +182,8 @@ -- ^ @--builddir@, where build artifacts will be placed. Different -- flavors using the same compiler must use different 'buildDir'. , mode :: CabalMode + , projectFile :: Maybe FilePath + -- ^ A project file to use with @cabal build@. , 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 @@ -141,7 +198,11 @@ renderRawCabalArgs ca = "cabal" :| mconcat [ case ca.mode of ProjectBuild -> ["build"] + BlankProjectBuild -> ["build"] InstallLib -> ["install", "--lib"] + , case ca.projectFile of + Nothing -> [] + Just path -> ["--project-file", Text.pack path] , case ca.envFile of Nothing -> [] Just path -> ["--package-env", Text.pack path] @@ -162,14 +223,18 @@ , buildDir = buildDirFor flavor , mode , envFile = environmentFilePath args + , projectFile = fst . (.projectFile) <$> mProjectFile , step , options = concat [ options , Set.toList flavor.unorderedOptions + , projectArgs , flavor.orderedOptions ] , targets } + where + (projectArgs, mProjectFile) = projectOrArgs args -- TODO: there probably needs to be some mechanism to clean up these at some -- point. @@ -180,7 +245,131 @@ renderCabalArgs :: CabalArgs -> NonEmpty Text renderCabalArgs = renderRawCabalArgs . argsToRaw +data ProjectData = ProjectData + { projectFile :: (FilePath, Text) + , auxCabalFile :: Maybe (FilePath, Text) + } + +-- | Do we need a project file, or will some CLI args suffice? +projectOrArgs :: CabalArgs -> ([Text], Maybe ProjectData) +projectOrArgs args = + ( cliConstraints + , guard (args.mode == BlankProjectBuild || needAuxCabalFile) + >> Just ProjectData + { projectFile = (projectFile, projectFileContents) + , auxCabalFile = guard needAuxCabalFile >> Just + ( auxCabalFile + , auxCabalFileContents + ) + } + ) + where + (Set.unions -> simpleConstraints, complexConstraints) = partitionEithers + $ Set.toList args.flavor.constraints.unConjunction <&> \disj + -> case NonEmpty.nonEmpty $ Set.toList disj.unDisjunction of + Nothing -> Left $ Set.singleton Constraint + { package = "base" + , versions = noVersion + } -- An empty disjunction is an unsatisfiable constraint. + Just (conj :| []) -> Left conj.unConjunction + Just conjs -> Right conjs + + cliConstraints = + [ "--constraint=" <> Text.pack (unPackageName package) + <> Text.pack (prettyShow versions) + | Constraint{ package, versions } <- Set.toList simpleConstraints + ] + + needAuxCabalFile = not $ null complexConstraints + + projectFile = buildDirFor args.flavor "cabal.project" + projectFileContents = Text.unlines $ + [ "import: " <> Text.pack userProjectFile + | args.mode /= BlankProjectBuild + , userProjectFile <- args.userProjectFiles.unUserProjectFiles + ] <> + [ "extra-packages: " <> Text.intercalate ", " args.targets + | args.mode == BlankProjectBuild + ] <> + [ "packages: " <> Text.pack auxCabalFile + | needAuxCabalFile + ] + + auxCabalFile = buildDirFor args.flavor + "cabal-matrix-constraints-fake-package.cabal" + (flags, buildDepends) = complexConstraintsToFlags complexConstraints + auxCabalFileContents = Text.unlines $ + [ "cabal-version: >=1.8" + , "name: cabal-matrix-constraints-fake-package" + , "version: 0" + , "build-type: Simple" + ] <> + [ "flag " <> flag <> " {}" + | flag <- flags + ] <> + [ "library" + ] <> + buildDepends + +complexConstraintsToFlags + :: [NonEmpty (Conjunction Constraint)] -> ([Text], [Text]) +complexConstraintsToFlags complexConstraints = + ( [ flag i j + | (i, conjs) <- zip [0..] complexConstraints + , j <- [1 .. NonEmpty.length conjs - 1] + ] + , concat $ zipWith (goDisj 1 1) [0..] complexConstraints + ) + where + goDisj !indent !_j !_i (conj :| []) = goConj indent conj + goDisj indent j i (conj :| conj' : conjs) = + [ Text.replicate indent " " <> "if flag(" <> flag i j <> ") {" + ] <> goConj (indent + 1) conj <> + [ Text.replicate indent " " <> "} else {" + ] <> goDisj (indent + 1) (j + 1) i (conj' :| conjs) <> + [ Text.replicate indent " " <> "}" + ] + + goConj !indent (Conjunction constrs) = + [ Text.replicate indent " " <> "build-depends:" + <> Text.intercalate ", " + [ Text.pack $ prettyShow constr.package <> prettyShow constr.versions + | constr <- Set.toList constrs + ] + ] + + flag :: Int -> Int -> Text + flag i j = "cabal-matrix-disjunction-" + <> Text.pack (show i) <> "-" <> Text.pack (show j) + environmentFilePath :: CabalArgs -> Maybe FilePath environmentFilePath CabalArgs{..} = case mode of - ProjectBuild -> Nothing InstallLib -> Just $ buildDirFor flavor "env" + ProjectBuild -> Nothing + BlankProjectBuild -> Nothing + +newtype UserProjectFiles = UserProjectFiles { unUserProjectFiles :: [FilePath] } + +detectUserProjectFiles :: IO UserProjectFiles +detectUserProjectFiles = UserProjectFiles <$> (getCurrentDirectory >>= go) + where + go dir = doesFileExist projectFile >>= \case + False -> if takeDirectory dir /= dir + then go $ takeDirectory dir + else pure [] + True -> (projectFile:) <$> filterM doesFileExist [localFile, freezeFile] + where + projectFile = dir "cabal.project" + localFile = dir "cabal.project.local" + freezeFile = dir "cabal.project.freeze" + +prepareFilesForCabal :: CabalArgs -> IO () +prepareFilesForCabal args = do + for_ (snd $ projectOrArgs args) \project -> do + createDirectoryIfMissing True $ takeDirectory $ fst project.projectFile + uncurry Text.writeFile project.projectFile + for_ project.auxCabalFile \auxCabalFile -> do + createDirectoryIfMissing True $ takeDirectory $ fst auxCabalFile + uncurry Text.writeFile auxCabalFile + for_ (environmentFilePath args) \environmentFile -> do + void $ try @_ @IOError $ removeFile environmentFile diff --git a/src/Cabal/Matrix/Cli.hs b/src/Cabal/Matrix/Cli.hs --- a/src/Cabal/Matrix/Cli.hs +++ b/src/Cabal/Matrix/Cli.hs @@ -14,11 +14,15 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Data.Char +import Data.Functor +import Data.List.NonEmpty qualified as NonEmpty import Data.List.Split import Data.Maybe +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import Data.Traversable +import Distribution.Compat.CharParsing (sepByNonEmpty, spaces, string, try) import Distribution.Package import Distribution.Parsec import Distribution.Version @@ -46,6 +50,7 @@ cabalExecutable <- case cabalOverride of Just override -> pure override Nothing -> fromMaybe "cabal" <$> lookupEnv "CABAL" + userProjectFiles <- detectUserProjectFiles pure SchedulerConfig{..} data CliOptions @@ -184,9 +189,15 @@ <*> 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") + modeOption + = flag' BlankProjectBuild (long "blank-project" + <> help "Create a blank project for the build, with the given targets \ + \specified as extra-packages, allowing targeting libraries directly \ + \from hackage" ) + <|> flag' InstallLib (long "install-lib" + <> help "Use cabal install --lib instead of cabal build instead of \ + \using a local project") + <|> pure ProjectBuild 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" @@ -306,6 +317,14 @@ <> help "A single build with the provided options, for options \ \that are order-sensitive. The provided options are appended \ \after all other options.") + , Expr "--constraints" . ConstraintsExpr + <$> option readConstraints + (long "constraints" <> metavar "CONSTRAINTS" + <> help "Specify constraints to use in the build. A basic \ + \constraint consists of a package name and a version range, such \ + \as 'foo >=1.0 && <2.0'. Constraints can be AND-ed with ',' and \ + \OR-ed with ';'. An implication constraint can be specified as \ + \'ANTECEDENT :- CONSEQUENT'.") ] , flag' OpenParen (long "[" <> style (\_ -> "--[ LIST --]") @@ -317,10 +336,10 @@ readCompilers :: ReadM [Compiler] readCompilers - = map Compiler . filter (not . null) <$> commaSeparated (strip <$> str) + = map Compiler . filter (not . null) <$> separatedBy "," (strip <$> str) readPrefer :: ReadM [Prefer] -readPrefer = commaSeparated $ maybeReader \(map toLower . strip -> s) -> if +readPrefer = separatedBy "," $ maybeReader \(map toLower . strip -> s) -> if | s `elem` ["newest", "newer", "new"] -> Just PreferNewest | s `elem` ["oldest", "older", "old"] -> Just PreferOldest | otherwise -> Nothing @@ -331,7 +350,7 @@ if '=' `elem` s then byEquals (mkPackageName . strip <$> str) - (SomeVersions <$> commaSeparated versionOrRange) + (SomeVersions <$> separatedBy "," versionOrRange) else ((, AllVersions) . mkPackageName . strip <$> str) where versionOrRange = ReadM $ ReaderT \s -> case eitherParsec @Version s of @@ -344,15 +363,50 @@ readCustom :: ReadM (Text, [Text]) readCustom = byEquals (Text.strip <$> str) - (filter (not . Text.null) <$> commaSeparated (Text.strip <$> str)) + (filter (not . Text.null) <$> separatedBy "," (Text.strip <$> str)) +readConstraints :: ReadM (Disjunction (Conjunction Constraint)) +readConstraints = ReadM $ ReaderT \s -> case explicitEitherParsec impl s of + Right constr -> pure constr + Left err -> throwE $ ErrorMsg $ "Expected package names followed by version \ + \constraints, separated by \",\", \";\", and \":-\": " <> err + where + atom = (\package versions -> Constraint{..}) + <$> (spaces *> parsec @PackageName) + <*> (spaces *> try (parsec @VersionRange)) + term = sepByNonEmpty atom (spaces *> string ",") + <&> \as -> Conjunction $ Set.fromList $ NonEmpty.toList as + expr = sepByNonEmpty term (spaces *> string ";") + <&> \ts -> Disjunction $ Set.fromList $ NonEmpty.toList ts + impl = try (mkImplication <$> term <*> (spaces *> string ":-" *> expr)) + <|> expr + + mkImplication (Conjunction constrs) (Disjunction disj) + = Disjunction $ Set.map invertConstr constrs `Set.union` disj + invertConstr Constraint{ package, versions } + = Conjunction $ Set.singleton Constraint + { package + , versions = flip cataVersionRange versions \case + ThisVersionF ver -> notThisVersion ver + LaterVersionF ver -> orEarlierVersion ver + OrLaterVersionF ver -> earlierVersion ver + EarlierVersionF ver -> orLaterVersion ver + OrEarlierVersionF ver -> laterVersion ver + MajorBoundVersionF ver -> unionVersionRanges + (earlierVersion ver) + (orLaterVersion $ majorUpperBound ver) + UnionVersionRangesF vs1 vs2 -> intersectVersionRanges vs1 vs2 + IntersectVersionRangesF vs1 vs2 -> unionVersionRanges vs1 vs2 + } + 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 +separatedBy :: String -> ReadM a -> ReadM [a] +separatedBy separator (ReadM (ReaderT p)) + = ReadM $ ReaderT \s -> for (splitOn separator 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 --- a/src/Cabal/Matrix/Files.hs +++ b/src/Cabal/Matrix/Files.hs @@ -61,6 +61,23 @@ Left err2 -> fail $ unlines ["Expected a version or a version range: ", err1, err2] +newtype ConstraintJSON = ConstraintJSON Constraint + +instance ToJSON ConstraintJSON where + toJSON (ConstraintJSON constr) = object + [ "package" .= unPackageName constr.package + , "versions" .= prettyShow constr.versions + ] + +instance FromJSON ConstraintJSON where + parseJSON = withObject "Constraint" \o -> do + package <- mkPackageName <$> o .: "package" + versions <- explicitParseField parseVersion o "versions" + pure $ ConstraintJSON Constraint{..} + where + parseVersion = withText "Version" \txt -> do + either fail pure $ eitherParsec @VersionRange $ Text.unpack txt + newtype MatrixExprJSON = MatrixExprJSON MatrixExpr instance ToJSON MatrixExprJSON where @@ -94,6 +111,12 @@ [ "custom_ordered" .= key , "options" .= toJSON options ] + ConstraintsExpr disj -> object + [ "constraints" .= + [ [ConstraintJSON constr | constr <- Set.toList conj.unConjunction] + | conj <- Set.toList disj.unDisjunction + ] + ] goTimes (TimesExpr x y) ys = goTimes x (MatrixExprJSON y : ys) goTimes y xs = object [ "times" .= toJSON (MatrixExprJSON y : xs) @@ -147,12 +170,18 @@ Just options -> pure $ Just $ CustomOrderedExpr key options Nothing -> fail "Expected \"custom_ordered\" to be accompanied by \"options\"" + , (o .:? "constraints") <&> fmap @Maybe \disj + -> ConstraintsExpr $ Disjunction $ Set.fromList + [ Conjunction $ Set.fromList + [constr | ConstraintJSON constr <- conj] + | conj <- disj + ] ] case catMaybes parses of [x] -> pure $ MatrixExprJSON x _ -> fail "Expected exactly one of: \"times\", \"add\", \"subtract\", \ \\"seq\", \"compilers\", \"prefer\", \"package\", \ - \\"custom_unordered\", \"custom_ordered\"" + \\"custom_unordered\", \"custom_ordered\", \"constraints\"" parseJSON v = typeMismatch "Object or String" v writeExprFile :: FilePath -> MatrixExpr -> IO () @@ -167,13 +196,29 @@ instance ToJSON MatrixRowJSON where toJSON (MatrixRowJSON (flavor, row)) = object - [ "ordered_options" .= flavor.orderedOptions + [ "constraints" .= + [ [ [ConstraintJSON constr | constr <- Set.toList conj.unConjunction] + | conj <- Set.toList disj.unDisjunction + ] + | disj <- Set.toList flavor.constraints.unConjunction + ] + , "ordered_options" .= flavor.orderedOptions , "unordered_options" .= flavor.unorderedOptions , "flavor" .= row ] instance FromJSON MatrixRowJSON where parseJSON = withObject "MatrixRow" \o -> do + mConstraints <- o .:? "constraints" + let + constraints = Conjunction $ Set.fromList + [ Disjunction $ Set.fromList + [ Conjunction $ Set.fromList + [constr | ConstraintJSON constr <- conj] + | conj <- disj + ] + | disj <- fromMaybe [] mConstraints + ] orderedOptions <- o .: "ordered_options" unorderedOptions <- o .: "unordered_options" flavor <- o .: "flavor" diff --git a/src/Cabal/Matrix/Matrix.hs b/src/Cabal/Matrix/Matrix.hs --- a/src/Cabal/Matrix/Matrix.hs +++ b/src/Cabal/Matrix/Matrix.hs @@ -46,9 +46,8 @@ compilersMatrix :: [Compiler] -> Matrix compilersMatrix compilers = Rectangle.vertical "COMPILER" - [ ( Flavor + [ ( mempty { unorderedOptions = Set.singleton ("--with-compiler=" <> compiler) - , orderedOptions = [] } , Just compiler ) @@ -60,11 +59,10 @@ preferMatrix :: [Prefer] -> Matrix preferMatrix values = Rectangle.vertical "PREFER" - [ ( Flavor + [ ( mempty { unorderedOptions = if value == PreferOldest then Set.singleton "--prefer-oldest" else Set.empty - , orderedOptions = [] } , Just case value of PreferOldest -> "oldest" @@ -74,23 +72,25 @@ ] packageVersionMatrix :: PackageName -> [Version] -> Matrix -packageVersionMatrix (Text.pack . unPackageName -> package) versions - = Rectangle.vertical package - [ ( Flavor - { unorderedOptions = Set.singleton - $ "--constraint=" <> package <> "==" <> version - , orderedOptions = [] +packageVersionMatrix package versions + = Rectangle.vertical (Text.pack $ unPackageName package) + [ ( mempty + { constraints = Conjunction $ Set.singleton + $ Disjunction $ Set.singleton $ Conjunction $ Set.singleton + $ Constraint + { package + , versions = thisVersion version + } } - , Just version + , Just $ Text.pack $ prettyShow version ) - | version <- Text.pack . prettyShow <$> versions + | version <- versions ] customUnorderedOptions :: Text -> [Text] -> Matrix customUnorderedOptions name options = Rectangle.vertical name - [ ( Flavor + [ ( mempty { unorderedOptions = Set.fromList options - , orderedOptions = [] } , Just $ Text.unwords options ) @@ -98,14 +98,18 @@ customOrderedOptions :: Text -> [Text] -> Matrix customOrderedOptions name options = Rectangle.vertical name - [ ( Flavor - { unorderedOptions = Set.empty - , orderedOptions = options + [ ( mempty + { orderedOptions = options } , Just $ Text.unwords options ) ] +constraintsMatrix :: Disjunction (Conjunction Constraint) -> Matrix +constraintsMatrix disj = Rectangle.unitRow $ mempty + { constraints = Conjunction $ Set.singleton disj + } + data VersionExpr = AllVersions | SomeVersions [Either Version VersionRange] @@ -124,6 +128,7 @@ | PackageVersionExpr PackageName VersionExpr | CustomUnorderedExpr Text [Text] | CustomOrderedExpr Text [Text] + | ConstraintsExpr (Disjunction (Conjunction Constraint)) -- | 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. @@ -176,6 +181,8 @@ -> EvalPure $ customUnorderedOptions name values CustomOrderedExpr name values -> EvalPure $ customOrderedOptions name values + ConstraintsExpr disjs + -> EvalPure $ constraintsMatrix disjs resolveMatrixExpr :: MatrixExpr -> IO MatrixExpr resolveMatrixExpr = runEvalM . go @@ -193,3 +200,4 @@ <$> evalVersionRanges package versions e@(CustomUnorderedExpr _ _) -> pure e e@(CustomOrderedExpr _ _) -> pure e + e@(ConstraintsExpr _) -> pure e diff --git a/src/Cabal/Matrix/Scheduler.hs b/src/Cabal/Matrix/Scheduler.hs --- a/src/Cabal/Matrix/Scheduler.hs +++ b/src/Cabal/Matrix/Scheduler.hs @@ -21,10 +21,8 @@ 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 @@ -32,7 +30,6 @@ import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) -import System.Directory import System.Exit @@ -44,6 +41,7 @@ , targets :: [Text] , cabalExecutable :: FilePath , mode :: CabalMode + , userProjectFiles :: UserProjectFiles , steps :: PerCabalStep Bool -- ^ Which build steps to run or skip. } @@ -105,6 +103,7 @@ { cabalExecutable = input.cabalExecutable , step , mode = input.mode + , userProjectFiles = input.userProjectFiles , options = input.options , targets = input.targets , flavor @@ -127,22 +126,24 @@ waitForNext :: IO () waitForNext = do waitQSem sem - done <- modifyMVar stateVar \state -> case state.queue of + (done, signal) <- modifyMVar stateVar \state -> case state.queue of [] -> do doneWithFlavor - pure (state, True) + pure (state, (True, pure ())) flavorIndex:queue' -> do - mProcess <- startSteps flavorIndex + result <- startSteps flavorIndex (filter (indexCabalStep input.steps) [minBound..maxBound]) pure ( state { processes - = Map.alter (\_ -> mProcess) flavorIndex state.processes + = Map.alter (\_ -> fst <$> result) flavorIndex state.processes , queue = queue' } - , False + , (False, maybe (pure ()) snd result) ) + signal -- possibly send the 'OnStepStarted' event + if done then waitForDone else waitForNext @@ -150,17 +151,24 @@ doneWithFlavor :: IO () doneWithFlavor = signalQSem sem - startSteps :: FlavorIndex -> [CabalStep] -> IO (Maybe ProcessHandle) + startSteps + :: FlavorIndex -> [CabalStep] -> IO (Maybe (ProcessHandle, IO ())) startSteps flavorIndex = \case [] -> Nothing <$ doneWithFlavor step:nextSteps -> Just <$> do stdoutClosed <- newEmptyMVar stderrClosed <- newEmptyMVar - cb OnStepStarted { flavorIndex, step } + processStarted <- newEmptyMVar let args = mkCabalArgs input step (indexArray flavors flavorIndex) - for_ (environmentFilePath args) $ void . try @_ @IOError . removeFile - startProcess (renderCabalArgs args) - (reactStep flavorIndex step nextSteps stdoutClosed stderrClosed) + prepareFilesForCabal args + handle <- startProcess (renderCabalArgs args) + (reactStep flavorIndex step nextSteps stdoutClosed stderrClosed processStarted) + -- We cannot send 'OnStepStarted' here because we are holding the state + -- MVar, and a deadlock is possible. Instead we defer sending it until + -- the MVar is released, and synchronize 'OnOutput' with this event. + pure $ (handle,) do + cb OnStepStarted { flavorIndex, step } + putMVar processStarted () reactStep :: FlavorIndex @@ -168,42 +176,54 @@ -> [CabalStep] -> MVar () -> 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 } - modifyMVar_ stateVar \state -> case exitCode of - ExitSuccess - -- It's possible that an interrupt signal has been received after - -- the process has already exited (successfully), but before we got - -- the 'OnProcessExit' message. So we must check this flag to see if - -- we shouldn't start subsequent steps. - | flavorIndex `Set.notMember` state.stopRequested - -> do - mProcess <- startSteps flavorIndex nextSteps - pure state - { processes - = Map.alter (\_ -> mProcess) flavorIndex state.processes - } - _ -> do - doneWithFlavor - pure state - { processes = Map.delete flavorIndex state.processes - , stopRequested = Set.delete flavorIndex state.stopRequested - } + reactStep flavorIndex step nextSteps stdoutClosed stderrClosed + processStarted = \case + OnProcessOutput channel output -> do + -- Synchronize OnOutput to be sent after OnStepStarted + readMVar processStarted + 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 } + signal <- modifyMVar stateVar \state -> case exitCode of + ExitSuccess + -- It's possible that an interrupt signal has been received after + -- the process has already exited (successfully), but before we got + -- the 'OnProcessExit' message. So we must check this flag to see if + -- we shouldn't start subsequent steps. + | flavorIndex `Set.notMember` state.stopRequested + -> do + result <- startSteps flavorIndex nextSteps + pure + ( state + { processes = Map.alter + (\_ -> fst <$> result) flavorIndex state.processes + } + , maybe (pure ()) snd result + ) + _ -> do + doneWithFlavor + pure + ( state + { processes = Map.delete flavorIndex state.processes + , stopRequested = Set.delete flavorIndex state.stopRequested + } + , pure () + ) + signal -- possibly send the 'OnStepStarted' event waitForDone :: IO () waitForDone = do