From da18744ef9bdecfde4a2ada68632716822e39e6f Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 10 Aug 2026 14:54:08 +0200 Subject: [PATCH 01/17] Fix #12119 --- .../Distribution/Solver/Modular/Dependency.hs | 33 +++++++++++++--- .../src/Distribution/Solver/Modular/Flag.hs | 30 +++++++++++--- .../src/Distribution/Solver/Modular/Index.hs | 24 ++++++++++-- .../Solver/Modular/IndexConversion.hs | 1 + .../Distribution/Solver/Modular/Package.hs | 10 ++++- .../src/Distribution/Solver/Modular/Tree.hs | 13 ++++++- .../src/Distribution/Solver/Types/Flag.hs | 9 ++++- .../Distribution/Solver/Types/PackagePath.hs | 20 ++++++++-- .../Distribution/Client/ProjectPlanning.hs | 39 ++++++++++++++++--- .../Distribution/Solver/Modular/QuickCheck.hs | 8 ++-- 10 files changed, 156 insertions(+), 31 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index f002323030c..e274cf3ce15 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -65,7 +65,10 @@ import Distribution.Types.UnqualComponentName -- | Constrained instance. It represents the allowed instances for a package, -- which can be either a fixed instance or a version range. data CI = Fixed I | Constrained VR - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured CI +instance Binary CI {------------------------------------------------------------------------------- Flagged dependencies @@ -92,6 +95,10 @@ data FlaggedDep qpn = | Stanza (SN qpn) (TrueFlaggedDeps qpn) -- | Dependencies which are always enabled, for the component 'comp'. | Simple (LDep qpn) Component + deriving (Eq, Generic) + +instance Structured qpn => Structured (FlaggedDep qpn) +instance Binary qpn => Binary (FlaggedDep qpn) -- | Conservatively flatten out flagged dependencies -- @@ -114,6 +121,10 @@ type FalseFlaggedDeps qpn = FlaggedDeps qpn -- depending; having a 'Functor' instance makes bugs where we don't distinguish -- these two far too likely. (By rights 'LDep' ought to have two type variables.) data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) + deriving (Eq, Generic) + +instance Structured qpn => Structured (LDep qpn) +instance Binary qpn => Binary (LDep qpn) -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as @@ -122,26 +133,38 @@ data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component | Ext Extension -- ^ dependency on a language extension | Lang Language -- ^ dependency on a language version | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package - deriving Functor + deriving (Functor, Eq, Generic) + +instance Structured qpn => Structured (Dep qpn) +instance Binary qpn => Binary (Dep qpn) -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. data PkgComponent qpn = PkgComponent qpn ExposedComponent - deriving (Eq, Ord, Functor, Show) + deriving (Eq, Ord, Functor, Show, Generic) + +instance Structured qpn => Structured (PkgComponent qpn) +instance Binary qpn => Binary (PkgComponent qpn) -- | A component that can be depended upon by another package, i.e., a library -- or an executable. data ExposedComponent = ExposedLib LibraryName | ExposedExe UnqualComponentName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured ExposedComponent +instance Binary ExposedComponent -- | The reason that a dependency is active. It identifies the package and any -- flag and stanza choices that introduced the dependency. It contains -- everything needed for creating ConflictSets or describing conflicts in solver -- log messages. data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) - deriving (Functor, Eq, Show) + deriving (Functor, Eq, Show, Generic) + +instance Structured qpn => Structured (DependencyReason qpn) +instance Binary qpn => Binary (DependencyReason qpn) -- | Print the reason that a dependency was introduced. showDependencyReason :: DependencyReason QPN -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs index a7796ad8ad5..67de583af52 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Flag.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Modular.Flag ( FInfo(..) , Flag @@ -20,16 +22,22 @@ module Distribution.Solver.Modular.Flag import Data.Map as M import Prelude hiding (pi) +import GHC.Generics import qualified Distribution.PackageDescription as P -- from Cabal import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath +import Distribution.Utils.Structured (Structured (..)) +import Distribution.Compat.Binary (Binary) -- | Flag name. Consists of a package instance and the flag identifier itself. data FN qpn = FN qpn Flag - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Ord, Show, Functor, Generic) + +instance Structured qpn => Structured (FN qpn) +instance Binary qpn => Binary (FN qpn) -- | Flag identifier. Just a string. type Flag = P.FlagName @@ -47,7 +55,10 @@ mkFlag = P.mkFlagName -- whether the flag is weak. Manual flags can only be set explicitly. -- Weak flags are typically deferred by the solver. data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured FInfo +instance Binary FInfo -- | Flag defaults. type FlagInfo = Map Flag FInfo @@ -57,7 +68,10 @@ type QFN = FN QPN -- | Stanza name. Paired with a package name, much like a flag. data SN qpn = SN qpn Stanza - deriving (Eq, Ord, Show, Functor) + deriving (Eq, Ord, Show, Functor, Generic) + +instance Structured qpn => Structured (SN qpn) +instance Binary qpn => Binary (SN qpn) -- | Qualified stanza name. type QSN = SN QPN @@ -74,12 +88,18 @@ type QSN = SN QPN -- special case of triviality we actually consider is if there are no new -- dependencies introduced by the choice. newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured WeakOrTrivial +instance Binary WeakOrTrivial -- | Value shown for a flag in a solver log message. The message can refer to -- only the true choice, only the false choice, or both choices. data FlagValue = FlagTrue | FlagFalse | FlagBoth - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured FlagValue +instance Binary FlagValue showQFNBool :: QFN -> Bool -> String showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index 2f28d12de85..2b0ad18ae6f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + module Distribution.Solver.Modular.Index ( Index , PInfo(..) @@ -13,11 +15,14 @@ import Prelude hiding (pi) import Data.Map (Map) import qualified Data.List as L import qualified Data.Map as M +import GHC.Generics import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree +import Distribution.Utils.Structured (Structured (..)) +import Distribution.Compat.Binary (Binary) -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped @@ -36,21 +41,34 @@ data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent ComponentInfo) FlagInfo (Maybe FailReason) + deriving (Eq, Generic) + +instance Structured PInfo +instance Binary PInfo -- | Info associated with each library and executable in a package instance. data ComponentInfo = ComponentInfo { compIsVisible :: IsVisible , compIsBuildable :: IsBuildable } - deriving Show + deriving (Show, Eq, Generic) + +instance Structured ComponentInfo +instance Binary ComponentInfo -- | Whether a component is visible in the current environment. newtype IsVisible = IsVisible Bool - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured IsVisible +instance Binary IsVisible -- | Whether a component is made unbuildable by a "buildable: False" field. newtype IsBuildable = IsBuildable Bool - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured IsBuildable +instance Binary IsBuildable mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index 77e6867e1c6..252c7741ddd 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -1,5 +1,6 @@ module Distribution.Solver.Modular.IndexConversion ( convPIs + , convSP ) where import Distribution.Solver.Compat.Prelude diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index 25b79522729..0e8358abac4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -49,11 +49,17 @@ type PId = UnitId -- -- TODO: More information is needed about the repo. data Loc = Inst PId | InRepo - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured Loc +instance Binary Loc -- | Instance. A version number and a location. data I = I Ver Loc - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured I +instance Binary I -- | String representation of an instance. showI :: I -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index 48fb3537081..61fb492bc9e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -21,7 +21,9 @@ import Control.Monad hiding (mapM, sequence) import Data.Foldable import Data.Traversable import Prelude hiding (foldr, mapM, sequence) +import GHC.Generics +import Distribution.Compat.Binary (Binary) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package @@ -34,6 +36,7 @@ import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnitId (UnitId) +import Distribution.Utils.Structured (Structured (..)) import Language.Haskell.Extension (Extension, Language) type Weight = Double @@ -129,11 +132,17 @@ data FailReason = UnsupportedExtension Extension | DependenciesNotLinked String | CyclicDependencies | UnsupportedSpecVer Ver - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured FailReason +instance Binary FailReason -- | Information about a dependency involved in a conflict, for error messages. data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured ConflictingDep +instance Binary ConflictingDep -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' -- have the same meaning as in 'Tree'. diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs b/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs index 18ce1df3243..c8816ffa19a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Flag.hs @@ -3,6 +3,13 @@ module Distribution.Solver.Types.Flag ) where import Prelude (Eq, Show) +import GHC.Generics + +import Distribution.Utils.Structured (Structured (..)) +import Distribution.Compat.Binary (Binary) data FlagType = Manual | Automatic - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance Structured FlagType +instance Binary FlagType diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..23a101df24b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -18,7 +18,10 @@ import qualified Text.PrettyPrint as Disp -- | A package path consists of a namespace and a package path inside that -- namespace. data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured PackagePath +instance Binary PackagePath -- | Top-level namespace -- @@ -30,7 +33,10 @@ data Namespace = -- | A namespace for a specific build target | Independent PackageName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured Namespace +instance Binary Namespace -- | Pretty-prints a namespace. The result is either empty or -- ends in a period, so it can be prepended onto a qualifier. @@ -68,7 +74,10 @@ data Qualifier = -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | QualExe PackageName PackageName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured Qualifier +instance Binary Qualifier -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. @@ -87,7 +96,10 @@ dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Structured a => Structured (Qualified a) +instance Binary a => Binary (Qualified a) -- | Qualified package name. type QPN = Qualified PackageName diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index c325f75b89a..6ec16026370 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -136,7 +136,7 @@ import Distribution.Client.RebuildMonad import Distribution.Client.Setup hiding (cabalVersion, packageName) import Distribution.Client.SetupWrapper import Distribution.Client.Store -import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.Targets (userToPackageConstraint, UserConstraint) import Distribution.Client.Types import Distribution.Client.Utils (concatMapM, duplicatesBy, incVersion) @@ -156,10 +156,13 @@ import Distribution.Utils.Path hiding import qualified Hackage.Security.Client as Sec +import Distribution.Solver.Modular.Index +import Distribution.Solver.Modular.IndexConversion import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId @@ -836,7 +839,7 @@ rebuildInstallPlan verbosity fileMonitorSolverPlan ( solverSettings - , localPackages + , pinfos , localPackagesEnabledStanzas , compiler , platform @@ -883,6 +886,30 @@ rebuildInstallPlan dieWithException verbosity $ PhaseRunSolverErr msg Right plan -> return (plan, pkgConfigDB, tis, ar) where + sourcePackages :: [SourcePackage UnresolvedPkgLoc] + sourcePackages = [ pkg | SpecificSourcePackage pkg <- localPackages ] + + Platform arch os = platform + + pair lpc = + let PackageConstraint scope _ = unlabelPackageConstraint lpc + in (scopeToPackageName scope, [lpc]) + + pinfos :: [PInfo] + pinfos = [ pinfo + | (_, _, pinfo) <- + map + (convSP os arch + (compilerInfo compiler) + (Map.fromListWith (++) $ map (pair . settingConstraintToLPC) $ solverSettingConstraints solverSettings) + (solverSettingStrongFlags solverSettings) + (SolveExecutables True) + ) + sourcePackages + ] + + -- TODO: project localPackages down to PInfo + corePackageDbs :: PackageDBStackCWD corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared) @@ -1423,9 +1450,7 @@ planPackages ] . addConstraints -- version constraints from the config file or command line - [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints - ] + (map settingConstraintToLPC solverSettingConstraints) . addPreferences -- enable stanza preference unilaterally, regardless if the user asked -- accordingly or expressed no preference, to help hint the solver @@ -1563,6 +1588,10 @@ planPackages setupMaxCabalVersionConstraint = alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion +settingConstraintToLPC :: (UserConstraint, ConstraintSource) -> LabeledPackageConstraint +settingConstraintToLPC (pc, src) = + LabeledPackageConstraint (userToPackageConstraint pc) src + ------------------------------------------------------------------------------ -- * Install plan post-processing diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 41e77e9c2c2..cd42f0f03f4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -637,10 +637,10 @@ instance ArbitraryOrd ShortText where pure $ \l r -> strc (fromShortText l) (fromShortText r) deriving instance Generic (Variable pn) -deriving instance Generic (P.Qualified a) -deriving instance Generic P.PackagePath -deriving instance Generic P.Namespace -deriving instance Generic P.Qualifier +-- deriving instance Generic (P.Qualified a) +-- deriving instance Generic P.PackagePath +-- deriving instance Generic P.Namespace +-- deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs From 535276e99368a375607d36a518cf740bd9b38781 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 10 Aug 2026 15:14:54 +0200 Subject: [PATCH 02/17] Cleanup --- .../Distribution/Client/ProjectPlanning.hs | 35 ++++++++++--------- .../Distribution/Solver/Modular/QuickCheck.hs | 4 --- 2 files changed, 18 insertions(+), 21 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 6ec16026370..497425b41ad 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -136,7 +136,7 @@ import Distribution.Client.RebuildMonad import Distribution.Client.Setup hiding (cabalVersion, packageName) import Distribution.Client.SetupWrapper import Distribution.Client.Store -import Distribution.Client.Targets (userToPackageConstraint, UserConstraint) +import Distribution.Client.Targets (UserConstraint, userToPackageConstraint) import Distribution.Client.Types import Distribution.Client.Utils (concatMapM, duplicatesBy, incVersion) @@ -887,28 +887,29 @@ rebuildInstallPlan Right plan -> return (plan, pkgConfigDB, tis, ar) where sourcePackages :: [SourcePackage UnresolvedPkgLoc] - sourcePackages = [ pkg | SpecificSourcePackage pkg <- localPackages ] + sourcePackages = [pkg | SpecificSourcePackage pkg <- localPackages] Platform arch os = platform pair lpc = - let PackageConstraint scope _ = unlabelPackageConstraint lpc - in (scopeToPackageName scope, [lpc]) + let PackageConstraint scope _ = unlabelPackageConstraint lpc + in (scopeToPackageName scope, [lpc]) pinfos :: [PInfo] - pinfos = [ pinfo - | (_, _, pinfo) <- - map - (convSP os arch - (compilerInfo compiler) - (Map.fromListWith (++) $ map (pair . settingConstraintToLPC) $ solverSettingConstraints solverSettings) - (solverSettingStrongFlags solverSettings) - (SolveExecutables True) - ) - sourcePackages - ] - - -- TODO: project localPackages down to PInfo + pinfos = + [ pinfo + | (_, _, pinfo) <- + map + ( convSP + os + arch + (compilerInfo compiler) + (Map.fromListWith (++) $ map (pair . settingConstraintToLPC) $ solverSettingConstraints solverSettings) + (solverSettingStrongFlags solverSettings) + (SolveExecutables True) + ) + sourcePackages + ] corePackageDbs :: PackageDBStackCWD corePackageDbs = diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index cd42f0f03f4..631a0bb01e9 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -637,10 +637,6 @@ instance ArbitraryOrd ShortText where pure $ \l r -> strc (fromShortText l) (fromShortText r) deriving instance Generic (Variable pn) --- deriving instance Generic (P.Qualified a) --- deriving instance Generic P.PackagePath --- deriving instance Generic P.Namespace --- deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs From 52d7d4d5f4cd1e5edae822dc95e6d70eeb462505 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 7 Sep 2026 15:36:17 +0200 Subject: [PATCH 03/17] Fix test --- cabal-testsuite/PackageTests/ReplDashB/cabal.out | 1 - 1 file changed, 1 deletion(-) diff --git a/cabal-testsuite/PackageTests/ReplDashB/cabal.out b/cabal-testsuite/PackageTests/ReplDashB/cabal.out index 46fee55f1a9..8dc2562728b 100644 --- a/cabal-testsuite/PackageTests/ReplDashB/cabal.out +++ b/cabal-testsuite/PackageTests/ReplDashB/cabal.out @@ -1,6 +1,5 @@ # cabal clean # cabal v2-repl -Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - fake-package-0 (interactive) (lib) (first run) From 98581609adbf644a2b76bb1778adfd04bb29a01c Mon Sep 17 00:00:00 2001 From: Ilya Baryshnikov Date: Wed, 9 Sep 2026 08:23:26 +0300 Subject: [PATCH 04/17] fix bootstrap --- .github/workflows/bootstrap.yml | 9 +++++++-- bootstrap/bootstrap.py | 10 ++++++---- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/.github/workflows/bootstrap.yml b/.github/workflows/bootstrap.yml index 8f29357bd07..1b1a1922c9b 100644 --- a/.github/workflows/bootstrap.yml +++ b/.github/workflows/bootstrap.yml @@ -44,8 +44,13 @@ jobs: id: bootstrap-cache with: path: "/home/runner/work/cabal/cabal/_build" - key: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-${{ hashFiles(format('bootstrap/linux-{0}.json', matrix.ghc)) }}-${{ github.sha }} - restore-keys: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-${{ hashFiles(format('bootstrap/linux-{0}.json', matrix.ghc)) }}- + # Hash the .cabal files of the local packages into the key too: + # the bootstrap plans only reference local packages by name, so + # without this the caches of branches with different local package + # versions (e.g. master vs a release branch) collide and a stale + # _build/packages.conf gets restored. See #12311. + key: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-${{ hashFiles(format('bootstrap/linux-{0}.json', matrix.ghc), 'Cabal/Cabal.cabal', 'Cabal-syntax/Cabal-syntax.cabal', 'Cabal-hooks/Cabal-hooks.cabal', 'hooks-exe/hooks-exe.cabal', 'cabal-install-solver/cabal-install-solver.cabal', 'cabal-install/cabal-install.cabal') }}-${{ github.sha }} + restore-keys: bootstrap-${{ steps.get-osver.outputs.osver }}-${{ matrix.ghc }}-${{ hashFiles(format('bootstrap/linux-{0}.json', matrix.ghc), 'Cabal/Cabal.cabal', 'Cabal-syntax/Cabal-syntax.cabal', 'Cabal-hooks/Cabal-hooks.cabal', 'hooks-exe/hooks-exe.cabal', 'cabal-install-solver/cabal-install-solver.cabal', 'cabal-install/cabal-install.cabal') }}- - uses: haskell-actions/setup@v2 with: diff --git a/bootstrap/bootstrap.py b/bootstrap/bootstrap.py index 5638b13648c..30dcd9044d7 100755 --- a/bootstrap/bootstrap.py +++ b/bootstrap/bootstrap.py @@ -275,10 +275,12 @@ def hash_file(h, f: BinaryIO) -> SHA256Hash: PlanUnit = NewType('PlanUnit', dict) def bootstrap(info: BootstrapInfo, ghc: Compiler) -> None: - if not PKG_DB.exists(): - print(f'Creating package database {PKG_DB}') - PKG_DB.parent.mkdir(parents=True, exist_ok=True) - subprocess_run([ghc.ghc_pkg_path, 'init', PKG_DB]) + if PKG_DB.exists(): + print(f'Deleting stale package database {PKG_DB}') + shutil.rmtree(PKG_DB) + print(f'Creating package database {PKG_DB}') + PKG_DB.parent.mkdir(parents=True, exist_ok=True) + subprocess_run([ghc.ghc_pkg_path, 'init', PKG_DB]) for dep in info.builtin: check_builtin(dep, ghc) From 0865a386ff852f7012cda837796246a8136ca8a9 Mon Sep 17 00:00:00 2001 From: sheaf Date: Thu, 27 Aug 2026 13:30:52 +0200 Subject: [PATCH 05/17] Allow minor Cabal version bumps without recompiling We now don't store the specific Cabal library version used to provide the Setup CLI, which allows us to re-use an install plan made with another Cabal library version that is still compatible (e.g. across a minor version bump). Fixes #11416 --- .../src/Distribution/Client/Configure.hs | 20 +-- .../Client/ProjectBuilding/UnpackedPackage.hs | 15 +- .../Distribution/Client/ProjectPlanOutput.hs | 2 +- .../Distribution/Client/ProjectPlanning.hs | 33 ++--- .../Client/ProjectPlanning/SetupPolicy.hs | 34 ++--- .../Client/ProjectPlanning/Types.hs | 75 +++++++--- .../src/Distribution/Client/SetupWrapper.hs | 135 +++++++++++------- changelog.d/T11416.md | 20 +++ 8 files changed, 208 insertions(+), 126 deletions(-) create mode 100644 changelog.d/T11416.md diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 6a4e3d0016c..9b4e31177b7 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -42,7 +42,8 @@ import Distribution.Client.Setup , filterConfigureFlags ) import Distribution.Client.SetupWrapper - ( SetupRunnerArgs (NotInLibrary) + ( SetupDependencies (..) + , SetupRunnerArgs (NotInLibrary) , SetupScriptOptions (..) , defaultSetupScriptOptions , setupWrapper @@ -288,14 +289,15 @@ configureSetupScript , useExtraEnvOverrides = [] , setupCacheLock = lock , useWin32CleanHack = False - , -- If we have explicit setup dependencies, list them; otherwise, we give - -- the empty list of dependencies; ideally, we would fix the version of - -- Cabal here, so that we no longer need the special case for that in - -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet - -- know the version of Cabal at this point, but only find this there. - -- Therefore, for now, we just leave this blank. - useDependencies = fromMaybe [] explicitSetupDeps - , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps + , -- If the @custom-setup@ stanza has an explicit list of dependencies, + -- use those exclusively. Otherwise, the list is not exhaustive, and + -- we have a special case in 'SetupWrapper' to go looking for a Cabal + -- library. We don't yet know its version, so for now we leave the list + -- of implicit dependencies blank. + useSetupDependencies = + case explicitSetupDeps of + Just deps | not defaultSetupDeps -> ExplicitSetupDeps deps + _ -> ImplicitSetupDeps (fromMaybe [] explicitSetupDeps) , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps , isInteractive = False , isMainLibOrExeComponent = True diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 30d235bbcde..9f6b202830c 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -667,7 +667,7 @@ buildInplaceUnpackedPackage Simple -> listSimple Hooks -> listSdist `ifNullThen` listSimple _ - | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> + | setupCliVersion (elabSetupScriptCliVersion pkg) >= mkVersion [1, 17] -> listSdist `ifNullThen` listSimple | otherwise -> listSimple @@ -689,18 +689,19 @@ buildInplaceUnpackedPackage buildResult whenReconfigure :: IO InLibraryLBI -> IO InLibraryLBI - whenReconfigure action = + whenReconfigure configure_action = case buildStatus of - BuildStatusConfigure _ -> action + BuildStatusConfigure _ -> configure_action _ -> do -- We are skipping reconfiguration, so we recover the -- 'LocalBuildInfo' persisted by the previous 'configure'. mbOldLBI <- Cabal.tryGetPersistBuildConfig (Just srcdir) builddir case mbOldLBI of - -- #11942: if the previous LocalBuildInfo was written by an - -- external Setup.hs with an incompatible Cabal library version, - -- then we must continue to use the external setup method. - Left Cabal.ConfigStateFileBadVersion{} -> return NotInLibraryNoLBI + -- #11942: the previous 'LocalBuildInfo' was written by an + -- incompatible Cabal (either an external Setup.hs or a different + -- version of cabal-install). We can't use it at all, so we must + -- re-configure. + Left Cabal.ConfigStateFileBadVersion{} -> configure_action -- Other errors reflect genuine problems: re-throw them. Left err -> throwIO err Right lbi_wo_programs -> do diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 82e90976013..7ba35583ca0 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -220,7 +220,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- with an old lib:Cabal version. buildInfoFileLocation :: J.Pair buildInfoFileLocation - | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] = + | setupCliVersion (elabSetupScriptCliVersion elab) < mkVersion [3, 7, 0, 0] = "build-info" J..= J.Null | otherwise = "build-info" J..= J.String (getSymbolicPath $ buildInfoPref $ makeSymbolicPath dist_dir) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 497425b41ad..b696417515c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -4016,25 +4016,24 @@ setupHsScriptOptions builddir cacheLock = SetupScriptOptions - { useCabalVersion = thisVersion elabSetupScriptCliVersion - , useCabalSpecVersion = + { useCabalVersion = thisVersion cliVersion + , -- NB: for build-type: Hooks we don't want to commit to a Cabal + -- version, as all that should matter is the version of Cabal-hooks, + -- not of Cabal. + useCabalSpecVersion = if PD.buildType elabPkgDescription == PD.Hooks - then -- NB: we don't want to commit to a Cabal version here: - -- - all that should matter for Hooks build-type is the - -- version of Cabal-hooks, not of Cabal, - -- - if we commit to a Cabal version, the logic in - Nothing - else Just elabSetupScriptCliVersion + then Nothing + else Just cliVersion , useCompiler = Just pkgConfigCompiler , usePlatform = Just pkgConfigPlatform , usePackageDB = elabSetupPackageDBStack , usePackageIndex = Nothing - , useDependencies = - [ (uid, srcid) - | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- - elabSetupDependencies elab - ] - , useDependenciesExclusive = True + , useSetupDependencies = + ExplicitSetupDeps + [ (uid, srcid) + | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- + elabSetupDependencies elab + ] , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps , useProgramDb = pkgConfigCompilerProgs , useDistPref = builddir @@ -4059,6 +4058,8 @@ setupHsScriptOptions -- everything else is not a main lib or exe component ElabComponent _ -> False } + where + cliVersion = setupCliVersion elabSetupScriptCliVersion -- | To be used for the input for elaborateInstallPlan. -- @@ -4340,7 +4341,7 @@ setupHsBuildFlags par_strat elab _ common = , buildProgramArgs = mempty -- unused, set at configure time , buildNumJobs = mempty -- TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs), , buildUseSemaphore = - if elabSetupScriptCliVersion elab >= mkVersion [3, 11, 0, 0] + if setupCliVersion (elabSetupScriptCliVersion elab) >= mkVersion [3, 11, 0, 0] then -- Cabal 3.11 is the first version that supports parallelism semaphores par_strat else mempty @@ -4349,7 +4350,7 @@ setupHsBuildFlags par_strat elab _ common = setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] setupHsBuildArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _}) -- Fix for #3335, don't pass build arguments if it's not supported - | elabSetupScriptCliVersion elab >= mkVersion [1, 17] = + | setupCliVersion (elabSetupScriptCliVersion elab) >= mkVersion [1, 17] = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) | otherwise = [] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs index e3a6595ecdb..1ac2e31b4ea 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/SetupPolicy.hs @@ -7,20 +7,8 @@ -- functions for both phases together here so at least you can see all of it -- in one place. -- --- There are four major cases for Setup.hs handling: --- --- 1. @build-type@ Custom with a @custom-setup@ section --- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ --- --- It's also worth noting that packages specifying @cabal-version: >= 1.23@ --- or later that have @build-type@ Custom will always have a @custom-setup@ --- section. Therefore in case 2, the specified @cabal-version@ will always be --- less than 1.23. --- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. +-- There are four major cases for Setup.hs handling; see the documentation of +-- 'SetupScriptStyle' in Distribution.Client.ProjectPlanning.Types. -- -- @since 3.12.0.0 module Distribution.Client.ProjectPlanning.SetupPolicy @@ -34,7 +22,10 @@ where import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.ProjectPlanning.Types (SetupScriptStyle (..)) +import Distribution.Client.ProjectPlanning.Types + ( SetupCliVersion (..) + , SetupScriptStyle (..) + ) import Distribution.Client.SolverInstallPlan (SolverPlanPackage) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD @@ -192,24 +183,25 @@ packageSetupScriptSpecVersion -> PackageDescription -> Graph.Graph NonSetupLibDepSolverPlanPackage -> ComponentDeps [SolverId] - -> Version + -> SetupCliVersion -- We're going to be using the internal Cabal library, so the spec version of -- that is simply the version of the Cabal library that cabal-install has been -- built with. packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ = - cabalVersion + InternalCabalLib -- If we happen to be building the Cabal lib itself then because that -- bootstraps itself then we use the version of the lib we're building. packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _ | packageName pkg == cabalPkgname = - packageVersion pkg + ExternalCabalLib $ packageVersion pkg -- In all other cases we have a look at what version of the Cabal lib the -- solver picked. Or if it didn't depend on Cabal at all (which is very rare) -- then we look at the .cabal file to see what spec version it declares. packageSetupScriptSpecVersion _ pkg libDepGraph deps = - case find ((cabalPkgname ==) . packageName) setupLibDeps of - Just dep -> packageVersion dep - Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)) + ExternalCabalLib $ + case find ((cabalPkgname ==) . packageName) setupLibDeps of + Just dep -> packageVersion dep + Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg)) where setupLibDeps = maybe [] (map packageId) (Graph.closure libDepGraph (CD.setupDeps deps)) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 89fc0e54bdf..15d91232441 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -57,6 +57,8 @@ module Distribution.Client.ProjectPlanning.Types -- * Setup script , SetupScriptStyle (..) + , SetupCliVersion (..) + , setupCliVersion ) where import Distribution.Client.Compat.Prelude @@ -102,7 +104,7 @@ import Distribution.Simple.Setup , ReplOptions , TestShowDetails ) -import Distribution.Simple.Utils (ordNub) +import Distribution.Simple.Utils (cabalVersion, ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza @@ -313,15 +315,10 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage elabSetupScriptStyle :: SetupScriptStyle -- ^ One of four modes for how we build and interact with the Setup.hs - -- script, based on whether it's a build-type Custom, with or without - -- explicit deps and the cabal spec version the .cabal file needs. - , elabSetupScriptCliVersion :: Version - -- ^ The version of the Cabal command line interface that we are using - -- for this package. This is typically the version of the Cabal lib - -- that the Setup.hs is built against. - -- - -- TODO: We might want to turn this into a enum, - -- yet different enum than 'CabalSpecVersion'. + -- script, based on whether it's a build-type Custom or Hooks, with or + -- without explicit deps, and the cabal spec version the .cabal file needs. + , elabSetupScriptCliVersion :: SetupCliVersion + -- ^ The Cabal library version used to provide the Setup CLI. , -- Build time related: elabConfigureTargets :: [ComponentTarget] , elabBuildTargets :: [ComponentTarget] @@ -914,26 +911,62 @@ componentOptionalStanza _ = Nothing -- | There are four major cases for Setup.hs handling: -- --- 1. @build-type@ Custom with a @custom-setup@ section +-- 1. @build-type@ Custom or Hooks with a @custom-setup@ section -- 2. @build-type@ Custom without a @custom-setup@ section --- 3. @build-type@ not Custom with @cabal-version > $our-cabal-version@ --- 4. @build-type@ not Custom with @cabal-version <= $our-cabal-version@ +-- 3. @build-type@ neither Custom nor Hooks, with +-- @cabal-version > $our-cabal-version@ +-- 4. @build-type@ neither Custom nor Hooks, with +-- @cabal-version <= $our-cabal-version@ -- -- It's also worth noting that packages specifying @cabal-version: >= 1.23@ -- or later that have @build-type@ Custom will always have a @custom-setup@ -- section. Therefore in case 2, the specified @cabal-version@ will always be -- less than 1.23. -- --- In cases 1 and 2 we obviously have to build an external Setup.hs script, --- while in case 4 we can use the internal library API. In case 3 we also have --- to build an external Setup.hs script because the package needs a later --- Cabal lib version than we can support internally. +-- In cases 1 and 2 we obviously have to compile an external program: a +-- Setup.hs script for build-type Custom, and the hooks executable for +-- build-type Hooks (with a possible fallback to a Setup.hs). +-- In case 3 we also have to build an external Setup.hs script, because the +-- package needs a later Cabal lib version than we can support internally. +-- Only in case 4 can we use the internal library API alone. data SetupScriptStyle - = SetupCustomExplicitDeps - | SetupCustomImplicitDeps - | SetupNonCustomExternalLib - | SetupNonCustomInternalLib + = -- | @build-type: Custom@ (or @Hooks@) with explicit @setup-depends@ + SetupCustomExplicitDeps + | -- | @build-type: Custom@ without an explicit @setup-depends@ + SetupCustomImplicitDeps + | -- | Non-Custom/Hooks build-type, but we fall back to an external @Setup.hs@ + -- in order to satisfy Cabal version constraints. + SetupNonCustomExternalLib + | -- | Non-Custom/Hooks build type: Cabal provides the Setup.hs CLI internally. + SetupNonCustomInternalLib deriving (Eq, Show, Generic) instance Binary SetupScriptStyle instance Structured SetupScriptStyle + +-- | The version of the Cabal library used to provide the Setup CLI. +-- +-- The version corresponds to the 'SetupScriptStyle' we use: for +-- 'SetupNonCustomInternalLib' we use the Cabal library that @cabal-install@ was +-- built against, and for every other 'SetupScripStyle' we pick the version +-- chosen by the solver to compile the Setup script. +data SetupCliVersion + = -- | Use the Cabal library version that @cabal-install@ was linked against + -- to provide the Setup CLI. + InternalCabalLib -- NB: this very carefully __does not__ store a version number. + -- + -- This is because of #11416: the install plan is cached across @cabal-install@ + -- invocations, so we should not pin a Cabal library version which would + -- go stale when doing a minor @cabal-install@ upgrade. + | -- | Use the Cabal library version picked by the solver to provide + -- the Setup CLI. + ExternalCabalLib !Version + deriving (Eq, Show, Generic) + +instance Binary SetupCliVersion +instance Structured SetupCliVersion + +-- | The version of the Cabal library used to provide the Setup CLI. +setupCliVersion :: SetupCliVersion -> Version +setupCliVersion InternalCabalLib = cabalVersion +setupCliVersion (ExternalCabalLib version) = version diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 69b9b2dc980..4feb5e1827b 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -31,6 +31,8 @@ module Distribution.Client.SetupWrapper , RightFlagsForPhase , setupWrapper , SetupScriptOptions (..) + , SetupDependencies (..) + , setupDependencies , defaultSetupScriptOptions , externalSetupMethod ) where @@ -292,17 +294,45 @@ data SetupMethod (kind :: SetupKind) where -- -- See also the discussion at https://github.com/haskell/cabal/pull/3094 +-- | The dependencies to use to compile an external @Setup@ executable. +data SetupDependencies + = -- | An exhaustive set of dependencies to compile the Setup script against. + -- + -- These are used __exclusively__, hiding every other package in the + -- package databases. + -- + -- Whether the @Cabal@ library is among these is the package's business: a + -- @custom-setup@ stanza may leave it out if its @Setup.hs@ does not need + -- it. + ExplicitSetupDeps [(ComponentId, PackageId)] + | -- | A non-exhaustive set of dependencies to compile the Setup script against. + -- + -- We keep all other packages in the package databases visible as well. + -- + -- We also go looking for a @Cabal@ library in the package databases, adding + -- it to this list of dependencies if it doesn't already contain one. + ImplicitSetupDeps [(ComponentId, PackageId)] + +-- | The dependencies to use to compile an external @Setup@ executable, whether +-- or not they are to be used exclusively. +-- +-- Prefer matching on 'SetupDependencies' where the distinction matters. +setupDependencies :: SetupDependencies -> [(ComponentId, PackageId)] +setupDependencies (ExplicitSetupDeps deps) = deps +setupDependencies (ImplicitSetupDeps deps) = deps + -- | @SetupScriptOptions@ are options used to configure and run 'Setup', as -- opposed to options given to the Cabal command at runtime. data SetupScriptOptions = SetupScriptOptions { useCabalVersion :: VersionRange - -- ^ The version of the Cabal library to use (if 'useDependenciesExclusive' - -- is not set). A suitable version of the Cabal library must be installed - -- (or for some build-types be the one cabal-install was built with). + -- ^ The acceptable Cabal library version range for this Setup script. -- - -- The version found also determines the version of the Cabal specification - -- that we us for talking to the Setup.hs, unless overridden by - -- 'useCabalSpecVersion'. + -- This determines: + -- - whether the Cabal library that cabal-install is linked against can + -- provide the Setup CLI, + -- - which Cabal library to go looking for in package databases when + -- 'useSetupDependencies' is 'ImplicitSetupDeps', which in turn decides + -- which Cabal specification we use to talk with the @Setup@ executable. , useCabalSpecVersion :: Maybe Version -- ^ This is the version of the Cabal specification that we believe that -- this package uses. This affects the semantics and in particular the @@ -310,9 +340,7 @@ data SetupScriptOptions = SetupScriptOptions -- -- This is similar to 'useCabalVersion' but instead of probing the system -- for a version of the /Cabal library/ you just say exactly which version - -- of the /spec/ we will use. Using this also avoids adding the Cabal - -- library as an additional dependency, so add it to 'useDependencies' - -- if needed. + -- of the /spec/ we will use. , useCompiler :: Maybe Compiler , usePlatform :: Maybe Platform , usePackageDB :: PackageDBStackCWD @@ -328,23 +356,9 @@ data SetupScriptOptions = SetupScriptOptions -- -- * @'Just' v@ means \"set the environment variable's value to @v@\". -- * 'Nothing' means \"unset the environment variable\". - , useDependencies :: [(ComponentId, PackageId)] - -- ^ List of dependencies to use when building Setup.hs. - , useDependenciesExclusive :: Bool - -- ^ Is the list of setup dependencies exclusive? - -- - -- When this is @False@, if we compile the Setup.hs script we do so with the - -- list in 'useDependencies' but all other packages in the environment are - -- also visible. A suitable version of @Cabal@ library (see - -- 'useCabalVersion') is also added to the list of dependencies, unless - -- 'useDependencies' already contains a Cabal dependency. - -- - -- When @True@, only the 'useDependencies' packages are used, with other - -- packages in the environment hidden. - -- - -- This feature is here to support the setup stanza in .cabal files that - -- specifies explicit (and exclusive) dependencies, as well as the old - -- style with no dependencies. + , useSetupDependencies :: SetupDependencies + -- ^ The dependencies to use when building Setup.hs, and whether they are to + -- be used exclusively. , useVersionMacros :: Bool -- ^ Should we build the Setup.hs with CPP version macros available? -- We turn this on when we have a setup stanza in .cabal that declares @@ -393,8 +407,7 @@ defaultSetupScriptOptions = , usePlatform = Nothing , usePackageDB = [GlobalPackageDB, UserPackageDB] , usePackageIndex = Nothing - , useDependencies = [] - , useDependenciesExclusive = False + , useSetupDependencies = ImplicitSetupDeps [] , useVersionMacros = False , useProgramDb = emptyProgramDb , useDistPref = defaultDistPref @@ -510,9 +523,13 @@ withSetupMethod verbosity options pkg buildType' allowInLibrary with Nothing -> False withExternalSetupMethod = do debug verbosity $ "Using external setup method with build-type " ++ show buildType' - debug verbosity $ - "Using explicit dependencies: " - ++ show (useDependenciesExclusive options) + debug verbosity $ case useSetupDependencies options of + ExplicitSetupDeps deps -> + "Using explicit dependencies: " + ++ show (map (prettyShow . snd) deps) + ImplicitSetupDeps deps -> + "Using implicit dependencies: " + ++ show (map (prettyShow . snd) deps) with <$> compileExternalExe verbosity options pkg buildType' WantSetup runSetupMethod :: WithCallStack (SetupMethod GeneralSetup -> SetupRunner UseGeneralSetup) @@ -915,14 +932,14 @@ compileExternalExe verbosity options pkg bt wantedExe = do platform = fromMaybe buildPlatform (usePlatform options) -- | Extract the Cabal library version from 'SetupScriptOptions' if it is --- already determined: either by the solver via 'useDependencies', or directly --- via 'useCabalSpecVersion' (used for build-type: Custom packages whose --- setup-depends does not include a transitive Cabal dependency). +-- already determined: either by the solver via 'useSetupDependencies', or +-- directly via 'useCabalSpecVersion' (used for build-type: Custom packages +-- whose setup-depends does not include a transitive Cabal dependency). cabalLibFromOptions :: SetupScriptOptions -> Maybe (Version, Maybe ComponentId) cabalLibFromOptions options = - case find (isCabalPkgId . snd) (useDependencies options) of + case find (isCabalPkgId . snd) (setupDependencies (useSetupDependencies options)) of Just (unitId, pkgId) -> Just (pkgVersion pkgId, Just unitId) Nothing -> case useCabalSpecVersion options of @@ -1260,18 +1277,16 @@ compileSetupX (\ipkgid -> [(ipkgid, cabalPkgid)]) maybeCabalLibInstalledPkgId - -- With 'useDependenciesExclusive' and Custom build type, - -- we enforce the deps specified, so only the given ones can be used. - -- Otherwise we add on a dep on the Cabal library - -- (unless 'useDependencies' already contains one). - selectedDeps - | (useDependenciesExclusive options' && (bt /= Hooks)) - -- NB: to compile build-type: Hooks packages, we need Cabal - -- in order to compile @main = defaultMainWithSetupHooks setupHooks@. - || any (isCabalPkgId . snd) (useDependencies options') - = useDependencies options' - | otherwise = - useDependencies options' ++ cabalDep + setupDeps = useSetupDependencies options' + hideAllPackages = case setupDeps of + ExplicitSetupDeps{} -> True + ImplicitSetupDeps{} -> False + + selectedDeps = case setupDeps of + ExplicitSetupDeps ds -> ds + ImplicitSetupDeps ds + | any (isCabalPkgId . snd) ds -> ds + | otherwise -> ds ++ cabalDep addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) @@ -1295,8 +1310,8 @@ compileSetupX Hooks -> toNubListR [sameDirectory] _ -> mempty , ghcOptPackageDBs = pkgDbs - , ghcOptHideAllPackages = Flag (useDependenciesExclusive options') - , ghcOptCabal = Flag (useDependenciesExclusive options') + , ghcOptHideAllPackages = Flag hideAllPackages + , ghcOptCabal = Flag hideAllPackages , ghcOptPackages = toNubListR $ map addRenaming selectedDeps -- With 'useVersionMacros', use a version CPP macros .h file. , ghcOptCppIncludes = @@ -1313,6 +1328,19 @@ compileSetupX -- when compiling a simple Setup.hs file. , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler } + -- Sanity check: if we generated Setup.hs ourselves (the non-Custom case), + -- make sure we provide a Cabal dependency when building it. + -- This allows us to report a custom message for #11416 instead of giving + -- the user a confusing GHC error. + when (hideAllPackages && bt /= Custom && not (any (isCabalPkgId . snd) selectedDeps)) $ + die' verbosity $ unwords + [ "internal error: no Cabal library is available to compile the" + , what + , "executable for the" + , prettyShow bt + , "package" + , prettyShow pkgId ++ "." + ] let ghcCmdLine = renderGhcOptions compiler platform ghcOptions when (useVersionMacros options') $ rewriteFileEx verbosity (i cppMacrosFile) $ @@ -1347,8 +1375,13 @@ isBasePkgId (PackageIdentifier pname _) = pname == mkPackageName "base" -- Hopefully we can get rid of all of this before long, simplifying this -- annoyingly complex module. -- --- The v1 code path corresponds to 'useDependencies' being unset --- (no pre-computed dependencies by the solver). +-- These functions locate a Cabal library by searching the package databases. +-- They are reached whenever the 'SetupScriptOptions' do not already determine +-- one, i.e. when no Cabal library appears in 'useSetupDependencies' and +-- 'useCabalSpecVersion' is unset. In practice that is the v1 code path, which +-- leaves 'useCabalSpecVersion' unset; note that it is not the same thing as +-- 'ImplicitSetupDeps', which v1 uses only for packages without an explicit +-- @custom-setup@ stanza. -- | **v1-only** -- diff --git a/changelog.d/T11416.md b/changelog.d/T11416.md new file mode 100644 index 00000000000..36097e13f1c --- /dev/null +++ b/changelog.d/T11416.md @@ -0,0 +1,20 @@ +--- +synopsis: Allow minor Cabal version bumps without recompiling +packages: [cabal-install] +prs: 12289 +issues: 11416 +--- + +Fix a bug in which changing the version of `cabal-install` without clearing +`dist-newstyle` could cause subsequent builds to fail with an error of the form: + +```txt +setup.hs:2:1: error: [GHC-87110] + Could not load module 'Distribution.Simple'. + It is a member of the hidden package 'Cabal-x.y.z'. + Perhaps you need to add 'Cabal' to the build-depends in your .cabal file. +``` + +A safeguard is also put in place to provide a more understandable error should +this ever arise again, instead of the nonsense GHC error above which provides a +non-actionable hint. From 53473f78d585805ac8e9dc94d13ae9c8c69ebe57 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 3 Aug 2026 15:25:50 +0800 Subject: [PATCH 06/17] cabal-install: only add base>=4.22 constraint with wired-in unit ids `dependOnWiredIns` adds two kinds of constraint: one installed-unit-id constraint per wired-in unit of the compiler, and one `base >= 4.22` version constraint. The second only makes sense next to the first. The unit-id constraints pin the new, reinstallable `base`; the version constraint then excludes the old, non-reinstallable one. But it was added unconditionally, while the unit-id constraints are empty for a compiler that reports no wired-in units. Such a compiler has no installed `base` satisfying the bound, so plans that reach this code fail, and `--allow-boot-library-installs` alone is enough to reach it. Fixes #12328. --- cabal-install/src/Distribution/Client/Dependency.hs | 9 ++++++--- .../UnitTests/Distribution/Solver/Modular/Solver.hs | 7 +++++++ changelog.d/base-422-wired-in-guard.md | 10 ++++++++++ 3 files changed, 23 insertions(+), 3 deletions(-) create mode 100644 changelog.d/base-422-wired-in-guard.md diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index afc77c032aa..04815cea7d5 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -445,13 +445,16 @@ setSolverVerbosity verbosity params = } dependOnWiredIns :: CompilerInfo -> DepResolverParams -> DepResolverParams -dependOnWiredIns compiler params = addConstraints extraConstraints params +dependOnWiredIns compiler params = + case compilerInfoWiredInUnitIds compiler of + Nothing -> params + Just wiredInUnitIds -> addConstraints (extraConstraints wiredInUnitIds) params where - extraConstraints = + extraConstraints wiredInUnitIds = [ LabeledPackageConstraint (PackageConstraint (ScopeAnyQualifier pkgName) (PackagePropertyInstalledSpecificUnitId unitId)) ConstraintSourceNonReinstallablePackage - | (pkgName, unitId) <- fromMaybe [] $ compilerInfoWiredInUnitIds compiler + | (pkgName, unitId) <- wiredInUnitIds ] ++ -- Old versions of `base` must be excluded from build plans still as they do not depend on any version of a wired-in unit. diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index d76928e982f..cdacc2ee44b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -218,6 +218,13 @@ tests = allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ solverSuccess [("base", 5), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] + , -- The base >= 4.22 constraint only makes sense alongside the wired-in + -- unit id constraints. A compiler that reports none has no installed + -- base satisfying it, so it must not be added here. + runTest $ + allowBootLibInstalls $ + mkTest dbBaseOld "Install old base with --allow-boot-library-installs" ["base"] $ + solverSuccess [("base", 1)] ] , testGroup "Reinstallable base, template-haskell, but not ghc{,-internal} (GHC with wiredInUnitIds)" diff --git a/changelog.d/base-422-wired-in-guard.md b/changelog.d/base-422-wired-in-guard.md new file mode 100644 index 00000000000..cdcb654fd59 --- /dev/null +++ b/changelog.d/base-422-wired-in-guard.md @@ -0,0 +1,10 @@ +--- +synopsis: Fix `--allow-boot-library-installs` on GHC < 9.14 +packages: [cabal-install] +prs: 12301 +issues: 12328 +--- + +`--allow-boot-library-installs` made builds fail on compilers that report no +wired-in unit ids, because `base` was constrained to version 4.22 or later +regardless of the compiler. From b5ae1d62ac8463de6935e92d34bde1f7f4648a40 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 16 Jun 2026 15:37:12 +0200 Subject: [PATCH 07/17] Refactoring in preparation of #11411 This commit includes a series of refactorings that are necessary to solve #11411: - Abstract the Rebuild monad into the MonadRebuild typeclass, introducing the `withRunRebuildInIO` method of MonadRebuild. This allows us to interleave plain `IO` with `MonadRebuild` without necessarily having to use `Rebuild` itself. This is especially important because `Rebuild` also encodes the "current working directory" concern, which is relevant within `cabal-install`, but something we don't want to require within the `Cabal` library. Since the `MonadRebuild` typeclass allows for arbitrary custom monadic state per instance, it can live in the `Cabal` subproject, together with operations defined in terms of the typeclass, while `Rebuild` itself remains in `cabal-install`, using the custom monadic state to cover the "current working directory" concern. - Change the `StateT` part of `Rebuild` into `WriterT`, since we only ever emit additional files from within a Rebuild context; consuming them happens on the outside, so Writer is sufficient. - Provide `MonadRebuild` instances for the existing `Rebuild` type, and for the most minimal type that can satisfy the typeclass, `WriterT [MonitorFilePath] IO`. - Implement most file monitoring / Rebuild actions in terms of `MonadRebuild`, so they can live in `Cabal` (`Distribution.Simple.RebuildMonad`), leaving only `cabal-install` specific things in the existing `cabal-install` module (`Distribution.Client.RebuildMonad`). Specifically, we implement `rerunIfChanged'` in terms of `MonadRebuild` and a custom function for chaining `IO` actions (serially or in parallel, as needed); the existing `rerunIfChanged` and `rerunConcurrentlyIfChanged` functions, which live in `cabal-install`, are now implemented in terms of `rerunIfChanged'`, which lives in `Cabal`). - Move large parts of the `Distribution.Client.FileMonitor` module from `cabal-install` to `Cabal` (as `Distribution.Simple.FileMonitor`); we will be needing these parts to solve #11411 (`Distribution.Client.FileMonitor` still re-exports all of them though). - Move most of the `Distribution.Client.HashValue` module over to `Cabal` (with the exception of TUF-related functions, which are specific to `cabal-install`; again we re-export everything in `cabal-install` to maintain API compatibility). - Move `getFilePathRootDirectory` from `Distribution.Client.Glob` into `Distribution.Simple.FileMonitor.Types` - it has little to do with actual globs, and is only used for file monitoring purposes. - Shuffle some utility functions around to make them accessible where we need them. The big picture with all this is that we want to reuse the existing file monitoring machinery to keep track of build-tool versions alongside generated source files. However, the tracking needs to happen in the `Cabal` library, while file monitoring has so far only been available in `cabal-install`; hence we need to move the required file monitoring code and its dependencies into the `Cabal` library, but without introducing any `cabal-install` specific concerns into `Cabal`, and without breaking API compatibility on the `cabal-install` side. --- .../src/Test/QuickCheck/Instances/Cabal.hs | 608 +++++--- .../src/Distribution/Utils/Structured.hs | 3 + Cabal-tests/Cabal-tests.cabal | 24 + Cabal-tests/tests/LongTests.hs | 21 + .../Distribution/Simple}/FileMonitor.hs | 18 +- .../UnitTests/Distribution/Simple/Glob.hs | 191 ++- Cabal-tests/tests/UnitTests/Options.hs | 30 + Cabal/Cabal.cabal | 3 + Cabal/src/Distribution/Simple/FileMonitor.hs | 1345 +++++++++++++++++ .../Distribution/Simple/FileMonitor/Types.hs | 15 + Cabal/src/Distribution/Simple/RebuildMonad.hs | 274 ++++ Cabal/src/Distribution/Simple/Utils.hs | 35 + cabal-install/cabal-install.cabal | 4 - .../src/Distribution/Client/FileMonitor.hs | 1315 +--------------- cabal-install/src/Distribution/Client/Glob.hs | 14 - .../src/Distribution/Client/HashValue.hs | 35 +- .../Distribution/Client/ProjectPlanning.hs | 2 +- .../src/Distribution/Client/RebuildMonad.hs | 188 +-- .../src/Distribution/Client/Utils.hs | 40 +- cabal-install/tests/LongTests.hs | 3 - cabal-install/tests/UnitTests.hs | 4 - .../Distribution/Client/ArbitraryInstances.hs | 115 -- .../UnitTests/Distribution/Client/Glob.hs | 160 -- changelog.d/12065.md | 22 + 24 files changed, 2406 insertions(+), 2063 deletions(-) create mode 100644 Cabal-tests/tests/LongTests.hs rename {cabal-install/tests/UnitTests/Distribution/Client => Cabal-tests/tests/UnitTests/Distribution/Simple}/FileMonitor.hs (98%) create mode 100644 Cabal-tests/tests/UnitTests/Options.hs create mode 100644 Cabal/src/Distribution/Simple/FileMonitor.hs create mode 100644 Cabal/src/Distribution/Simple/RebuildMonad.hs delete mode 100644 cabal-install/tests/UnitTests/Distribution/Client/Glob.hs create mode 100644 changelog.d/12065.md diff --git a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs index 0cdff2283e9..40b9fb9a1c9 100644 --- a/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -1,29 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Test.QuickCheck.Instances.Cabal () where #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) #endif -import Data.Bits (countLeadingZeros, finiteBitSize, shiftL, shiftR) -import Data.Char (isAlphaNum, isDigit, toLower) -import Data.List (intercalate, (\\)) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.Bits (countLeadingZeros, finiteBitSize, shiftL, shiftR) +import Data.Char (isAlphaNum, isDigit, isLetter, toLower) +import Data.List (intercalate, (\\)) +import Data.List.NonEmpty (NonEmpty (..)) import Distribution.Utils.Generic (lowercase) import Test.QuickCheck import Distribution.CabalSpecVersion -import Distribution.Compat.NonEmptySet (NonEmptySet) +import Distribution.Compat.NonEmptySet (NonEmptySet) import Distribution.Compiler import Distribution.FieldGrammar.Newtypes import Distribution.ModuleName +import Distribution.SPDX import Distribution.Simple.Compiler +import Distribution.Simple.FileMonitor.Types (FilePathRoot (..), RootedGlob (..)) +import Distribution.Simple.Glob.Internal (Glob (..), GlobPiece (..)) import Distribution.Simple.InstallDirs -import Distribution.Simple.Setup (HaddockTarget (..), TestShowDetails (..), DumpBuildInfo) -import Distribution.SPDX +import Distribution.Simple.Setup (DumpBuildInfo, HaddockTarget (..), TestShowDetails (..)) import Distribution.System import Distribution.Types.Dependency -import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) +import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName import Distribution.Types.LibraryVisibility @@ -43,34 +46,35 @@ import Distribution.Version import Test.QuickCheck.GenericArbitrary -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.NonEmptySet as NES +import Data.ByteString.Char8 qualified as BS8 +import Distribution.Compat.NonEmptySet qualified as NES ------------------------------------------------------------------------------- -- CabalSpecVersion ------------------------------------------------------------------------------- instance Arbitrary CabalSpecVersion where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum instance Arbitrary SpecVersion where - arbitrary = fmap SpecVersion arbitrary + arbitrary = fmap SpecVersion arbitrary ------------------------------------------------------------------------------- -- PackageName and PackageIdentifier ------------------------------------------------------------------------------- instance Arbitrary PackageName where - arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent - where - nameComponent = shortListOf1 5 (elements packageChars) - `suchThat` liftA2 (&&) (not . all isDigit) (/= "all") - packageChars = filter isAlphaNum ['\0'..'\127'] + arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent + where + nameComponent = + shortListOf1 5 (elements packageChars) + `suchThat` liftA2 (&&) (not . all isDigit) (/= "all") + packageChars = filter isAlphaNum ['\0' .. '\127'] instance Arbitrary PackageIdentifier where - arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary + arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary - shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr) + shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr) ------------------------------------------------------------------------------- -- Version @@ -79,44 +83,50 @@ instance Arbitrary PackageIdentifier where -- | Does *NOT* generate 'nullVersion' instance Arbitrary Version where arbitrary = do - branch <- smallListOf1 $ - frequency [(3, return 0) - ,(3, return 1) - ,(2, return 2) - ,(2, return 3) - ,(1, return 0xfffd) - ,(1, return 0xfffe) -- max fitting into packed W64 - ,(1, return 0xffff) - ,(1, return 999999998) - ,(1, return 999999999) - ,(1, return 0x10000)] - return (mkVersion branch) + branch <- + smallListOf1 $ + frequency + [ (3, return 0) + , (3, return 1) + , (2, return 2) + , (2, return 3) + , (1, return 0xfffd) + , (1, return 0xfffe) -- max fitting into packed W64 + , (1, return 0xffff) + , (1, return 999999998) + , (1, return 999999999) + , (1, return 0x10000) + ] + return (mkVersion branch) where smallListOf1 = scale (\n -> min 6 (n `div` 3)) . listOf1 - shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver) - , not (null ns) ] + shrink ver = + [ mkVersion ns | ns <- shrink (versionNumbers ver), not (null ns) + ] instance Arbitrary VersionRange where arbitrary = sized $ \n -> chooseInt (0, n) >>= verRangeExp . intSqrt where verRangeExp n - | n > 0 = oneof - [ recurse unionVersionRanges n - , recurse intersectVersionRanges n - ] - | otherwise = oneof - [ return anyVersion - , fmap thisVersion arbitrary - , fmap laterVersion arbitrary - , fmap orLaterVersion arbitrary - , fmap orLaterVersion' arbitrary - , fmap earlierVersion arbitrary - , fmap orEarlierVersion arbitrary - , fmap orEarlierVersion' arbitrary - , fmap withinVersion arbitraryV - , fmap majorBoundVersion arbitrary - ] + | n > 0 = + oneof + [ recurse unionVersionRanges n + , recurse intersectVersionRanges n + ] + | otherwise = + oneof + [ return anyVersion + , fmap thisVersion arbitrary + , fmap laterVersion arbitrary + , fmap orLaterVersion arbitrary + , fmap orLaterVersion' arbitrary + , fmap earlierVersion arbitrary + , fmap orEarlierVersion arbitrary + , fmap orEarlierVersion' arbitrary + , fmap withinVersion arbitraryV + , fmap majorBoundVersion arbitrary + ] recurse mk n = do k <- chooseInt (0, n - 1) @@ -125,18 +135,18 @@ instance Arbitrary VersionRange where arbitraryV :: Gen Version arbitraryV = arbitrary `suchThat` \v -> all (< 999999999) (versionNumbers v) - orLaterVersion' v = - unionVersionRanges (LaterVersion v) (ThisVersion v) + orLaterVersion' v = + unionVersionRanges (LaterVersion v) (ThisVersion v) orEarlierVersion' v = unionVersionRanges (EarlierVersion v) (ThisVersion v) - shrink (ThisVersion v) = map ThisVersion (shrink v) - shrink (LaterVersion v) = map LaterVersion (shrink v) - shrink (EarlierVersion v) = map EarlierVersion (shrink v) - shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) - shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) - shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) - shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) + shrink (ThisVersion v) = map ThisVersion (shrink v) + shrink (LaterVersion v) = map LaterVersion (shrink v) + shrink (EarlierVersion v) = map EarlierVersion (shrink v) + shrink (OrLaterVersion v) = LaterVersion v : map OrLaterVersion (shrink v) + shrink (OrEarlierVersion v) = EarlierVersion v : map OrEarlierVersion (shrink v) + shrink (MajorBoundVersion v) = map MajorBoundVersion (shrink v) + shrink (UnionVersionRanges a b) = a : b : map (uncurry UnionVersionRanges) (shrink (a, b)) shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b)) instance Arbitrary VersionIntervals where @@ -150,16 +160,16 @@ instance Arbitrary Bound where ------------------------------------------------------------------------------- instance Arbitrary Mixin where - arbitrary = normaliseMixin <$> genericArbitrary - shrink = fmap normaliseMixin . genericShrink + arbitrary = normaliseMixin <$> genericArbitrary + shrink = fmap normaliseMixin . genericShrink instance Arbitrary IncludeRenaming where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary ModuleRenaming where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink ------------------------------------------------------------------------------- -- @@ -168,7 +178,7 @@ instance Arbitrary ModuleRenaming where instance Arbitrary LibraryVisibility where arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] - shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] + shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] shrink LibraryVisibilityPrivate = [] ------------------------------------------------------------------------------- @@ -176,203 +186,217 @@ instance Arbitrary LibraryVisibility where ------------------------------------------------------------------------------- instance Arbitrary ModuleName where - arbitrary = fromString . intercalate "." <$> shortListOf1 4 comp where - comp = (:) <$> elements upper <*> shortListOf1 10 (elements moduleChar) - upper = ['A'..'Z'] - moduleChar = [ c | c <- ['\0' .. '\255'], isAlphaNum c || c `elem` "_'" ] + arbitrary = fromString . intercalate "." <$> shortListOf1 4 comp + where + comp = (:) <$> elements upper <*> shortListOf1 10 (elements moduleChar) + upper = ['A' .. 'Z'] + moduleChar = [c | c <- ['\0' .. '\255'], isAlphaNum c || c `elem` "_'"] ------------------------------------------------------------------------------- -- Dependency ------------------------------------------------------------------------------- instance Arbitrary Dependency where - arbitrary = mkDependency - <$> arbitrary - <*> arbitrary - <*> (arbitrary `suchThat` const True) -- should be (not . null) - - shrink (Dependency pn vr lb) = - [ mkDependency pn' vr' lb' - | (pn', vr', lb') <- shrink (pn, vr, lb) - ] + arbitrary = + mkDependency + <$> arbitrary + <*> arbitrary + <*> (arbitrary `suchThat` const True) -- should be (not . null) + + shrink (Dependency pn vr lb) = + [ mkDependency pn' vr' lb' + | (pn', vr', lb') <- shrink (pn, vr, lb) + ] ------------------------------------------------------------------------------- -- PackageVersionConstraint ------------------------------------------------------------------------------- instance Arbitrary PackageVersionConstraint where - arbitrary = PackageVersionConstraint - <$> arbitrary - <*> arbitrary + arbitrary = + PackageVersionConstraint + <$> arbitrary + <*> arbitrary - shrink (PackageVersionConstraint pn vr) = - [ PackageVersionConstraint pn' vr' - | (pn', vr') <- shrink (pn, vr) - ] + shrink (PackageVersionConstraint pn vr) = + [ PackageVersionConstraint pn' vr' + | (pn', vr') <- shrink (pn, vr) + ] ------------------------------------------------------------------------------- -- System ------------------------------------------------------------------------------- instance Arbitrary OS where - arbitrary = elements knownOSs + arbitrary = elements knownOSs instance Arbitrary Arch where - arbitrary = elements knownArches + arbitrary = elements knownArches instance Arbitrary Platform where - arbitrary = Platform <$> arbitrary <*> arbitrary + arbitrary = Platform <$> arbitrary <*> arbitrary ------------------------------------------------------------------------------- -- Various names ------------------------------------------------------------------------------- instance Arbitrary UnqualComponentName where - -- same rules as package names - arbitrary = packageNameToUnqualComponentName <$> arbitrary + -- same rules as package names + arbitrary = packageNameToUnqualComponentName <$> arbitrary instance Arbitrary LibraryName where - arbitrary = oneof - [ LSubLibName <$> arbitrary - , pure LMainLibName - ] + arbitrary = + oneof + [ LSubLibName <$> arbitrary + , pure LMainLibName + ] - shrink (LSubLibName _) = [LMainLibName] - shrink _ = [] + shrink (LSubLibName _) = [LMainLibName] + shrink _ = [] ------------------------------------------------------------------------------- -- GPD flags ------------------------------------------------------------------------------- instance Arbitrary FlagName where - arbitrary = mkFlagName <$> frequency + arbitrary = + mkFlagName + <$> frequency [ (20, flagident) - -- special nasty cases - , (1, pure "none") - , (1, pure "any") + , -- special nasty cases + (1, pure "none") + , (1, pure "any") ] - where - flagident = lowercase <$> shortListOf1 5 (elements flagChars) - `suchThat` (("-" /=) . take 1) - flagChars = "-_" ++ ['a'..'z'] + where + flagident = + lowercase + <$> shortListOf1 5 (elements flagChars) + `suchThat` (("-" /=) . take 1) + flagChars = "-_" ++ ['a' .. 'z'] instance Arbitrary FlagAssignment where - arbitrary = mkFlagAssignment <$> arbitrary - shrink x = mkFlagAssignment <$> shrink (unFlagAssignment x) + arbitrary = mkFlagAssignment <$> arbitrary + shrink x = mkFlagAssignment <$> shrink (unFlagAssignment x) ------------------------------------------------------------------------------- -- Verbosity ------------------------------------------------------------------------------- instance Arbitrary VerbosityFlags where - arbitrary = do - v <- mkVerbosityFlags <$> elements [minBound..maxBound] - -- verbose markoutput is left out on purpose - flags <- listOf $ elements - [ verboseCallSite - , verboseCallStack - , verboseNoWrap - , verboseTimestamp - , verboseStderr - ] - return (foldr ($) v flags) + arbitrary = do + v <- mkVerbosityFlags <$> elements [minBound .. maxBound] + -- verbose markoutput is left out on purpose + flags <- + listOf $ + elements + [ verboseCallSite + , verboseCallStack + , verboseNoWrap + , verboseTimestamp + , verboseStderr + ] + return (foldr ($) v flags) ------------------------------------------------------------------------------- -- SourceRepo ------------------------------------------------------------------------------- instance Arbitrary RepoType where - arbitrary = elements (KnownRepoType <$> knownRepoTypes) + arbitrary = elements (KnownRepoType <$> knownRepoTypes) instance Arbitrary RepoKind where - arbitrary = elements [RepoHead, RepoThis] + arbitrary = elements [RepoHead, RepoThis] ------------------------------------------------------------------------------- -- SPDX ------------------------------------------------------------------------------- instance Arbitrary LicenseId where - arbitrary = elements $ licenseIdList currentLicenseListVersion + arbitrary = elements $ licenseIdList currentLicenseListVersion instance Arbitrary LicenseExceptionId where - arbitrary = elements $ licenseExceptionIdList currentLicenseListVersion + arbitrary = elements $ licenseExceptionIdList currentLicenseListVersion currentLicenseListVersion :: LicenseListVersion currentLicenseListVersion = cabalSpecVersionToSPDXListVersion cabalSpecLatest instance Arbitrary LicenseRef where - arbitrary = mkLicenseRef' <$> ids' <*> ids - where - ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-" - ids' = oneof [ pure Nothing, Just <$> ids ] + arbitrary = mkLicenseRef' <$> ids' <*> ids + where + ids = listOf1 $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "_-" + ids' = oneof [pure Nothing, Just <$> ids] instance Arbitrary SimpleLicenseExpression where - arbitrary = oneof - [ ELicenseId <$> arbitrary - , ELicenseIdPlus <$> arbitrary - , ELicenseRef <$> arbitrary - ] + arbitrary = + oneof + [ ELicenseId <$> arbitrary + , ELicenseIdPlus <$> arbitrary + , ELicenseRef <$> arbitrary + ] instance Arbitrary LicenseExpression where - arbitrary = sized arb - where - arb n - | n <= 0 = ELicense <$> arbitrary <*> pure Nothing - | otherwise = oneof - [ ELicense <$> arbitrary <*> arbitrary - , EAnd <$> arbA <*> arbB - , EOr <$> arbA <*> arbB - ] - where - m = n `div` 2 - arbA = arb m - arbB = arb (n - m) - - shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) - shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) - shrink _ = [] + arbitrary = sized arb + where + arb n + | n <= 0 = ELicense <$> arbitrary <*> pure Nothing + | otherwise = + oneof + [ ELicense <$> arbitrary <*> arbitrary + , EAnd <$> arbA <*> arbB + , EOr <$> arbA <*> arbB + ] + where + m = n `div` 2 + arbA = arb m + arbB = arb (n - m) + + shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b)) + shrink (EOr a b) = a : b : map (uncurry EOr) (shrink (a, b)) + shrink _ = [] ------------------------------------------------------------------------------- -- Compiler ------------------------------------------------------------------------------- instance Arbitrary CompilerFlavor where - arbitrary = elements knownCompilerFlavors + arbitrary = elements knownCompilerFlavors instance Arbitrary CompilerId where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = genericArbitrary + shrink = genericShrink instance Arbitrary ProfDetailLevel where - arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] + arbitrary = elements [d | (_, _, d) <- knownProfDetailLevels] instance Arbitrary OptimisationLevel where - arbitrary = elements [minBound..maxBound] + arbitrary = elements [minBound .. maxBound] instance Arbitrary DebugInfoLevel where - arbitrary = elements [minBound..maxBound] + arbitrary = elements [minBound .. maxBound] ------------------------------------------------------------------------------- -- NonEmptySet ------------------------------------------------------------------------------- instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where - arbitrary = mk <$> arbitrary <*> arbitrary where - mk x xs = NES.fromNonEmpty (x :| xs) + arbitrary = mk <$> arbitrary <*> arbitrary + where + mk x xs = NES.fromNonEmpty (x :| xs) - shrink nes = case NES.toNonEmpty nes of - x :| xs -> map mk (shrink (x, xs)) - where - mk (x,xs) = NES.fromNonEmpty (x :| xs) + shrink nes = case NES.toNonEmpty nes of + x :| xs -> map mk (shrink (x, xs)) + where + mk (x, xs) = NES.fromNonEmpty (x :| xs) ------------------------------------------------------------------------------- -- NubList ------------------------------------------------------------------------------- instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where - arbitrary = toNubList <$> arbitrary - shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] - -- try empty, otherwise don't shrink as it can loop + arbitrary = toNubList <$> arbitrary + shrink xs = [toNubList [] | (not . null) (fromNubList xs)] + +-- try empty, otherwise don't shrink as it can loop ------------------------------------------------------------------------------- -- InstallDirs @@ -383,64 +407,83 @@ instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where -- invalid characters or path components instance Arbitrary a => Arbitrary (InstallDirs a) where - arbitrary = InstallDirs - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 - <*> arbitrary -- 17 + arbitrary = + InstallDirs + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 4 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 8 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 12 + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary -- 16 + <*> arbitrary -- 17 instance Arbitrary PathTemplate where - arbitrary = toPathTemplate <$> arbitraryShortToken - shrink t = [ toPathTemplate s - | s <- shrink (fromPathTemplate t) - , not (null s) ] + arbitrary = toPathTemplate <$> arbitraryShortToken + shrink t = + [ toPathTemplate s + | s <- shrink (fromPathTemplate t) + , not (null s) + ] ------------------------------------------------------------------------------- -- Pkgconfig ------------------------------------------------------------------------------- instance Arbitrary PkgconfigVersion where - arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems where - elems = frequency - [ (2, pure ".") - , (1, pure "-") - , (5, listOf1 $ elements ['0' .. '9']) - , (1, listOf1 $ elements ['A' .. 'Z']) - , (1, listOf1 $ elements ['a' .. 'z']) - ] - - -- disallow versions starting with dash - dropDash = notEmpty . dropWhile (== '-') - notEmpty x - | null x = "0" - | otherwise = x + arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems + where + elems = + frequency + [ (2, pure ".") + , (1, pure "-") + , (5, listOf1 $ elements ['0' .. '9']) + , (1, listOf1 $ elements ['A' .. 'Z']) + , (1, listOf1 $ elements ['a' .. 'z']) + ] + + -- disallow versions starting with dash + dropDash = notEmpty . dropWhile (== '-') + notEmpty x + | null x = "0" + | otherwise = x instance Arbitrary PkgconfigVersionRange where arbitrary = sized $ \n -> chooseInt (0, n) >>= verRangeExp . intSqrt where verRangeExp n - | n > 0 = oneof - [ recurse PcUnionVersionRanges n - , recurse PcIntersectVersionRanges n - ] - | otherwise = oneof - [ return PcAnyVersion - , fmap PcThisVersion arbitrary - , fmap PcLaterVersion arbitrary - , fmap PcOrLaterVersion arbitrary - , fmap orLaterVersion' arbitrary - , fmap PcEarlierVersion arbitrary - , fmap PcOrEarlierVersion arbitrary - , fmap orEarlierVersion' arbitrary - ] + | n > 0 = + oneof + [ recurse PcUnionVersionRanges n + , recurse PcIntersectVersionRanges n + ] + | otherwise = + oneof + [ return PcAnyVersion + , fmap PcThisVersion arbitrary + , fmap PcLaterVersion arbitrary + , fmap PcOrLaterVersion arbitrary + , fmap orLaterVersion' arbitrary + , fmap PcEarlierVersion arbitrary + , fmap PcOrEarlierVersion arbitrary + , fmap orEarlierVersion' arbitrary + ] recurse mk n = do k <- chooseInt (0, n - 1) liftA2 mk (verRangeExp k) (verRangeExp (n - k - 1)) - orLaterVersion' v = - PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) + orLaterVersion' v = + PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) orEarlierVersion' v = PcUnionVersionRanges (PcEarlierVersion v) (PcThisVersion v) @@ -449,27 +492,140 @@ instance Arbitrary PkgconfigVersionRange where ------------------------------------------------------------------------------- instance Arbitrary HaddockTarget where - arbitrary = elements [ForHackage, ForDevelopment] + arbitrary = elements [ForHackage, ForDevelopment] instance Arbitrary TestShowDetails where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum ------------------------------------------------------------------------------- -- PackageDB ------------------------------------------------------------------------------- instance Arbitrary (PackageDBX FilePath) where - arbitrary = oneof [ pure GlobalPackageDB - , pure UserPackageDB - , SpecificPackageDB <$> arbitraryShortPath - ] + arbitrary = + oneof + [ pure GlobalPackageDB + , pure UserPackageDB + , SpecificPackageDB <$> arbitraryShortPath + ] ------------------------------------------------------------------------------- -- DumpBuildInfo ------------------------------------------------------------------------------- instance Arbitrary DumpBuildInfo where - arbitrary = arbitraryBoundedEnum + arbitrary = arbitraryBoundedEnum + +------------------------------------------------------------------------------- +-- Glob +------------------------------------------------------------------------------- + +instance Arbitrary RootedGlob where + arbitrary = + (RootedGlob <$> arbitrary <*> arbitrary) + `suchThat` validFilePathGlob + + shrink (RootedGlob root pathglob) = + [ RootedGlob root' pathglob' + | (root', pathglob') <- shrink (root, pathglob) + , validFilePathGlob (RootedGlob root' pathglob') + ] + +validFilePathGlob :: RootedGlob -> Bool +validFilePathGlob (RootedGlob FilePathRelative pathglob) = + case pathglob of + GlobDirTrailing -> False + GlobDir [Literal "~"] _ -> False + GlobDir [Literal (d : ":")] _ + | isLetter d -> False + _ -> True +validFilePathGlob _ = True + +instance Arbitrary FilePathRoot where + arbitrary = + frequency + [ (3, pure FilePathRelative) + , (1, pure (FilePathRoot unixroot)) + , (1, FilePathRoot <$> windrive) + , (1, pure FilePathHomeDir) + ] + where + unixroot = "/" + windrive = do d <- choose ('A', 'Z'); return (d : ":\\") + + shrink FilePathRelative = [] + shrink (FilePathRoot _) = [FilePathRelative] + shrink FilePathHomeDir = [FilePathRelative] + +instance Arbitrary Glob where + arbitrary = sized $ \sz -> + oneof $ + take + (max 1 sz) + [ pure GlobDirTrailing + , GlobFile . getGlobPieces <$> arbitrary + , (GlobDir . getGlobPieces <$> arbitrary) + <*> resize (sz `div` 2) arbitrary + ] + + shrink GlobDirTrailing = [] + shrink (GlobFile glob) = + GlobDirTrailing + : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)] + shrink (GlobDir glob pathglob) = + pathglob + : GlobFile glob + : [ GlobDir (getGlobPieces glob') pathglob' + | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) + ] + shrink (GlobDirRecursive glob) = + GlobDirTrailing + : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)] + +newtype GlobPieces = GlobPieces {getGlobPieces :: [GlobPiece]} + deriving (Eq) + +instance Arbitrary GlobPieces where + arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary + + shrink (GlobPieces glob) = + [ GlobPieces (mergeLiterals (getNonEmpty glob')) + | glob' <- shrink (NonEmpty glob) + ] + +mergeLiterals :: [GlobPiece] -> [GlobPiece] +mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps) +mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps +-- Two consecutive wildcards are semantically equivalent to a single one, but +-- would syntactically produce a recursive wildcard when pretty-printed, so +-- whenever we end up generating two or more consecutive wildcards, we merge +-- them together to avoid this problem. +mergeLiterals (WildCard : WildCard : ps) = mergeLiterals (WildCard : ps) +mergeLiterals (p : ps) = p : mergeLiterals ps +mergeLiterals [] = [] + +instance Arbitrary GlobPiece where + arbitrary = sized $ \sz -> + frequency + [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars)) + , (1, pure WildCard) + , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary))) + ] + + shrink (Literal str) = + [ Literal str' + | str' <- shrink str + , not (null str') + , all (`elem` globLiteralChars) str' + ] + shrink WildCard = [] + shrink (Union as) = + [ Union (map getGlobPieces (getNonEmpty as')) + | as' <- shrink (NonEmpty (map GlobPieces as)) + ] + +globLiteralChars :: [Char] +globLiteralChars = ['\0' .. '\128'] \\ "*{},/\\" ------------------------------------------------------------------------------- -- Helpers @@ -477,36 +633,36 @@ instance Arbitrary DumpBuildInfo where shortListOf1 :: Int -> Gen a -> Gen [a] shortListOf1 bound gen = sized $ \n -> do - k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) - vectorOf k gen + k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) + vectorOf k gen arbitraryShortToken :: Gen String arbitraryShortToken = arbitraryShortStringWithout "{}[]" arbitraryShortPath :: Gen String arbitraryShortPath = arbitraryShortStringWithout "{}[],<>:|*?" `suchThat` (not . winDevice) - where - -- split path components on dots - -- no component can be empty or a device name - -- this blocks a little too much (both "foo..bar" and "foo.con" are legal) - -- but for QC being a little conservative isn't harmful - winDevice = any (any (`elem` ["","con", "aux", "prn", "com", "lpt", "nul"]) . splitBy ".") . splitBy "\\/" . map toLower - splitBy _ "" = [] - splitBy seps str = let (part,rest) = break (`elem` seps) str - in part : if length rest == 1 then [""] else splitBy seps (drop 1 rest) + where + -- split path components on dots + -- no component can be empty or a device name + -- this blocks a little too much (both "foo..bar" and "foo.con" are legal) + -- but for QC being a little conservative isn't harmful + winDevice = any (any (`elem` ["", "con", "aux", "prn", "com", "lpt", "nul"]) . splitBy ".") . splitBy "\\/" . map toLower + splitBy _ "" = [] + splitBy seps str = + let (part, rest) = break (`elem` seps) str + in part : if length rest == 1 then [""] else splitBy seps (drop 1 rest) arbitraryShortStringWithout :: String -> Gen String arbitraryShortStringWithout excludeChars = - shortListOf1 5 $ elements $ ['#' .. '~'] \\ excludeChars + shortListOf1 5 $ elements $ ['#' .. '~'] \\ excludeChars --- | intSqrt :: Int -> Int intSqrt 0 = 0 intSqrt 1 = 1 intSqrt n = case compare n 0 of - LT -> 0 -- whatever - EQ -> 0 - GT -> iter (iter guess) -- two iterations give good results + LT -> 0 -- whatever + EQ -> 0 + GT -> iter (iter guess) -- two iterations give good results where iter :: Int -> Int iter 0 = 0 diff --git a/Cabal-syntax/src/Distribution/Utils/Structured.hs b/Cabal-syntax/src/Distribution/Utils/Structured.hs index ad70892e498..236a2718045 100644 --- a/Cabal-syntax/src/Distribution/Utils/Structured.hs +++ b/Cabal-syntax/src/Distribution/Utils/Structured.hs @@ -77,6 +77,7 @@ import qualified Control.Monad.Trans.State.Strict as State import Control.Exception (ErrorCall (..), catch, evaluate) +import GHC.Fingerprint import GHC.Generics import qualified Data.ByteString as BS @@ -391,6 +392,8 @@ instance Structured Integer where structure = nominalStructure instance Structured Data.Word.Word where structure = nominalStructure +instance Structured Fingerprint + instance Structured Int8 where structure = nominalStructure instance Structured Int16 where structure = nominalStructure instance Structured Int32 where structure = nominalStructure diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal index 6044ba1d780..250f519f2fb 100644 --- a/Cabal-tests/Cabal-tests.cabal +++ b/Cabal-tests/Cabal-tests.cabal @@ -202,6 +202,30 @@ test-suite no-thunks-test build-depends: , nothunks >=0.1.1.0 && <0.3 +-- Slow, long-running tests +test-suite long-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + other-modules: + Test.Laws + UnitTests.Options + UnitTests.Distribution.Simple.FileMonitor + + main-is: LongTests.hs + build-depends: + , base >=4.17 && <5 + , Cabal + , Cabal-syntax + , containers + , directory >=1.2.7 + , filepath + , tasty >=1.2.3 && <1.6 + , tasty-expected-failure + , tasty-hunit + + ghc-options: -Wall + default-language: Haskell2010 + executable ghc-supported-extensions hs-source-dirs: exes main-is: GhcSupportedExtensions.hs diff --git a/Cabal-tests/tests/LongTests.hs b/Cabal-tests/tests/LongTests.hs new file mode 100644 index 00000000000..6328ed8ae89 --- /dev/null +++ b/Cabal-tests/tests/LongTests.hs @@ -0,0 +1,21 @@ +module Main (main) where + +import Test.Tasty + +import qualified UnitTests.Distribution.Simple.FileMonitor +import UnitTests.Options + +main :: IO () +main = + defaultMainWithIngredients + (includingOptions extraOptions : defaultIngredients) + tests + +tests :: TestTree +tests = + askOption $ \(OptionMtimeChangeDelay mtimeChange) -> + testGroup + "Long-running tests" + [ testGroup "UnitTests.Distribution.Simple.FileMonitor" $ + UnitTests.Distribution.Simple.FileMonitor.tests mtimeChange + ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/FileMonitor.hs similarity index 98% rename from cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs rename to Cabal-tests/tests/UnitTests/Distribution/Simple/FileMonitor.hs index f8f9b9c6d90..f60fcf7e4f4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/FileMonitor.hs @@ -1,4 +1,4 @@ -module UnitTests.Distribution.Client.FileMonitor (tests) where +module UnitTests.Distribution.Simple.FileMonitor (tests) where import Distribution.Parsec (simpleParsec) @@ -16,8 +16,8 @@ import Distribution.Compat.Binary import Distribution.Simple.Utils (removeFileForcibly, withTempDirectory) import Distribution.System (OS (Windows), buildOS) -import Distribution.Client.FileMonitor import Distribution.Compat.Time +import Distribution.Simple.FileMonitor import Distribution.Utils.Structured (Structured, structureHash) import GHC.Fingerprint (Fingerprint (..)) @@ -29,7 +29,7 @@ tests :: Int -> [TestTree] tests mtimeChange = [ testGroup "Structured hashes" - [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe1339b9dcfdfe19d 0x9135a5f30da7ca82 + [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint fingerprintStateFile1 fingerprintStateFile2 , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint fingerprintStateGlob1 fingerprintStateGlob2 , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint fingerprintStateFileSet1 fingerprintStateFileSet2 ] @@ -94,11 +94,13 @@ tests mtimeChange = knownBrokenInWindows msg = case buildOS of Windows -> expectFailBecause msg _ -> id - fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64 - fingerprintStateGlob1 = 0x5d9efec2b93d22a1 - fingerprintStateGlob2 = 0xfdbc86351866a191 - fingerprintStateFileSet1 = 0x4cee0a3a23697bb1 - fingerprintStateFileSet2 = 0x96039d15c3241985 + fingerprintStateFile1, fingerprintStateFile2, fingerprintStateGlob1, fingerprintStateGlob2, fingerprintStateFileSet1, fingerprintStateFileSet2 :: Word64 + fingerprintStateFile1 = 0x982ee8fef06a3b5f + fingerprintStateFile2 = 0xe3c608811ccf1011 + fingerprintStateGlob1 = 0xd17eeece5373667b + fingerprintStateGlob2 = 0x0b8d8ed7d6a103e8 + fingerprintStateFileSet1 = 0xb1555b75c3f96850 + fingerprintStateFileSet2 = 0x4a51468742b6452b -- Check the file system behaves the way we expect it to diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs index e853040c1d6..b7bcdd65336 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Simple/Glob.hs @@ -1,22 +1,29 @@ {-# LANGUAGE LambdaCase #-} + module UnitTests.Distribution.Simple.Glob - ( tests - ) where - -import Control.Monad -import Data.Foldable (for_) -import Data.Function (on) -import Data.List (sort) -import Data.Maybe (mapMaybe) -import Distribution.Simple.Glob -import qualified Distribution.Verbosity as Verbosity + ( tests + ) where + +import Distribution.Compat.Prelude hiding (last) +import Prelude () + import Distribution.CabalSpecVersion +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.FileMonitor.Types +import Distribution.Simple.Glob +import Distribution.Simple.Glob.Internal +import Distribution.Utils.Structured (structureHash) +import Distribution.Verbosity +import Distribution.Verbosity qualified as Verbosity +import GHC.Fingerprint import System.Directory (createDirectoryIfMissing) -import System.FilePath ((), splitFileName, normalise) +import System.FilePath (normalise, splitFileName, ()) import System.IO.Temp (withSystemTempDirectory) +import Test.QuickCheck.Instances.Cabal () import Test.Tasty import Test.Tasty.HUnit -import Distribution.Verbosity +import Test.Tasty.QuickCheck sampleFileNames :: [FilePath] sampleFileNames = @@ -51,6 +58,134 @@ makeSampleFiles dir = for_ sampleFileNames $ \filename -> do createDirectoryIfMissing True (dir dir') writeFile (dir dir' name) $ "This is " ++ filename +prop_roundtrip_printparse :: RootedGlob -> Property +prop_roundtrip_printparse pathglob = + counterexample (prettyShow pathglob) $ + eitherParsec (prettyShow pathglob) === Right pathglob + +-- first run, where we don't even call updateMonitor +testParseCases :: Assertion +testParseCases = do + RootedGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/" + RootedGlob FilePathHomeDir GlobDirTrailing <- testparse "~/" + + RootedGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/" + RootedGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/" + RootedGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\" + RootedGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:" + + RootedGlob + FilePathRelative + (GlobDirRecursive [WildCard]) <- + testparse "**/*" + RootedGlob + FilePathRelative + (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard])) <- + testparse "foo/**/*" + RootedGlob + FilePathRelative + (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard, Literal ".txt"])) <- + testparse "foo/**/*.txt" + + RootedGlob + FilePathRelative + (GlobFile [Literal "."]) <- + testparse "." + + RootedGlob + FilePathRelative + (GlobFile [Literal "~"]) <- + testparse "~" + + RootedGlob + FilePathRelative + (GlobDir [Literal "."] GlobDirTrailing) <- + testparse "./" + + RootedGlob + FilePathRelative + (GlobFile [Literal "foo"]) <- + testparse "foo" + + RootedGlob + FilePathRelative + ( GlobDir + [Literal "foo"] + (GlobFile [Literal "bar"]) + ) <- + testparse "foo/bar" + + RootedGlob + FilePathRelative + ( GlobDir + [Literal "foo"] + (GlobDir [Literal "bar"] GlobDirTrailing) + ) <- + testparse "foo/bar/" + + RootedGlob + (FilePathRoot "/") + ( GlobDir + [Literal "foo"] + (GlobDir [Literal "bar"] GlobDirTrailing) + ) <- + testparse "/foo/bar/" + + RootedGlob + (FilePathRoot "C:\\") + ( GlobDir + [Literal "foo"] + (GlobDir [Literal "bar"] GlobDirTrailing) + ) <- + testparse "C:\\foo\\bar\\" + + RootedGlob + FilePathRelative + (GlobFile [WildCard]) <- + testparse "*" + + RootedGlob + FilePathRelative + (GlobFile [WildCard, WildCard]) <- + testparse "**" -- not helpful, but valid (?) + RootedGlob + FilePathRelative + (GlobFile [WildCard, Literal "foo", WildCard]) <- + testparse "*foo*" + + RootedGlob + FilePathRelative + (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- + testparse "foo*bar" + + RootedGlob + FilePathRelative + (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- + testparse "{*,foo}" + + parseFail "{" + parseFail "}" + parseFail "," + parseFail "{" + parseFail "{{}" + parseFail "{}" + parseFail "{,}" + parseFail "{foo,}" + parseFail "{,foo}" + + return () + +testparse :: String -> IO RootedGlob +testparse s = + case eitherParsec s of + Right p -> return p + Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err) + +parseFail :: String -> Assertion +parseFail s = + case eitherParsec s :: Either String RootedGlob of + Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p) + Left _ -> return () compatibilityTests :: CabalSpecVersion -> [TestTree] compatibilityTests version = [ testCase "literal match" $ @@ -109,19 +244,23 @@ testMatchesVersion version pat expected = do -- check can't identify that kind of match. expected' = filter (\case GlobMatchesDirectory _ -> False; _ -> True) expected unless (sort expected' == sort actual) $ - assertFailure $ "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected + assertFailure $ + "Unexpected result (pure matcher): " ++ show actual ++ "\nExpected: " ++ show expected checkIO globPat = withSystemTempDirectory "globstar-sample" $ \tmpdir -> do makeSampleFiles tmpdir actual <- runDirFileGlob verbosity (Just version) tmpdir globPat unless (isEqual actual expected) $ - assertFailure $ "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected + assertFailure $ + "Unexpected result (impure matcher): " ++ show actual ++ "\nExpected: " ++ show expected testFailParseVersion :: CabalSpecVersion -> FilePath -> GlobSyntaxError -> Assertion testFailParseVersion version pat expected = case parseFileGlob version pat of - Left err -> unless (expected == err) $ - assertFailure $ "Unexpected error: " ++ show err + Left err -> + unless (expected == err) $ + assertFailure $ + "Unexpected error: " ++ show err Right _ -> assertFailure "Unexpected success in parsing." globstarTests :: [TestTree] @@ -157,9 +296,25 @@ multiDotTests = where testMatches = testMatchesVersion CabalSpecV2_4 +printParseTests :: [TestTree] +printParseTests = + [ testProperty "print/parse roundtrip" prop_roundtrip_printparse + , testCase "parse examples" testParseCases + , testGroup + "Structured hashes" + [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782 + , testCase "Glob" $ structureHash (Proxy :: Proxy Glob) @?= Fingerprint 0x3a5af41e8194eaa3 0xd8e461fdfdb0e07b + , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5 + , testCase "RootedGlob" $ structureHash (Proxy :: Proxy RootedGlob) @?= Fingerprint 0x0031d198379cd1bf 0x7246ab9b6c6e0e7d + ] + ] + tests :: [TestTree] tests = - [ testGroup "pre-2.4 compatibility" $ + [ testGroup + "print/parse" + printParseTests + , testGroup "pre-2.4 compatibility" $ compatibilityTests CabalSpecV2_2 , testGroup "post-2.4 compatibility" $ compatibilityTests CabalSpecV2_4 @@ -168,3 +323,5 @@ tests = testFailParseVersion CabalSpecV1_4 "foo/*.bar" VersionDoesNotSupportGlob , testGroup "multi-dot globbing" multiDotTests ] + +-- TODO: tests for windows style file paths diff --git a/Cabal-tests/tests/UnitTests/Options.hs b/Cabal-tests/tests/UnitTests/Options.hs new file mode 100644 index 00000000000..d1b2ac32aa4 --- /dev/null +++ b/Cabal-tests/tests/UnitTests/Options.hs @@ -0,0 +1,30 @@ +module UnitTests.Options + ( OptionMtimeChangeDelay (..) + , extraOptions + ) +where + +import Data.Proxy + +import Test.Tasty.Options + +{------------------------------------------------------------------------------- + Test options +-------------------------------------------------------------------------------} + +extraOptions :: [OptionDescription] +extraOptions = + [ Option (Proxy :: Proxy OptionMtimeChangeDelay) + ] + +newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int + +instance IsOption OptionMtimeChangeDelay where + defaultValue = OptionMtimeChangeDelay 10000 + showDefaultValue (OptionMtimeChangeDelay v) = Just (show v) + parseValue = fmap OptionMtimeChangeDelay . safeRead + optionName = return "mtime-change-delay" + optionHelp = + return $ + "How long to wait before attempting to detect" + ++ "file modification, in microseconds" diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 1383588445d..2dd4f917c99 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -44,6 +44,7 @@ library , Cabal-syntax ^>= 3.19 , array >= 0.4.0.1 && < 0.6 , base >= 4.17 && < 5 + , binary >= 0.7.3 && < 0.9 , bytestring >= 0.10.8 && < 0.13 , containers >= 0.5.8.2 && < 0.9 , deepseq >= 1.4 && < 1.7 @@ -122,6 +123,7 @@ library Distribution.Simple.Compiler Distribution.Simple.Configure Distribution.Simple.Errors + Distribution.Simple.FileMonitor Distribution.Simple.FileMonitor.Types Distribution.Simple.Flag Distribution.Simple.GHC @@ -154,6 +156,7 @@ library Distribution.Simple.Program.Script Distribution.Simple.Program.Strip Distribution.Simple.Program.Types + Distribution.Simple.RebuildMonad Distribution.Simple.Register Distribution.Simple.Setup Distribution.Simple.ShowBuildInfo diff --git a/Cabal/src/Distribution/Simple/FileMonitor.hs b/Cabal/src/Distribution/Simple/FileMonitor.hs new file mode 100644 index 00000000000..0c341ffe0c5 --- /dev/null +++ b/Cabal/src/Distribution/Simple/FileMonitor.hs @@ -0,0 +1,1345 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | An abstraction to help with re-running actions when files or other +-- input values they depend on have changed. +module Distribution.Simple.FileMonitor + ( -- * Declaring files to monitor + module Distribution.Simple.FileMonitor.Types + + -- * Creating and checking sets of monitored files + , FileMonitor (..) + , newFileMonitor + , MonitorChanged (..) + , MonitorChangedReason (..) + , checkFileMonitorChanged + , updateFileMonitor + , MonitorTimestamp + , beginUpdateFileMonitor + + -- * Internal + , MonitorStateFileSet + , MonitorStateFile + , MonitorStateGlob + ) where + +import Distribution.Compat.Prelude + +import qualified Data.Binary as Binary +import Data.Binary.Get (runGetOrFail) +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map.Strict as Map + +import Control.Exception +import Control.Monad.Except + ( ExceptT + , runExceptT + , throwError + , withExceptT + ) +import Control.Monad.State (StateT, mapStateT) +import qualified Control.Monad.State as State +import Control.Monad.Trans (MonadIO, liftIO) +import GHC.Fingerprint (Fingerprint) +import qualified GHC.Fingerprint as Fingerprint + +import Distribution.Compat.Time +import Distribution.Simple.FileMonitor.Types +import Distribution.Simple.Glob +import Distribution.Simple.Glob.Internal (Glob (..), GlobPieces) +import Distribution.Simple.Utils + ( MergeResult (..) + , handleDoesNotExist + , mergeBy + , writeFileAtomic + ) +import Distribution.Utils.Structured (Tag (..), structuredEncode) + +import System.Directory +import System.FilePath +import System.IO + +------------------------------------------------------------------------------ +-- Implementation types, files status +-- + +-- | The state necessary to determine whether a set of monitored +-- files has changed. It consists of two parts: a set of specific +-- files to be monitored (index by their path), and a list of +-- globs, which monitor may files at once. +data MonitorStateFileSet + = MonitorStateFileSet + ![MonitorStateFile] + ![MonitorStateGlob] + -- Morally this is not actually a set but a bag (represented by lists). + -- There is no principled reason to use a bag here rather than a set, but + -- there is also no particular gain either. That said, we do preserve the + -- order of the lists just to reduce confusion (and have predictable I/O + -- patterns). + deriving (Show, Generic) + +instance Binary MonitorStateFileSet +instance Structured MonitorStateFileSet + +-- | The state necessary to determine whether a monitored file has changed. +-- +-- This covers all the cases of 'MonitorFilePath' except for globs which is +-- covered separately by 'MonitorStateGlob'. +data MonitorStateFile + = MonitorStateFile + !MonitorKindFile + !MonitorKindDir + !FilePath + !MonitorStateFileStatus + deriving (Show, Generic) + +data MonitorStateFileStatus + = MonitorStateFileExists + | -- | cached file mtime + MonitorStateFileModTime !ModTime + | -- | cached mtime and content hash + MonitorStateFileHashed !ModTime !Fingerprint + | MonitorStateDirExists + | -- | cached dir mtime + MonitorStateDirModTime !ModTime + | MonitorStateNonExistent + | MonitorStateAlreadyChanged + deriving (Show, Generic) + +instance Binary MonitorStateFile +instance Binary MonitorStateFileStatus +instance Structured MonitorStateFile +instance Structured MonitorStateFileStatus + +-- | The state necessary to determine whether the files matched by a globbing +-- match have changed. +data MonitorStateGlob + = MonitorStateGlob + !MonitorKindFile + !MonitorKindDir + !FilePathRoot + !MonitorStateGlobRel + deriving (Show, Generic) + +-- | Monitoring state for a 'Glob'. Constructors mirror those of Glob +data MonitorStateGlobRel + = -- | Monitoring state for 'GlobDir' + MonitorStateGlobDirs + !GlobPieces + -- ^ Glob matching on subdirectory in current directory + !Glob + -- ^ Glob tail matching on anything below subdirectory + !ModTime + -- ^ Cached directory modification time + ![(FilePath, MonitorStateGlobRel)] + -- ^ Per-file monitoring state. + -- Invariant: sorted + | -- | Monitoring state for 'GlobFile' + MonitorStateGlobFiles + !GlobPieces + -- ^ Glob matching on file in current directory + !ModTime + -- ^ Cached directory modification time + ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted + + -- ^ Per-file monitoring state. + -- Invariant: sorted + | -- | Monitoring state for 'GlobDirRecursive' + MonitorStateGlobRecursive + !GlobPieces + -- ^ Glob matching on file in current directory subtree (current + -- directory and all of its descendants). + !ModTime + -- ^ Cached directory modification time + ![(FilePath, MonitorStateFileStatus)] + -- ^ Per-file monitoring state for files immediately below the current + -- directory. + -- Invariant: sorted + ![(FilePath, MonitorStateGlobRel)] + -- ^ Monitoring state for immediate subdirectories. Transient + -- subdirectories are represented recursively within these. + -- Invariant: sorted + | -- | Monitoring state for 'GlobDirTrailing' + -- (Trivial, because there is no data in 'GlobDirTrailing') + MonitorStateGlobDirTrailing + deriving (Show, Generic) + +instance Binary MonitorStateGlob +instance Binary MonitorStateGlobRel + +instance Structured MonitorStateGlob +instance Structured MonitorStateGlobRel + +-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by +-- inspecting the state of the file system, and we can go in the reverse +-- direction by just forgetting the extra info. +reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] +reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = + map getSinglePath singlePaths ++ map getGlobPath globPaths + where + getSinglePath :: MonitorStateFile -> MonitorFilePath + getSinglePath (MonitorStateFile kindfile kinddir filepath _) = + MonitorFile kindfile kinddir filepath + + getGlobPath :: MonitorStateGlob -> MonitorFilePath + getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = + MonitorFileGlob kindfile kinddir $ + RootedGlob root $ + monitorStateGlobRelGlob gstate + +-- | Reconstruct a 'Glob' from a 'MonitorStateGlobRel'. This simply erases the +-- additional information in 'MonitorStateGlobRel' added via +-- 'buildMonitorStateGlobRel'. +monitorStateGlobRelGlob :: MonitorStateGlobRel -> Glob +monitorStateGlobRelGlob gstate = + case gstate of + MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs + MonitorStateGlobFiles glob _ _ -> GlobFile glob + MonitorStateGlobRecursive glob _ _ _ -> GlobDirRecursive glob + MonitorStateGlobDirTrailing -> GlobDirTrailing + +------------------------------------------------------------------------------ +-- Checking the status of monitored files +-- + +-- | A monitor for detecting changes to a set of files. It can be used to +-- efficiently test if any of a set of files (specified individually or by +-- glob patterns) has changed since some snapshot. In addition, it also checks +-- for changes in a value (of type @a@), and when there are no changes in +-- either it returns a saved value (of type @b@). +-- +-- The main use case looks like this: suppose we have some expensive action +-- that depends on certain pure inputs and reads some set of files, and +-- produces some pure result. We want to avoid re-running this action when it +-- would produce the same result. So we need to monitor the files the action +-- looked at, the other pure input values, and we need to cache the result. +-- Then at some later point, if the input value didn't change, and none of the +-- files changed, then we can re-use the cached result rather than re-running +-- the action. +-- +-- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance +-- saves state in a disk file, so the file for that has to be specified, +-- making sure it is unique. The pattern is to use 'checkFileMonitorChanged' +-- to see if there's been any change. If there is, re-run the action, keeping +-- track of the files, then use 'updateFileMonitor' to record the current +-- set of files to monitor, the current input value for the action, and the +-- result of the action. +-- +-- The typical occurrence of this pattern is captured by 'rerunIfChanged' +-- and the 'Rebuild' monad. More complicated cases may need to use +-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. +data FileMonitor a b = FileMonitor + { fileMonitorCacheFile :: FilePath + -- ^ The file where this 'FileMonitor' should store its state. + , fileMonitorKeyValid :: a -> a -> Bool + -- ^ Compares a new cache key with old one to determine if a + -- corresponding cached value is still valid. + -- + -- Typically this is just an equality test, but in some + -- circumstances it can make sense to do things like subset + -- comparisons. + -- + -- The first arg is the new value, the second is the old cached value. + , fileMonitorCheckIfOnlyValueChanged :: Bool + -- ^ When this mode is enabled, if 'checkFileMonitorChanged' returns + -- 'MonitoredValueChanged' then we have the guarantee that no files + -- changed, that the value change was the only change. In the default + -- mode no such guarantee is provided which is slightly faster. + } + +-- | Define a new file monitor. +-- +-- It's best practice to define file monitor values once, and then use the +-- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this +-- ensures you get the same types @a@ and @b@ for reading and writing. +-- +-- The path of the file monitor itself must be unique because it keeps state +-- on disk and these would clash. +newFileMonitor + :: Eq a + => FilePath + -- ^ The file to cache the state of the + -- file monitor. Must be unique. + -> FileMonitor a b +newFileMonitor path = FileMonitor path (==) False + +-- | The result of 'checkFileMonitorChanged': either the monitored files or +-- value changed (and it tells us which it was) or nothing changed and we get +-- the cached result. +data MonitorChanged a b + = -- | The monitored files and value did not change. The cached result is + -- @b@. + -- + -- The set of monitored files is also returned. This is useful + -- for composing or nesting 'FileMonitor's. + MonitorUnchanged b [MonitorFilePath] + | -- | The monitor found that something changed. The reason is given. + MonitorChanged (MonitorChangedReason a) + deriving (Show) + +-- | What kind of change 'checkFileMonitorChanged' detected. +data MonitorChangedReason a + = -- | One of the files changed (existence, file type, mtime or file + -- content, depending on the 'MonitorFilePath' in question) + MonitoredFileChanged FilePath + | -- | The pure input value changed. + -- + -- The previous cached key value is also returned. This is sometimes + -- useful when using a 'fileMonitorKeyValid' function that is not simply + -- '(==)', when invalidation can be partial. In such cases it can make + -- sense to 'updateFileMonitor' with a key value that's a combination of + -- the new and old (e.g. set union). + MonitoredValueChanged a + | -- | There was no saved monitor state, cached value etc. Ie the file + -- for the 'FileMonitor' does not exist. + MonitorFirstRun + | -- | There was existing state, but we could not read it. This typically + -- happens when the code has changed compared to an existing 'FileMonitor' + -- cache file and type of the input value or cached value has changed such + -- that we cannot decode the values. This is completely benign as we can + -- treat is just as if there were no cache file and re-run. + MonitorCorruptCache + deriving (Eq, Show, Functor) + +-- | Test if the input value or files monitored by the 'FileMonitor' have +-- changed. If not, return the cached value. +-- +-- See 'FileMonitor' for a full explanation. +checkFileMonitorChanged + :: forall a b + . (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -- ^ cache file path + -> FilePath + -- ^ root directory + -> a + -- ^ guard or key value + -> IO (MonitorChanged a b) + -- ^ did the key or any paths change? +checkFileMonitorChanged + monitor@FileMonitor + { fileMonitorKeyValid + , fileMonitorCheckIfOnlyValueChanged + } + root + currentKey = + -- Consider it a change if the cache file does not exist, + -- or we cannot decode it. Sadly ErrorCall can still happen, despite + -- using decodeFileOrFail, e.g. Data.Char.chr errors + + handleDoesNotExist (MonitorChanged MonitorFirstRun) $ + handleErrorCall (MonitorChanged MonitorCorruptCache) $ + withCacheFile monitor $ + either + (\_ -> return (MonitorChanged MonitorCorruptCache)) + checkStatusCache + where + checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b) + checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do + change <- checkForChanges + case change of + Just reason -> return (MonitorChanged reason) + Nothing -> case cachedResult of + Left _ -> pure (MonitorChanged MonitorCorruptCache) + Right cr -> return (MonitorUnchanged cr monitorFiles) + where + monitorFiles = reconstructMonitorFilePaths cachedFileStatus + where + -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that + -- if we return MonitoredValueChanged that only the value changed. + -- We do that by checking for file changes first. Otherwise it makes + -- more sense to do the cheaper test first. + checkForChanges :: IO (Maybe (MonitorChangedReason a)) + checkForChanges + | fileMonitorCheckIfOnlyValueChanged = + checkFileChange cachedFileStatus cachedKey cachedResult + `mplusMaybeT` checkValueChange cachedKey + | otherwise = + checkValueChange cachedKey + `mplusMaybeT` checkFileChange cachedFileStatus cachedKey cachedResult + + mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1) + mplusMaybeT ma mb = do + mx <- ma + case mx of + Nothing -> mb + Just x -> return (Just x) + + -- Check if the guard value has changed + checkValueChange :: a -> IO (Maybe (MonitorChangedReason a)) + checkValueChange cachedKey + | not (fileMonitorKeyValid currentKey cachedKey) = + return (Just (MonitoredValueChanged cachedKey)) + | otherwise = + return Nothing + + -- Check if any file has changed + checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a)) + checkFileChange cachedFileStatus cachedKey cachedResult = do + res <- probeFileSystem root cachedFileStatus + case res of + -- Some monitored file has changed + Left changedPath -> + return (Just (MonitoredFileChanged (normalise changedPath))) + -- No monitored file has changed + Right (cachedFileStatus', cacheStatus) -> do + -- But we might still want to update the cache + whenCacheChanged cacheStatus $ + case cachedResult of + Left _ -> pure () + Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr + + return Nothing + +-- | Lazily decode a triple, parsing the first two fields strictly and +-- returning a lazy value containing either the last one or an error. +-- This is helpful for cabal cache files where the first two components +-- contain header data that lets one test if the cache is still valid, +-- and the last (potentially large) component is the cached value itself. +-- This way we can test for cache validity without needing to pay the +-- cost of the decode of stale cache data. This lives here rather than +-- Distribution.Utils.Structured because it depends on a newer version of +-- binary than supported in the Cabal library proper. +structuredDecodeTriple + :: forall a b c + . (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c) + => BS.ByteString + -> Either String (a, b, Either String c) +structuredDecodeTriple lbs = + let partialDecode = + (`runGetOrFail` lbs) $ do + (_ :: Tag (a, b, c)) <- Binary.get + (a :: a) <- Binary.get + (b :: b) <- Binary.get + pure (a, b) + cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + cleanEither (Right (_, _, v)) = Right v + in case partialDecode of + Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) + Right (lbs', _, (x, y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') + +-- | Helper for reading the cache file. +-- +-- This determines the type and format of the binary cache file. +withCacheFile + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) + -> IO r +withCacheFile (FileMonitor{fileMonitorCacheFile}) k = + withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do + contents <- structuredDecodeTriple <$> BS.hGetContents hnd + k contents + +-- | Helper for writing the cache file. +-- +-- This determines the type and format of the binary cache file. +rewriteCacheFile + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> MonitorStateFileSet + -> a + -> b + -> IO () +rewriteCacheFile FileMonitor{fileMonitorCacheFile} fileset key result = + writeFileAtomic fileMonitorCacheFile $ + structuredEncode (fileset, key, result) + +-- | Probe the file system to see if any of the monitored files have changed. +-- +-- It returns Nothing if any file changed, or returns a possibly updated +-- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. +-- +-- We may need to update the cache since there may be changes in the filesystem +-- state which don't change any of our affected files. +-- +-- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a +-- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run +-- and find @proj2@ was created, yet contains no files matching @*.cabal@ then +-- we want to update the cache despite no changes in our relevant file set. +-- Specifically, we should add an mtime for this directory so we can avoid +-- re-traversing the directory in future runs. +probeFileSystem + :: FilePath + -> MonitorStateFileSet + -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) +probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = + runChangedM $ do + sequence_ + [ probeMonitorStateFileStatus root file status + | MonitorStateFile _ _ file status <- singlePaths + ] + -- The glob monitors can require state changes + globPaths' <- + sequence + [ probeMonitorStateGlob root globPath + | globPath <- globPaths + ] + return (MonitorStateFileSet singlePaths globPaths') + +----------------------------------------------- +-- Monad for checking for file system changes +-- +-- We need to be able to bail out if we detect a change (using ExceptT), +-- but if there's no change we need to be able to rebuild the monitor +-- state. And we want to optimise that rebuilding by keeping track if +-- anything actually changed (using StateT), so that in the typical case +-- we can avoid rewriting the state file. + +newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a) + deriving (Functor, Applicative, Monad, MonadIO) + +runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged)) +runChangedM (ChangedM action) = + runExceptT $ State.runStateT action CacheUnchanged + +somethingChanged :: FilePath -> ChangedM a +somethingChanged path = ChangedM $ throwError path + +cacheChanged :: ChangedM () +cacheChanged = ChangedM $ State.put CacheChanged + +mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a +mapChangedFile adjust (ChangedM a) = + ChangedM (mapStateT (withExceptT adjust) a) + +data CacheChanged = CacheChanged | CacheUnchanged + +whenCacheChanged :: Monad m => CacheChanged -> m () -> m () +whenCacheChanged CacheChanged action = action +whenCacheChanged CacheUnchanged _ = return () + +---------------------- + +-- | Probe the file system to see if a single monitored file has changed. +probeMonitorStateFileStatus + :: FilePath + -> FilePath + -> MonitorStateFileStatus + -> ChangedM () +probeMonitorStateFileStatus root file status = + case status of + MonitorStateFileExists -> + probeFileExistence root file + MonitorStateFileModTime mtime -> + probeFileModificationTime root file mtime + MonitorStateFileHashed mtime hash -> + probeFileModificationTimeAndHash root file mtime hash + MonitorStateDirExists -> + probeDirExistence root file + MonitorStateDirModTime mtime -> + probeFileModificationTime root file mtime + MonitorStateNonExistent -> + probeFileNonExistence root file + MonitorStateAlreadyChanged -> + somethingChanged file + +-- | Probe the file system to see if a monitored file glob has changed. +probeMonitorStateGlob + :: FilePath + -- ^ root path + -> MonitorStateGlob + -> ChangedM MonitorStateGlob +probeMonitorStateGlob + relroot + (MonitorStateGlob kindfile kinddir globroot glob) = do + root <- liftIO $ getFilePathRootDirectory globroot relroot + case globroot of + FilePathRelative -> + MonitorStateGlob kindfile kinddir globroot + <$> probeMonitorStateGlobRel kindfile kinddir root "." glob + -- for absolute cases, make the changed file we report absolute too + _ -> + mapChangedFile (root ) $ + MonitorStateGlob kindfile kinddir globroot + <$> probeMonitorStateGlobRel kindfile kinddir root "" glob + +probeMonitorStateFiles + :: FilePath + -- ^ root path + -> FilePath + -- ^ path of the directory we are + -- looking in relative to @root@ + -> GlobPieces + -- ^ file glob to filter monitored files + -> ModTime + -- ^ cached directory modification time + -> [(FilePath, MonitorStateFileStatus)] + -> ChangedM (ModTime, [(FilePath, MonitorStateFileStatus)]) +probeMonitorStateFiles + root + dirName + glob + mtime + children = do + change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime + mtime' <- case change of + Nothing -> return mtime + Just mtime' -> do + -- directory modification time changed: + -- a matching file may have been added or deleted + matches <- + return . filter (matchGlobPieces glob) + =<< liftIO (listDirectory (root dirName)) + + traverse_ probeMergeResult $ + mergeBy + (\(path1, _) path2 -> compare path1 path2) + children + (sort matches) + return mtime' + + -- Check that none of the children have changed + for_ children $ \(file, status) -> + probeMonitorStateFileStatus root (dirName file) status + + return (mtime', children) + where + -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use + -- the new mtime' if any. + + probeMergeResult + :: MergeResult (FilePath, MonitorStateFileStatus) FilePath + -> ChangedM () + probeMergeResult mr = case mr of + InBoth _ _ -> return () + -- this is just to be able to accurately report which file changed: + OnlyInLeft (path, _) -> somethingChanged (dirName path) + OnlyInRight path -> somethingChanged (dirName path) + +probeMonitorStateDirs + :: MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ root path + -> FilePath + -- ^ path of the directory we are + -- looking in relative to @root@ + -> Maybe GlobPieces + -- ^ optional glob to filter filenames by + -> Glob + -- ^ glob to filter subdirectories by + -> ModTime + -- ^ cached directory modification time + -> [(FilePath, MonitorStateGlobRel)] + -> ChangedM (ModTime, [(FilePath, MonitorStateGlobRel)]) +probeMonitorStateDirs + kindfile + kinddir + root + dirName + globMaybe + globPath + mtime + children = do + change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime + case change of + Nothing -> do + children' <- + sequence + [ do + fstate' <- + probeMonitorStateGlobRel + kindfile + kinddir + root + (dirName fname) + fstate + return (fname, fstate') + | (fname, fstate) <- children + ] + return $! (mtime, children') + Just mtime' -> do + -- directory modification time changed: + -- a matching subdir may have been added or deleted + matches <- + filterM + ( \entry -> + let subdir = root dirName entry + in liftIO $ doesDirectoryExist subdir + ) + . maybe id (filter . matchGlobPieces) globMaybe + =<< liftIO (listDirectory (root dirName)) + + children' <- + traverse probeMergeResult $ + mergeBy + (\(path1, _) path2 -> compare path1 path2) + children + (sort matches) + return $! (mtime', children') + where + -- Note that just because the directory has changed, we don't force + -- a cache rewrite with 'cacheChanged' since that has some cost, and + -- all we're saving is scanning the directory. But we do rebuild the + -- cache with the new mtime', so that if the cache is rewritten for + -- some other reason, we'll take advantage of that. + + probeMergeResult + :: MergeResult (FilePath, MonitorStateGlobRel) FilePath + -> ChangedM (FilePath, MonitorStateGlobRel) + + -- Only in cached (directory deleted) + probeMergeResult (OnlyInLeft (path, fstate)) = do + case allMatchingFiles (dirName path) fstate of + [] -> return (path, fstate) + -- Strictly speaking we should be returning 'CacheChanged' above + -- as we should prune the now-missing 'MonitorStateGlobRel'. However + -- we currently just leave these now-redundant entries in the + -- cache as they cost no IO and keeping them allows us to avoid + -- rewriting the cache. + (file : _) -> somethingChanged file + + -- Only in current filesystem state (directory added) + probeMergeResult (OnlyInRight path) = do + fstate <- + liftIO $ + buildMonitorStateGlobRel + Nothing + Map.empty + kindfile + kinddir + root + (dirName path) + globPath + case allMatchingFiles (dirName path) fstate of + (file : _) -> somethingChanged file + -- This is the only case where we use 'cacheChanged' because we can + -- have a whole new dir subtree (of unbounded size and cost), so we + -- need to save the state of that new subtree in the cache. + [] -> cacheChanged >> return (path, fstate) + + -- Found in path + probeMergeResult (InBoth (path, fstate) _) = do + fstate' <- + probeMonitorStateGlobRel + kindfile + kinddir + root + (dirName path) + fstate + return (path, fstate') + + allMatchingFilesFromGlobFiles :: FilePath -> [(FilePath, a)] -> [FilePath] + allMatchingFilesFromGlobFiles dir entries = + [dir fname | (fname, _) <- entries] + + allMatchingFilesFromGlobDirs :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [FilePath] + allMatchingFilesFromGlobDirs dir entries = + [ res + | (subdir, fstate) <- entries + , res <- allMatchingFiles (dir subdir) fstate + ] + + -- \| Does a 'MonitorStateGlob' have any relevant files within it? + allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] + allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = + allMatchingFilesFromGlobFiles dir entries + allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = + allMatchingFilesFromGlobDirs dir entries + allMatchingFiles dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) = + allMatchingFilesFromGlobFiles dir fileEntries + ++ allMatchingFilesFromGlobDirs dir dirEntries + allMatchingFiles dir MonitorStateGlobDirTrailing = + [dir] + +probeMonitorStateGlobRel + :: MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ root path + -> FilePath + -- ^ path of the directory we are + -- looking in relative to @root@ + -> MonitorStateGlobRel + -> ChangedM MonitorStateGlobRel +probeMonitorStateGlobRel + kindfile + kinddir + root + dirName + (MonitorStateGlobDirs glob globPath mtime children) = do + (mtime', children') <- + probeMonitorStateDirs + kindfile + kinddir + root + dirName + (Just glob) + globPath + mtime + children + return $! MonitorStateGlobDirs glob globPath mtime' children' +probeMonitorStateGlobRel + _ + _ + root + dirName + (MonitorStateGlobFiles glob mtime children) = do + change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime + mtime' <- case change of + Nothing -> return mtime + Just mtime' -> do + -- directory modification time changed: + -- a matching file may have been added or deleted + matches <- + return . filter (matchGlobPieces glob) + =<< liftIO (listDirectory (root dirName)) + + traverse_ probeMergeResult $ + mergeBy + (\(path1, _) path2 -> compare path1 path2) + children + (sort matches) + return mtime' + + -- Check that none of the children have changed + for_ children $ \(file, status) -> + probeMonitorStateFileStatus root (dirName file) status + + return (MonitorStateGlobFiles glob mtime' children) + where + -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use + -- the new mtime' if any. + + probeMergeResult + :: MergeResult (FilePath, MonitorStateFileStatus) FilePath + -> ChangedM () + probeMergeResult mr = case mr of + InBoth _ _ -> return () + -- this is just to be able to accurately report which file changed: + OnlyInLeft (path, _) -> somethingChanged (dirName path) + OnlyInRight path -> somethingChanged (dirName path) +probeMonitorStateGlobRel + kindfile + kinddir + root + dirName + (MonitorStateGlobRecursive glob mtime fileChildren dirChildren) = do + -- For recursive globs, we check the file children first, then recurse + -- into subdirectories, applying the same logic as 'MonitorStateGlobFiles' + -- and 'MonitorStateGlobDirs', respectively. + (_, fileChildren') <- + probeMonitorStateFiles + root + dirName + glob + mtime + fileChildren + (mtime', dirChildren') <- + probeMonitorStateDirs + kindfile + kinddir + root + dirName + Nothing + (GlobDirRecursive glob) + mtime + dirChildren + return $! MonitorStateGlobRecursive glob mtime' fileChildren' dirChildren' +probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = + return MonitorStateGlobDirTrailing + +------------------------------------------------------------------------------ + +-- | Update the input value and the set of files monitored by the +-- 'FileMonitor', plus the cached value that may be returned in future. +-- +-- This takes a snapshot of the state of the monitored files right now, so +-- 'checkFileMonitorChanged' will look for file system changes relative to +-- this snapshot. +-- +-- This is typically done once the action has been completed successfully and +-- we have the action's result and we know what files it looked at. See +-- 'FileMonitor' for a full explanation. +-- +-- If we do take the snapshot after the action has completed then we have a +-- problem. The problem is that files might have changed /while/ the action was +-- running but /after/ the action read them. If we take the snapshot after the +-- action completes then we will miss these changes. The solution is to record +-- a timestamp before beginning execution of the action and then we make the +-- conservative assumption that any file that has changed since then has +-- already changed, ie the file monitor state for these files will be such that +-- 'checkFileMonitorChanged' will report that they have changed. +-- +-- So if you do use 'updateFileMonitor' after the action (so you can discover +-- the files used rather than predicting them in advance) then use +-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, +-- if you take the snapshot in advance of the action, or you're not monitoring +-- any files then you can use @Nothing@ for the timestamp parameter. +updateFileMonitor + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -- ^ cache file path + -> FilePath + -- ^ root directory + -> Maybe MonitorTimestamp + -- ^ timestamp when the update action started + -> [MonitorFilePath] + -- ^ files of interest relative to root + -> a + -- ^ the current key value + -> b + -- ^ the current result value + -> IO () +updateFileMonitor + monitor + root + startTime + monitorFiles + cachedKey + cachedResult = do + hashcache <- readCacheFileHashes monitor + msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles + rewriteCacheFile monitor msfs cachedKey cachedResult + +-- | A timestamp to help with the problem of file changes during actions. +-- See 'updateFileMonitor' for details. +newtype MonitorTimestamp = MonitorTimestamp ModTime + +-- | Record a timestamp at the beginning of an action, and when the action +-- completes call 'updateFileMonitor' passing it the timestamp. +-- See 'updateFileMonitor' for details. +beginUpdateFileMonitor :: IO MonitorTimestamp +beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime + +-- | Take the snapshot of the monitored files. That is, given the +-- specification of the set of files we need to monitor, inspect the state +-- of the file system now and collect the information we'll need later to +-- determine if anything has changed. +buildMonitorStateFileSet + :: Maybe MonitorTimestamp + -- ^ optional: timestamp + -- of the start of the action + -> FileHashCache + -- ^ existing file hashes + -> FilePath + -- ^ root directory + -> [MonitorFilePath] + -- ^ patterns of interest + -- relative to root + -> IO MonitorStateFileSet +buildMonitorStateFileSet mstartTime hashcache root = + go [] [] + where + go + :: [MonitorStateFile] + -> [MonitorStateGlob] + -> [MonitorFilePath] + -> IO MonitorStateFileSet + go !singlePaths !globPaths [] = + return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) + go + !singlePaths + !globPaths + (MonitorFile kindfile kinddir path : monitors) = do + monitorState <- + MonitorStateFile kindfile kinddir path + <$> buildMonitorStateFile + mstartTime + hashcache + kindfile + kinddir + root + path + go (monitorState : singlePaths) globPaths monitors + go + !singlePaths + !globPaths + (MonitorFileGlob kindfile kinddir globPath : monitors) = do + monitorState <- + buildMonitorStateGlob + mstartTime + hashcache + kindfile + kinddir + root + globPath + go singlePaths (monitorState : globPaths) monitors + +buildMonitorStateFile + :: Maybe MonitorTimestamp + -- ^ start time of update + -> FileHashCache + -- ^ existing file hashes + -> MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ the root directory + -> FilePath + -> IO MonitorStateFileStatus +buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do + let abspath = root path + isFile <- doesFileExist abspath + isDir <- doesDirectoryExist abspath + case (isFile, kindfile, isDir, kinddir) of + (_, FileNotExists, _, DirNotExists) -> + -- we don't need to care if it exists now, since we check at probe time + return MonitorStateNonExistent + (False, _, False, _) -> + return MonitorStateAlreadyChanged + (True, FileExists, _, _) -> + return MonitorStateFileExists + (True, FileModTime, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateFileModTime mtime) + (True, FileHashed, _, _) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else do + hash <- getFileHash hashcache abspath abspath mtime + return (MonitorStateFileHashed mtime hash) + (_, _, True, DirExists) -> + return MonitorStateDirExists + (_, _, True, DirModTime) -> + handleIOException MonitorStateAlreadyChanged $ do + mtime <- getModTime abspath + if changedDuringUpdate mstartTime mtime + then return MonitorStateAlreadyChanged + else return (MonitorStateDirModTime mtime) + (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged + (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged + +-- | If we have a timestamp for the beginning of the update, then any file +-- mtime later than this means that it changed during the update and we ought +-- to consider the file as already changed. +changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool +changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime = + mtime > startTime +changedDuringUpdate _ _ = False + +-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case +-- of a file glob. +-- +-- This gets used both by 'buildMonitorStateFileSet' when we're taking the +-- file system snapshot, but also by 'probeGlobStatus' as part of checking +-- the monitored (globed) files for changes when we find a whole new subtree. +buildMonitorStateGlob + :: Maybe MonitorTimestamp + -- ^ start time of update + -> FileHashCache + -- ^ existing file hashes + -> MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ the root directory + -> RootedGlob + -- ^ the matching glob + -> IO MonitorStateGlob +buildMonitorStateGlob + mstartTime + hashcache + kindfile + kinddir + relroot + (RootedGlob globroot globPath) = do + root <- liftIO $ getFilePathRootDirectory globroot relroot + MonitorStateGlob kindfile kinddir globroot + <$> buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + "." + globPath + +buildMonitorStateGlobRel + :: Maybe MonitorTimestamp + -- ^ start time of update + -> FileHashCache + -- ^ existing file hashes + -> MonitorKindFile + -> MonitorKindDir + -> FilePath + -- ^ the root directory + -> FilePath + -- ^ directory we are examining + -- relative to the root + -> Glob + -- ^ the matching glob + -> IO MonitorStateGlobRel +buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + dir + globPath = do + let absdir = root dir + dirEntries <- listDirectory absdir + dirMTime <- getModTime absdir + case globPath of + GlobDirRecursive glob -> do + -- evaluate globPath' over the current directory + let files = filter (matchGlobPieces glob) dirEntries + filesStates <- + for (sort files) $ \file -> do + fstate <- + buildMonitorStateFile + mstartTime + hashcache + kindfile + kinddir + root + (dir file) + return (file, fstate) + -- evaluate globPath' over every subdirectory + subdirs <- + filterM (\subdir -> doesDirectoryExist (absdir subdir)) dirEntries + subdirStates <- + for (sort subdirs) $ \subdir -> do + fstate <- + buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + (dir subdir) + globPath + return (subdir, fstate) + + return $! MonitorStateGlobRecursive glob dirMTime filesStates subdirStates + GlobDir glob globPath' -> do + subdirs <- + filterM (\subdir -> doesDirectoryExist (absdir subdir)) $ + filter (matchGlobPieces glob) dirEntries + subdirStates <- + for (sort subdirs) $ \subdir -> do + fstate <- + buildMonitorStateGlobRel + mstartTime + hashcache + kindfile + kinddir + root + (dir subdir) + globPath' + return (subdir, fstate) + return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates + GlobFile glob -> do + let files = filter (matchGlobPieces glob) dirEntries + filesStates <- + for (sort files) $ \file -> do + fstate <- + buildMonitorStateFile + mstartTime + hashcache + kindfile + kinddir + root + (dir file) + return (file, fstate) + return $! MonitorStateGlobFiles glob dirMTime filesStates + GlobDirTrailing -> + return MonitorStateGlobDirTrailing + +-- | We really want to avoid re-hashing files all the time. We already make +-- the assumption that if a file mtime has not changed then we don't need to +-- bother checking if the content hash has changed. We can apply the same +-- assumption when updating the file monitor state. In the typical case of +-- updating a file monitor the set of files is the same or largely the same so +-- we can grab the previously known content hashes with their corresponding +-- mtimes. +type FileHashCache = Map FilePath (ModTime, Fingerprint) + +-- | We declare it a cache hit if the mtime of a file is the same as before. +lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Fingerprint +lookupFileHashCache hashcache file mtime = do + (mtime', hash) <- Map.lookup file hashcache + guard (mtime' == mtime) + return hash + +-- | Either get it from the cache or go read the file +getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Fingerprint +getFileHash hashcache relfile absfile mtime = + case lookupFileHashCache hashcache relfile mtime of + Just hash -> return hash + Nothing -> Fingerprint.getFileHash absfile + +-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While +-- in principle we could preserve the structure of the previous state, given +-- that the set of files to monitor can change then it's simpler just to throw +-- away the structure and use a finite map. +readCacheFileHashes + :: (Binary a, Structured a, Binary b, Structured b) + => FileMonitor a b + -> IO FileHashCache +readCacheFileHashes monitor = + handleDoesNotExist Map.empty $ + handleErrorCall Map.empty $ + withCacheFile monitor $ \case + Left _ -> return Map.empty + Right (msfs, _, _) -> return (mkFileHashCache msfs) + where + mkFileHashCache :: MonitorStateFileSet -> FileHashCache + mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = + collectAllFileHashes singlePaths + `Map.union` collectAllGlobHashes globPaths + + collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Fingerprint) + collectAllFileHashes singlePaths = + Map.fromList + [ (fpath, (mtime, hash)) + | MonitorStateFile + _ + _ + fpath + (MonitorStateFileHashed mtime hash) <- + singlePaths + ] + + collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Fingerprint) + collectAllGlobHashes globPaths = + Map.fromList + [ (fpath, (mtime, hash)) + | MonitorStateGlob _ _ _ gstate <- globPaths + , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate + ] + + collectDirHashes :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [(FilePath, (ModTime, Fingerprint))] + collectDirHashes dir entries = + [ res + | (subdir, fstate) <- entries + , res <- collectGlobHashes (dir subdir) fstate + ] + + collectFileHashes :: FilePath -> [(FilePath, MonitorStateFileStatus)] -> [(FilePath, (ModTime, Fingerprint))] + collectFileHashes dir entries = + [ (dir fname, (mtime, hash)) + | (fname, MonitorStateFileHashed mtime hash) <- entries + ] + + collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Fingerprint))] + collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = + collectDirHashes dir entries + collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = + collectFileHashes dir entries + collectGlobHashes dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) = + collectFileHashes dir fileEntries + ++ collectDirHashes dir dirEntries + collectGlobHashes _dir MonitorStateGlobDirTrailing = + [] + +------------------------------------------------------------------------------ +-- Utils +-- + +-- | Within the @root@ directory, check if @file@ has its 'ModTime' is +-- the same as @mtime@, short-circuiting if it is different. +probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () +probeFileModificationTime root file mtime = do + unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime + unless unchanged (somethingChanged file) + +-- | Within the @root@ directory, check if @file@ has its 'ModTime' and +-- 'Fingerprint' is the same as @mtime@ and @hash@, short-circuiting if it is +-- different. +probeFileModificationTimeAndHash + :: FilePath + -> FilePath + -> ModTime + -> Fingerprint + -> ChangedM () +probeFileModificationTimeAndHash root file mtime hash = do + unchanged <- + liftIO $ + checkFileModificationTimeAndHashUnchanged root file mtime hash + unless unchanged (somethingChanged file) + +-- | Within the @root@ directory, check if @file@ still exists as a file. +-- If it *does not* exist, short-circuit. +probeFileExistence :: FilePath -> FilePath -> ChangedM () +probeFileExistence root file = do + existsFile <- liftIO $ doesFileExist (root file) + unless existsFile (somethingChanged file) + +-- | Within the @root@ directory, check if @dir@ still exists. +-- If it *does not* exist, short-circuit. +probeDirExistence :: FilePath -> FilePath -> ChangedM () +probeDirExistence root dir = do + existsDir <- liftIO $ doesDirectoryExist (root dir) + unless existsDir (somethingChanged dir) + +-- | Within the @root@ directory, check if @file@ still does not exist. +-- If it *does* exist, short-circuit. +probeFileNonExistence :: FilePath -> FilePath -> ChangedM () +probeFileNonExistence root file = do + existsFile <- liftIO $ doesFileExist (root file) + existsDir <- liftIO $ doesDirectoryExist (root file) + when (existsFile || existsDir) (somethingChanged file) + +-- | Returns @True@ if, inside the @root@ directory, @file@ has the same +-- 'ModTime' as @mtime@. +checkModificationTimeUnchanged + :: FilePath + -> FilePath + -> ModTime + -> IO Bool +checkModificationTimeUnchanged root file mtime = + handleIOException False $ do + mtime' <- getModTime (root file) + return (mtime == mtime') + +-- | Returns @True@ if, inside the @root@ directory, @file@ has the +-- same 'ModTime' and 'Fingerprint' as @mtime@ and @chash@. +checkFileModificationTimeAndHashUnchanged + :: FilePath + -> FilePath + -> ModTime + -> Fingerprint + -> IO Bool +checkFileModificationTimeAndHashUnchanged root file mtime chash = + handleIOException False $ do + mtime' <- getModTime (root file) + if mtime == mtime' + then return True + else do + chash' <- Fingerprint.getFileHash (root file) + return (chash == chash') + +-- | Given a directory @dir@, return @Nothing@ if its 'ModTime' +-- is the same as @mtime@, and the new 'ModTime' if it is not. +checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) +checkDirectoryModificationTime dir mtime = + handleIOException Nothing $ do + mtime' <- getModTime dir + if mtime == mtime' + then return Nothing + else return (Just mtime') + +-- | Run an IO computation, returning the first argument @e@ if there is an 'error' +-- call. ('ErrorCall') +handleErrorCall :: a -> IO a -> IO a +handleErrorCall e = handle handler + where + handler (ErrorCall _) = return e + +-- | Run an IO computation, returning @e@ if there is any 'IOException'. +-- +-- This policy is OK in the file monitor code because it just causes the +-- monitor to report that something changed, and then code reacting to that +-- will normally encounter the same IO exception when it re-runs the action +-- that uses the file. +handleIOException :: a -> IO a -> IO a +handleIOException e = + handle (anyIOException e) + where + anyIOException :: a -> IOException -> IO a + anyIOException x _ = return x + +------------------------------------------------------------------------------ +-- Instances +-- diff --git a/Cabal/src/Distribution/Simple/FileMonitor/Types.hs b/Cabal/src/Distribution/Simple/FileMonitor/Types.hs index e3f37f2b6d9..7a85110f410 100644 --- a/Cabal/src/Distribution/Simple/FileMonitor/Types.hs +++ b/Cabal/src/Distribution/Simple/FileMonitor/Types.hs @@ -7,6 +7,7 @@ module Distribution.Simple.FileMonitor.Types RootedGlob (..) , FilePathRoot (..) , Glob + , getFilePathRootDirectory -- * File monitoring , MonitorFilePath (..) @@ -38,6 +39,7 @@ import qualified Distribution.Compat.CharParsing as P import Distribution.Parsec import Distribution.Pretty import Distribution.Utils.Generic (isAsciiAlpha) +import System.Directory (getHomeDirectory) import qualified Text.PrettyPrint as Disp -------------------------------------------------------------------------------- @@ -67,6 +69,19 @@ data FilePathRoot instance Binary FilePathRoot instance Structured FilePathRoot +-- | Get the 'FilePath' corresponding to a 'FilePathRoot'. +-- +-- The 'FilePath' argument is required to supply the path for the +-- 'FilePathRelative' case. +getFilePathRootDirectory + :: FilePathRoot + -> FilePath + -- ^ root for relative paths + -> IO FilePath +getFilePathRootDirectory FilePathRelative root = return root +getFilePathRootDirectory (FilePathRoot root) _ = return root +getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory + ------------------------------------------------------------------------------ -- Types for specifying files to monitor -- diff --git a/Cabal/src/Distribution/Simple/RebuildMonad.hs b/Cabal/src/Distribution/Simple/RebuildMonad.hs new file mode 100644 index 00000000000..093ba85467e --- /dev/null +++ b/Cabal/src/Distribution/Simple/RebuildMonad.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | An abstraction for re-running actions if values or files have changed. +-- +-- This is not a full-blown make-style incremental build system, it's a bit +-- more ad-hoc than that, but it's easier to integrate with existing code. +-- +-- It's a convenient interface to the "Distribution.Simple.FileMonitor" +-- functions. +module Distribution.Simple.RebuildMonad + ( -- * MonadRebuild class + MonadRebuild (..) + + -- * Setting up file monitoring + , monitorFiles + , MonitorFilePath + , monitorFile + , monitorFileHashed + , monitorNonExistentFile + , monitorDirectory + , monitorNonExistentDirectory + , monitorDirectoryExistence + , monitorFileOrDirectory + , monitorFileSearchPath + , monitorFileHashedSearchPath + + -- ** Monitoring file globs + , monitorFileGlob + , monitorFileGlobExistence + , RootedGlob (..) + , FilePathRoot (..) + + -- * Using a file monitor + , FileMonitor (..) + , newFileMonitor + , rerunIfChanged' + + -- * Utils + , delayInitSharedResource + , delayInitSharedResources + , getDirectoryContentsMonitored + , createDirectoryMonitored + , monitorDirectoryStatus + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.FileMonitor +import Distribution.Verbosity (Verbosity (..)) + +import Distribution.Simple.Utils (debug) + +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) +import Control.Monad +import Control.Monad.Writer as Writer +import qualified Data.Map.Strict as Map +import System.Directory +import System.FilePath + +-- | A monad layered on top of 'IO' to help with re-running actions when the +-- input files and values they depend on change. The crucial operations are +-- 'rerunIfChanged'' and 'monitorFiles'. +class + (Monad m, MonadIO m, MonadWriter [MonitorFilePath] m) => + MonadRebuild m + where + -- | Lift an 'IO' action into a 'MonadRebuild' context, such that other + -- (compatible) 'MonadRebuild' actions can be unlifted inside that 'IO' + -- action. This is similar to @MonadUnliftIO@ or @MonadBaseControl@, but + -- specifically designed to support the needs of 'MonadRebuild': collecting + -- dependent file paths to monitor, providing 'liftIO', and allowing + -- instances to inject additional monadic context (@MonadReader@ or + -- equivalent). + -- + -- The usage pattern for this looks something like this: + -- + -- > foobar :: MonadRebuild m => m ResultType + -- > foobar = do + -- > -- We are in the 'm' monad here + -- > withRunRebuildInIO $ \runInIO -> do + -- > -- Now we are in 'IO' + -- > x <- doSomethingInIO + -- > (result, files) <- runInIO $ do + -- > -- We are back in 'm'; the result of 'someRebuildAction' becomes + -- > -- the first tuple element of the 'runInIO' return type, while any + -- > -- file monitoring paths become the second element. + -- > someRebuildAction x + -- > result' <- someIOProcessing result + -- > -- Return the result and the files that resulted from the inner 'm' + -- > -- action; the result will become the result of the outer 'm' action, + -- > -- while the files get injected back into the 'm' monad. + -- > return (result', files) + withRunRebuildInIO + :: ((forall a. m a -> IO (a, [MonitorFilePath])) -> IO (b, [MonitorFilePath])) + -> m b + +-- | Minimal instance for a simple @WriterT [MonitorFilePath] IO@. +instance MonadRebuild (WriterT [MonitorFilePath] IO) where + withRunRebuildInIO inner = do + (result, files) <- liftIO $ inner runWriterT + Writer.tell files + return result + +-- | Use this within the body action of 'rerunIfChanged' to declare that the +-- action depends on the given files. This can be based on what the action +-- actually did. It is these files that will be checked for changes next +-- time 'rerunIfChanged' is called for that 'FileMonitor'. +-- +-- Relative paths are interpreted as relative to an implicit root, ultimately +-- passed in to 'runRebuild'. +monitorFiles :: MonadRebuild m => [MonitorFilePath] -> m () +monitorFiles filespecs = + Writer.tell filespecs + +-- | This captures the standard use pattern for a 'FileMonitor': given a +-- monitor, an action and the input value the action depends on, either +-- re-run the action to get its output, or if the value and files the action +-- depends on have not changed then return a previously cached action result. +-- +-- The result is still in the original 'MonadRebuild' monad, so these can be +-- nested. +-- +-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged''. +rerunIfChanged' + :: (Binary a, Structured a, Binary b, Structured b, MonadRebuild m) + => Verbosity + -> FilePath + -- ^ Root directory for file monitoring. Used to resolve relative paths + -- in file monitors. + -> ([IO (b, [MonitorFilePath])] -> IO [(b, [MonitorFilePath])]) + -- ^ Helper function for combining multiple IO actions into a single one. + -- For serial execution, this can simply be 'sequence'; for concurrent + -- execution, something more sophisticated can be passed here. + -> [(FileMonitor a b, a, m b)] + -- ^ Triples of a file monitor, a key to identify it, and an associated + -- action. + -> m [b] +rerunIfChanged' verbosity rootDir chainIOs triples = do + withRunRebuildInIO $ \runInIO -> do + dacts <- forM triples $ \(monitor, key, action) -> do + let monitorName = takeFileName (fileMonitorCacheFile monitor) + changed <- liftIO $ checkFileMonitorChanged monitor rootDir key + case changed of + MonitorUnchanged result files -> do + debug verbosity $ + "File monitor '" + ++ monitorName + ++ "' unchanged." + ((), files') <- runInIO $ monitorFiles files + return (return (result, files')) + MonitorChanged reason -> do + debug verbosity $ + "File monitor '" + ++ monitorName + ++ "' changed: " + ++ showReason reason + return $ do + startTime <- beginUpdateFileMonitor + (result, files) <- runInIO action + updateFileMonitor + monitor + rootDir + (Just startTime) + files + key + result + return (result, files) + + (results, files) <- unzip <$> chainIOs dacts + return (results, mconcat files) + where + showReason (MonitoredFileChanged file) = "file " ++ file + showReason (MonitoredValueChanged _) = "monitor value changed" + showReason MonitorFirstRun = "first run" + showReason MonitorCorruptCache = "invalid cache file" + +-- | When using 'rerunIfChanged' for each element of a list of actions, it is +-- sometimes the case that each action needs to make use of some resource. e.g. +-- +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- mkResource +-- > ... -- use the resource +-- > | ... ] +-- +-- For efficiency one would like to share the resource between the actions +-- but the straightforward way of doing this means initialising it every time +-- even when no actions need re-running. +-- +-- > resource <- mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > ... -- use the resource +-- > | ... ] +-- +-- This utility allows one to get the best of both worlds: +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource +-- > ... -- use the resource +-- > | ... ] +delayInitSharedResource :: forall a m. MonadIO m => IO a -> m (m a) +delayInitSharedResource action = do + var <- liftIO (newMVar Nothing) + return (liftIO (getOrInitResource var)) + where + getOrInitResource :: MVar (Maybe a) -> IO a + getOrInitResource var = + modifyMVar var $ \case + Just x -> return (Just x, x) + Nothing -> do + x <- action + return (Just x, x) + +-- | Much like 'delayInitSharedResource' but for a keyed set of resources. +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource key +-- > ... -- use the resource +-- > | ... ] +delayInitSharedResources + :: forall k v m + . (Ord k, MonadIO m) + => (k -> IO v) + -> m (k -> m v) +delayInitSharedResources action = do + var <- liftIO (newMVar Map.empty) + return (liftIO . getOrInitResource var) + where + getOrInitResource :: MVar (Map k v) -> k -> IO v + getOrInitResource var k = + modifyMVar var $ \m -> + case Map.lookup k m of + Just x -> return (m, x) + Nothing -> do + x <- action k + let !m' = Map.insert k x m + return (m', x) + +getDirectoryContentsMonitored :: MonadRebuild m => FilePath -> m [FilePath] +getDirectoryContentsMonitored dir = do + exists <- monitorDirectoryStatus dir + if exists + then liftIO $ listDirectory dir + else return [] + +createDirectoryMonitored :: MonadRebuild m => Bool -> FilePath -> m () +createDirectoryMonitored createParents dir = do + monitorFiles [monitorDirectoryExistence dir] + liftIO $ createDirectoryIfMissing createParents dir + +-- | Monitor a directory as in 'monitorDirectory' if it currently exists or +-- as 'monitorNonExistentDirectory' if it does not. +monitorDirectoryStatus :: MonadRebuild m => FilePath -> m Bool +monitorDirectoryStatus dir = do + exists <- liftIO $ doesDirectoryExist dir + monitorFiles + [ if exists + then monitorDirectory dir + else monitorNonExistentDirectory dir + ] + return exists diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 3186e2950f1..22f7e991809 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -201,6 +201,10 @@ module Distribution.Simple.Utils , wrapText , wrapLine , stripCommonPrefix + , MergeResult (..) + , mergeBy + , duplicates + , duplicatesBy -- * FilePath stuff , isAbsoluteOnAnyPlatform @@ -243,6 +247,9 @@ import Distribution.Parsec import Distribution.Pretty import qualified Data.ByteString.Lazy as BS +import Data.List + ( groupBy + ) import Data.Typeable ( cast ) @@ -2194,3 +2201,31 @@ stripCommonPrefix (x : xs) (y : ys) | x == y = stripCommonPrefix xs ys | otherwise = y : ys stripCommonPrefix _ ys = ys + +-- | Generic merging utility. For sorted input lists this is a full outer join. +mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge :: [a] -> [b] -> [MergeResult a b] + merge [] ys = [OnlyInRight y | y <- ys] + merge xs [] = [OnlyInLeft x | x <- xs] + merge (x : xs) (y : ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x : xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y : ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [NonEmpty a] +duplicates = duplicatesBy compare + +duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a] +duplicatesBy cmp = mapMaybe moreThanOne . groupBy eq . sortBy cmp + where + eq :: a -> a -> Bool + eq a b = case cmp a b of + EQ -> True + _ -> False + moreThanOne (x : xs@(_ : _)) = Just (x :| xs) + moreThanOne _ = Nothing diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 83628ab03d1..c4adb43d607 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -243,7 +243,6 @@ library , async >= 2.0 && < 2.3 , array >= 0.4 && < 0.6 , base16-bytestring >= 1.0 && < 1.1 - , binary >= 0.7.3 && < 0.9 , bytestring >= 0.10.6.0 && < 0.13 , containers >= 0.5.6.2 && < 0.9 , cryptohash-sha256 >= 0.11 && < 0.12 @@ -333,7 +332,6 @@ test-suite unit-tests UnitTests.Distribution.Client.Configure UnitTests.Distribution.Client.FetchUtils UnitTests.Distribution.Client.Get - UnitTests.Distribution.Client.Glob UnitTests.Distribution.Client.HttpUtils UnitTests.Distribution.Client.GZipUtils UnitTests.Distribution.Client.IndexUtils @@ -477,7 +475,6 @@ test-suite long-tests UnitTests.Distribution.Client.ArbitraryInstances UnitTests.Distribution.Client.Described UnitTests.Distribution.Client.DescribedInstances - UnitTests.Distribution.Client.FileMonitor UnitTests.Distribution.Client.VCS UnitTests.Distribution.Solver.Modular.DSL UnitTests.Distribution.Solver.Modular.QuickCheck @@ -498,7 +495,6 @@ test-suite long-tests , tagged , tasty >= 1.2.3 && <1.6 , tasty-expected-failure - , tasty-hunit >= 0.10 , tasty-quickcheck <0.12 , QuickCheck >= 2.14 && <2.19 , pretty-show >= 1.6.15 diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs index 2a6ae7ef79b..3d675e96c6d 100644 --- a/cabal-install/src/Distribution/Client/FileMonitor.hs +++ b/cabal-install/src/Distribution/Client/FileMonitor.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-orphans #-} - -- | An abstraction to help with re-running actions when files or other -- input values they depend on have changed. module Distribution.Client.FileMonitor @@ -23,1315 +20,5 @@ module Distribution.Client.FileMonitor , MonitorStateGlob ) where -import Distribution.Client.Compat.Prelude -import qualified Distribution.Compat.Binary as Binary -import Prelude () - -import Data.Binary.Get (runGetOrFail) -import qualified Data.ByteString.Lazy as BS -import qualified Data.Map.Strict as Map - -import Control.Exception -import Control.Monad -import Control.Monad.Except - ( ExceptT - , runExceptT - , throwError - , withExceptT - ) -import Control.Monad.State (StateT, mapStateT) -import qualified Control.Monad.State as State -import Control.Monad.Trans (MonadIO, liftIO) - -import Distribution.Client.Glob -import Distribution.Client.HashValue -import Distribution.Client.Utils (MergeResult (..), mergeBy) -import Distribution.Compat.Time +import Distribution.Simple.FileMonitor import Distribution.Simple.FileMonitor.Types -import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) -import Distribution.Utils.Structured (Tag (..), structuredEncode) - -import System.Directory -import System.FilePath -import System.IO - ------------------------------------------------------------------------------- --- Implementation types, files status --- - --- | The state necessary to determine whether a set of monitored --- files has changed. It consists of two parts: a set of specific --- files to be monitored (index by their path), and a list of --- globs, which monitor may files at once. -data MonitorStateFileSet - = MonitorStateFileSet - ![MonitorStateFile] - ![MonitorStateGlob] - -- Morally this is not actually a set but a bag (represented by lists). - -- There is no principled reason to use a bag here rather than a set, but - -- there is also no particular gain either. That said, we do preserve the - -- order of the lists just to reduce confusion (and have predictable I/O - -- patterns). - deriving (Show, Generic) - -instance Binary MonitorStateFileSet -instance Structured MonitorStateFileSet - --- | The state necessary to determine whether a monitored file has changed. --- --- This covers all the cases of 'MonitorFilePath' except for globs which is --- covered separately by 'MonitorStateGlob'. --- --- The @Maybe ModTime@ is to cover the case where we already consider the --- file to have changed, either because it had already changed by the time we --- did the snapshot (i.e. too new, changed since start of update process) or it --- no longer exists at all. -data MonitorStateFile - = MonitorStateFile - !MonitorKindFile - !MonitorKindDir - !FilePath - !MonitorStateFileStatus - deriving (Show, Generic) - -data MonitorStateFileStatus - = MonitorStateFileExists - | -- | cached file mtime - MonitorStateFileModTime !ModTime - | -- | cached mtime and content hash - MonitorStateFileHashed !ModTime !HashValue - | MonitorStateDirExists - | -- | cached dir mtime - MonitorStateDirModTime !ModTime - | MonitorStateNonExistent - | MonitorStateAlreadyChanged - deriving (Show, Generic) - -instance Binary MonitorStateFile -instance Binary MonitorStateFileStatus -instance Structured MonitorStateFile -instance Structured MonitorStateFileStatus - --- | The state necessary to determine whether the files matched by a globbing --- match have changed. -data MonitorStateGlob - = MonitorStateGlob - !MonitorKindFile - !MonitorKindDir - !FilePathRoot - !MonitorStateGlobRel - deriving (Show, Generic) - --- | Monitoring state for a 'Glob'. Constructors mirror those of Glob -data MonitorStateGlobRel - = -- | Monitoring state for 'GlobDir' - MonitorStateGlobDirs - !GlobPieces - -- ^ Glob matching on subdirectory in current directory - !Glob - -- ^ Glob tail matching on anything below subdirectory - !ModTime - -- ^ Cached directory modification time - ![(FilePath, MonitorStateGlobRel)] - -- ^ Per-file monitoring state. - -- Invariant: sorted - | -- | Monitoring state for 'GlobFile' - MonitorStateGlobFiles - !GlobPieces - -- ^ Glob matching on file in current directory - !ModTime - -- ^ Cached directory modification time - ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted - - -- ^ Per-file monitoring state. - -- Invariant: sorted - | -- | Monitoring state for 'GlobDirRecursive' - MonitorStateGlobRecursive - !GlobPieces - -- ^ Glob matching on file in current directory subtree (current - -- directory and all of its descendants). - !ModTime - -- ^ Cached directory modification time - ![(FilePath, MonitorStateFileStatus)] - -- ^ Per-file monitoring state for files immediately below the current - -- directory. - -- Invariant: sorted - ![(FilePath, MonitorStateGlobRel)] - -- ^ Monitoring state for immediate subdirectories. Transient - -- subdirectories are represented recursively within these. - -- Invariant: sorted - | -- | Monitoring state for 'GlobDirTrailing' - -- (Trivial, because there is no data in 'GlobDirTrailing') - MonitorStateGlobDirTrailing - deriving (Show, Generic) - -instance Binary MonitorStateGlob -instance Binary MonitorStateGlobRel - -instance Structured MonitorStateGlob -instance Structured MonitorStateGlobRel - --- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by --- inspecting the state of the file system, and we can go in the reverse --- direction by just forgetting the extra info. -reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath] -reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) = - map getSinglePath singlePaths ++ map getGlobPath globPaths - where - getSinglePath :: MonitorStateFile -> MonitorFilePath - getSinglePath (MonitorStateFile kindfile kinddir filepath _) = - MonitorFile kindfile kinddir filepath - - getGlobPath :: MonitorStateGlob -> MonitorFilePath - getGlobPath (MonitorStateGlob kindfile kinddir root gstate) = - MonitorFileGlob kindfile kinddir $ - RootedGlob root $ - monitorStateGlobRelGlob gstate - --- | Reconstruct a 'Glob' from a 'MonitorStateGlobRel'. This simply erases the --- additional information in 'MonitorStateGlobRel' added via --- 'buildMonitorStateGlobRel'. -monitorStateGlobRelGlob :: MonitorStateGlobRel -> Glob -monitorStateGlobRelGlob gstate = - case gstate of - MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs - MonitorStateGlobFiles glob _ _ -> GlobFile glob - MonitorStateGlobRecursive glob _ _ _ -> GlobDirRecursive glob - MonitorStateGlobDirTrailing -> GlobDirTrailing - ------------------------------------------------------------------------------- --- Checking the status of monitored files --- - --- | A monitor for detecting changes to a set of files. It can be used to --- efficiently test if any of a set of files (specified individually or by --- glob patterns) has changed since some snapshot. In addition, it also checks --- for changes in a value (of type @a@), and when there are no changes in --- either it returns a saved value (of type @b@). --- --- The main use case looks like this: suppose we have some expensive action --- that depends on certain pure inputs and reads some set of files, and --- produces some pure result. We want to avoid re-running this action when it --- would produce the same result. So we need to monitor the files the action --- looked at, the other pure input values, and we need to cache the result. --- Then at some later point, if the input value didn't change, and none of the --- files changed, then we can re-use the cached result rather than re-running --- the action. --- --- This can be achieved using a 'FileMonitor'. Each 'FileMonitor' instance --- saves state in a disk file, so the file for that has to be specified, --- making sure it is unique. The pattern is to use 'checkFileMonitorChanged' --- to see if there's been any change. If there is, re-run the action, keeping --- track of the files, then use 'updateFileMonitor' to record the current --- set of files to monitor, the current input value for the action, and the --- result of the action. --- --- The typical occurrence of this pattern is captured by 'rerunIfChanged' --- and the 'Rebuild' monad. More complicated cases may need to use --- 'checkFileMonitorChanged' and 'updateFileMonitor' directly. -data FileMonitor a b = FileMonitor - { fileMonitorCacheFile :: FilePath - -- ^ The file where this 'FileMonitor' should store its state. - , fileMonitorKeyValid :: a -> a -> Bool - -- ^ Compares a new cache key with old one to determine if a - -- corresponding cached value is still valid. - -- - -- Typically this is just an equality test, but in some - -- circumstances it can make sense to do things like subset - -- comparisons. - -- - -- The first arg is the new value, the second is the old cached value. - , fileMonitorCheckIfOnlyValueChanged :: Bool - -- ^ When this mode is enabled, if 'checkFileMonitorChanged' returns - -- 'MonitoredValueChanged' then we have the guarantee that no files - -- changed, that the value change was the only change. In the default - -- mode no such guarantee is provided which is slightly faster. - } - --- | Define a new file monitor. --- --- It's best practice to define file monitor values once, and then use the --- same value for 'checkFileMonitorChanged' and 'updateFileMonitor' as this --- ensures you get the same types @a@ and @b@ for reading and writing. --- --- The path of the file monitor itself must be unique because it keeps state --- on disk and these would clash. -newFileMonitor - :: Eq a - => FilePath - -- ^ The file to cache the state of the - -- file monitor. Must be unique. - -> FileMonitor a b -newFileMonitor path = FileMonitor path (==) False - --- | The result of 'checkFileMonitorChanged': either the monitored files or --- value changed (and it tells us which it was) or nothing changed and we get --- the cached result. -data MonitorChanged a b - = -- | The monitored files and value did not change. The cached result is - -- @b@. - -- - -- The set of monitored files is also returned. This is useful - -- for composing or nesting 'FileMonitor's. - MonitorUnchanged b [MonitorFilePath] - | -- | The monitor found that something changed. The reason is given. - MonitorChanged (MonitorChangedReason a) - deriving (Show) - --- | What kind of change 'checkFileMonitorChanged' detected. -data MonitorChangedReason a - = -- | One of the files changed (existence, file type, mtime or file - -- content, depending on the 'MonitorFilePath' in question) - MonitoredFileChanged FilePath - | -- | The pure input value changed. - -- - -- The previous cached key value is also returned. This is sometimes - -- useful when using a 'fileMonitorKeyValid' function that is not simply - -- '(==)', when invalidation can be partial. In such cases it can make - -- sense to 'updateFileMonitor' with a key value that's a combination of - -- the new and old (e.g. set union). - MonitoredValueChanged a - | -- | There was no saved monitor state, cached value etc. Ie the file - -- for the 'FileMonitor' does not exist. - MonitorFirstRun - | -- | There was existing state, but we could not read it. This typically - -- happens when the code has changed compared to an existing 'FileMonitor' - -- cache file and type of the input value or cached value has changed such - -- that we cannot decode the values. This is completely benign as we can - -- treat is just as if there were no cache file and re-run. - MonitorCorruptCache - deriving (Eq, Show, Functor) - --- | Test if the input value or files monitored by the 'FileMonitor' have --- changed. If not, return the cached value. --- --- See 'FileMonitor' for a full explanation. -checkFileMonitorChanged - :: forall a b - . (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -- ^ cache file path - -> FilePath - -- ^ root directory - -> a - -- ^ guard or key value - -> IO (MonitorChanged a b) - -- ^ did the key or any paths change? -checkFileMonitorChanged - monitor@FileMonitor - { fileMonitorKeyValid - , fileMonitorCheckIfOnlyValueChanged - } - root - currentKey = - -- Consider it a change if the cache file does not exist, - -- or we cannot decode it. Sadly ErrorCall can still happen, despite - -- using decodeFileOrFail, e.g. Data.Char.chr errors - - handleDoesNotExist (MonitorChanged MonitorFirstRun) $ - handleErrorCall (MonitorChanged MonitorCorruptCache) $ - withCacheFile monitor $ - either - (\_ -> return (MonitorChanged MonitorCorruptCache)) - checkStatusCache - where - checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b) - checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do - change <- checkForChanges - case change of - Just reason -> return (MonitorChanged reason) - Nothing -> case cachedResult of - Left _ -> pure (MonitorChanged MonitorCorruptCache) - Right cr -> return (MonitorUnchanged cr monitorFiles) - where - monitorFiles = reconstructMonitorFilePaths cachedFileStatus - where - -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that - -- if we return MonitoredValueChanged that only the value changed. - -- We do that by checking for file changes first. Otherwise it makes - -- more sense to do the cheaper test first. - checkForChanges :: IO (Maybe (MonitorChangedReason a)) - checkForChanges - | fileMonitorCheckIfOnlyValueChanged = - checkFileChange cachedFileStatus cachedKey cachedResult - `mplusMaybeT` checkValueChange cachedKey - | otherwise = - checkValueChange cachedKey - `mplusMaybeT` checkFileChange cachedFileStatus cachedKey cachedResult - - mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1) - mplusMaybeT ma mb = do - mx <- ma - case mx of - Nothing -> mb - Just x -> return (Just x) - - -- Check if the guard value has changed - checkValueChange :: a -> IO (Maybe (MonitorChangedReason a)) - checkValueChange cachedKey - | not (fileMonitorKeyValid currentKey cachedKey) = - return (Just (MonitoredValueChanged cachedKey)) - | otherwise = - return Nothing - - -- Check if any file has changed - checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a)) - checkFileChange cachedFileStatus cachedKey cachedResult = do - res <- probeFileSystem root cachedFileStatus - case res of - -- Some monitored file has changed - Left changedPath -> - return (Just (MonitoredFileChanged (normalise changedPath))) - -- No monitored file has changed - Right (cachedFileStatus', cacheStatus) -> do - -- But we might still want to update the cache - whenCacheChanged cacheStatus $ - case cachedResult of - Left _ -> pure () - Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr - - return Nothing - --- | Lazily decode a triple, parsing the first two fields strictly and --- returning a lazy value containing either the last one or an error. --- This is helpful for cabal cache files where the first two components --- contain header data that lets one test if the cache is still valid, --- and the last (potentially large) component is the cached value itself. --- This way we can test for cache validity without needing to pay the --- cost of the decode of stale cache data. This lives here rather than --- Distribution.Utils.Structured because it depends on a newer version of --- binary than supported in the Cabal library proper. -structuredDecodeTriple - :: forall a b c - . (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c) - => BS.ByteString - -> Either String (a, b, Either String c) -structuredDecodeTriple lbs = - let partialDecode = - (`runGetOrFail` lbs) $ do - (_ :: Tag (a, b, c)) <- Binary.get - (a :: a) <- Binary.get - (b :: b) <- Binary.get - pure (a, b) - cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) - cleanEither (Right (_, _, v)) = Right v - in case partialDecode of - Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg) - Right (lbs', _, (x, y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs') - --- | Helper for reading the cache file. --- --- This determines the type and format of the binary cache file. -withCacheFile - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r) - -> IO r -withCacheFile (FileMonitor{fileMonitorCacheFile}) k = - withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do - contents <- structuredDecodeTriple <$> BS.hGetContents hnd - k contents - --- | Helper for writing the cache file. --- --- This determines the type and format of the binary cache file. -rewriteCacheFile - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> MonitorStateFileSet - -> a - -> b - -> IO () -rewriteCacheFile FileMonitor{fileMonitorCacheFile} fileset key result = - writeFileAtomic fileMonitorCacheFile $ - structuredEncode (fileset, key, result) - --- | Probe the file system to see if any of the monitored files have changed. --- --- It returns Nothing if any file changed, or returns a possibly updated --- file 'MonitorStateFileSet' plus an indicator of whether it actually changed. --- --- We may need to update the cache since there may be changes in the filesystem --- state which don't change any of our affected files. --- --- Consider the glob @{proj1,proj2}\/\*.cabal@. Say we first run and find a --- @proj1@ directory containing @proj1.cabal@ yet no @proj2@. If we later run --- and find @proj2@ was created, yet contains no files matching @*.cabal@ then --- we want to update the cache despite no changes in our relevant file set. --- Specifically, we should add an mtime for this directory so we can avoid --- re-traversing the directory in future runs. -probeFileSystem - :: FilePath - -> MonitorStateFileSet - -> IO (Either FilePath (MonitorStateFileSet, CacheChanged)) -probeFileSystem root (MonitorStateFileSet singlePaths globPaths) = - runChangedM $ do - sequence_ - [ probeMonitorStateFileStatus root file status - | MonitorStateFile _ _ file status <- singlePaths - ] - -- The glob monitors can require state changes - globPaths' <- - sequence - [ probeMonitorStateGlob root globPath - | globPath <- globPaths - ] - return (MonitorStateFileSet singlePaths globPaths') - ------------------------------------------------ --- Monad for checking for file system changes --- --- We need to be able to bail out if we detect a change (using ExceptT), --- but if there's no change we need to be able to rebuild the monitor --- state. And we want to optimise that rebuilding by keeping track if --- anything actually changed (using StateT), so that in the typical case --- we can avoid rewriting the state file. - -newtype ChangedM a = ChangedM (StateT CacheChanged (ExceptT FilePath IO) a) - deriving (Functor, Applicative, Monad, MonadIO) - -runChangedM :: ChangedM a -> IO (Either FilePath (a, CacheChanged)) -runChangedM (ChangedM action) = - runExceptT $ State.runStateT action CacheUnchanged - -somethingChanged :: FilePath -> ChangedM a -somethingChanged path = ChangedM $ throwError path - -cacheChanged :: ChangedM () -cacheChanged = ChangedM $ State.put CacheChanged - -mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a -mapChangedFile adjust (ChangedM a) = - ChangedM (mapStateT (withExceptT adjust) a) - -data CacheChanged = CacheChanged | CacheUnchanged - -whenCacheChanged :: Monad m => CacheChanged -> m () -> m () -whenCacheChanged CacheChanged action = action -whenCacheChanged CacheUnchanged _ = return () - ----------------------- - --- | Probe the file system to see if a single monitored file has changed. -probeMonitorStateFileStatus - :: FilePath - -> FilePath - -> MonitorStateFileStatus - -> ChangedM () -probeMonitorStateFileStatus root file status = - case status of - MonitorStateFileExists -> - probeFileExistence root file - MonitorStateFileModTime mtime -> - probeFileModificationTime root file mtime - MonitorStateFileHashed mtime hash -> - probeFileModificationTimeAndHash root file mtime hash - MonitorStateDirExists -> - probeDirExistence root file - MonitorStateDirModTime mtime -> - probeFileModificationTime root file mtime - MonitorStateNonExistent -> - probeFileNonExistence root file - MonitorStateAlreadyChanged -> - somethingChanged file - --- | Probe the file system to see if a monitored file glob has changed. -probeMonitorStateGlob - :: FilePath - -- ^ root path - -> MonitorStateGlob - -> ChangedM MonitorStateGlob -probeMonitorStateGlob - relroot - (MonitorStateGlob kindfile kinddir globroot glob) = do - root <- liftIO $ getFilePathRootDirectory globroot relroot - case globroot of - FilePathRelative -> - MonitorStateGlob kindfile kinddir globroot - <$> probeMonitorStateGlobRel kindfile kinddir root "." glob - -- for absolute cases, make the changed file we report absolute too - _ -> - mapChangedFile (root ) $ - MonitorStateGlob kindfile kinddir globroot - <$> probeMonitorStateGlobRel kindfile kinddir root "" glob - -probeMonitorStateFiles - :: FilePath - -- ^ root path - -> FilePath - -- ^ path of the directory we are - -- looking in relative to @root@ - -> GlobPieces - -- ^ file glob to filter monitored files - -> ModTime - -- ^ cached directory modification time - -> [(FilePath, MonitorStateFileStatus)] - -> ChangedM (ModTime, [(FilePath, MonitorStateFileStatus)]) -probeMonitorStateFiles - root - dirName - glob - mtime - children = do - change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime - mtime' <- case change of - Nothing -> return mtime - Just mtime' -> do - -- directory modification time changed: - -- a matching file may have been added or deleted - matches <- liftIO $ filter (matchGlobPieces glob) <$> listDirectory (root dirName) - - traverse_ probeMergeResult $ - mergeBy - (\(path1, _) path2 -> compare path1 path2) - children - (sort matches) - return mtime' - - -- Check that none of the children have changed - for_ children $ \(file, status) -> - probeMonitorStateFileStatus root (dirName file) status - - return (mtime', children) - where - -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use - -- the new mtime' if any. - - probeMergeResult - :: MergeResult (FilePath, MonitorStateFileStatus) FilePath - -> ChangedM () - probeMergeResult mr = case mr of - InBoth _ _ -> return () - -- this is just to be able to accurately report which file changed: - OnlyInLeft (path, _) -> somethingChanged (dirName path) - OnlyInRight path -> somethingChanged (dirName path) - -probeMonitorStateDirs - :: MonitorKindFile - -> MonitorKindDir - -> FilePath - -- ^ root path - -> FilePath - -- ^ path of the directory we are - -- looking in relative to @root@ - -> Maybe GlobPieces - -- ^ optional glob to filter filenames by - -> Glob - -- ^ glob to filter subdirectories by - -> ModTime - -- ^ cached directory modification time - -> [(FilePath, MonitorStateGlobRel)] - -> ChangedM (ModTime, [(FilePath, MonitorStateGlobRel)]) -probeMonitorStateDirs - kindfile - kinddir - root - dirName - globMaybe - globPath - mtime - children = do - change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime - case change of - Nothing -> do - children' <- - sequence - [ do - fstate' <- - probeMonitorStateGlobRel - kindfile - kinddir - root - (dirName fname) - fstate - return (fname, fstate') - | (fname, fstate) <- children - ] - return $! (mtime, children') - Just mtime' -> do - -- directory modification time changed: - -- a matching subdir may have been added or deleted - matches <- - filterM - ( \entry -> - let subdir = root dirName entry - in liftIO $ doesDirectoryExist subdir - ) - . maybe id (filter . matchGlobPieces) globMaybe - =<< liftIO (listDirectory (root dirName)) - - children' <- - traverse probeMergeResult $ - mergeBy - (\(path1, _) path2 -> compare path1 path2) - children - (sort matches) - return $! (mtime', children') - where - -- Note that just because the directory has changed, we don't force - -- a cache rewrite with 'cacheChanged' since that has some cost, and - -- all we're saving is scanning the directory. But we do rebuild the - -- cache with the new mtime', so that if the cache is rewritten for - -- some other reason, we'll take advantage of that. - - probeMergeResult - :: MergeResult (FilePath, MonitorStateGlobRel) FilePath - -> ChangedM (FilePath, MonitorStateGlobRel) - - -- Only in cached (directory deleted) - probeMergeResult (OnlyInLeft (path, fstate)) = do - case allMatchingFiles (dirName path) fstate of - [] -> return (path, fstate) - -- Strictly speaking we should be returning 'CacheChanged' above - -- as we should prune the now-missing 'MonitorStateGlobRel'. However - -- we currently just leave these now-redundant entries in the - -- cache as they cost no IO and keeping them allows us to avoid - -- rewriting the cache. - (file : _) -> somethingChanged file - - -- Only in current filesystem state (directory added) - probeMergeResult (OnlyInRight path) = do - fstate <- - liftIO $ - buildMonitorStateGlobRel - Nothing - Map.empty - kindfile - kinddir - root - (dirName path) - globPath - case allMatchingFiles (dirName path) fstate of - (file : _) -> somethingChanged file - -- This is the only case where we use 'cacheChanged' because we can - -- have a whole new dir subtree (of unbounded size and cost), so we - -- need to save the state of that new subtree in the cache. - [] -> cacheChanged >> return (path, fstate) - - -- Found in path - probeMergeResult (InBoth (path, fstate) _) = do - fstate' <- - probeMonitorStateGlobRel - kindfile - kinddir - root - (dirName path) - fstate - return (path, fstate') - - allMatchingFilesFromGlobFiles :: FilePath -> [(FilePath, a)] -> [FilePath] - allMatchingFilesFromGlobFiles dir entries = - [dir fname | (fname, _) <- entries] - - allMatchingFilesFromGlobDirs :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [FilePath] - allMatchingFilesFromGlobDirs dir entries = - [ res - | (subdir, fstate) <- entries - , res <- allMatchingFiles (dir subdir) fstate - ] - - -- \| Does a 'MonitorStateGlob' have any relevant files within it? - allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath] - allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) = - allMatchingFilesFromGlobFiles dir entries - allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) = - allMatchingFilesFromGlobDirs dir entries - allMatchingFiles dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) = - allMatchingFilesFromGlobFiles dir fileEntries - ++ allMatchingFilesFromGlobDirs dir dirEntries - allMatchingFiles dir MonitorStateGlobDirTrailing = - [dir] - -probeMonitorStateGlobRel - :: MonitorKindFile - -> MonitorKindDir - -> FilePath - -- ^ root path - -> FilePath - -- ^ path of the directory we are - -- looking in relative to @root@ - -> MonitorStateGlobRel - -> ChangedM MonitorStateGlobRel -probeMonitorStateGlobRel - kindfile - kinddir - root - dirName - (MonitorStateGlobDirs glob globPath mtime children) = do - (mtime', children') <- - probeMonitorStateDirs - kindfile - kinddir - root - dirName - (Just glob) - globPath - mtime - children - return $! MonitorStateGlobDirs glob globPath mtime' children' -probeMonitorStateGlobRel - _ - _ - root - dirName - (MonitorStateGlobFiles glob mtime children) = do - change <- liftIO $ checkDirectoryModificationTime (root dirName) mtime - mtime' <- case change of - Nothing -> return mtime - Just mtime' -> do - -- directory modification time changed: - -- a matching file may have been added or deleted - matches <- liftIO $ filter (matchGlobPieces glob) <$> listDirectory (root dirName) - - traverse_ probeMergeResult $ - mergeBy - (\(path1, _) path2 -> compare path1 path2) - children - (sort matches) - return mtime' - - -- Check that none of the children have changed - for_ children $ \(file, status) -> - probeMonitorStateFileStatus root (dirName file) status - - return (MonitorStateGlobFiles glob mtime' children) - where - -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use - -- the new mtime' if any. - - probeMergeResult - :: MergeResult (FilePath, MonitorStateFileStatus) FilePath - -> ChangedM () - probeMergeResult mr = case mr of - InBoth _ _ -> return () - -- this is just to be able to accurately report which file changed: - OnlyInLeft (path, _) -> somethingChanged (dirName path) - OnlyInRight path -> somethingChanged (dirName path) -probeMonitorStateGlobRel - kindfile - kinddir - root - dirName - (MonitorStateGlobRecursive glob mtime fileChildren dirChildren) = do - -- For recursive globs, we check the file children first, then recurse - -- into subdirectories, applying the same logic as 'MonitorStateGlobFiles' - -- and 'MonitorStateGlobDirs', respectively. - (_, fileChildren') <- - probeMonitorStateFiles - root - dirName - glob - mtime - fileChildren - (mtime', dirChildren') <- - probeMonitorStateDirs - kindfile - kinddir - root - dirName - Nothing - (GlobDirRecursive glob) - mtime - dirChildren - return $! MonitorStateGlobRecursive glob mtime' fileChildren' dirChildren' -probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing = - return MonitorStateGlobDirTrailing - ------------------------------------------------------------------------------- - --- | Update the input value and the set of files monitored by the --- 'FileMonitor', plus the cached value that may be returned in future. --- --- This takes a snapshot of the state of the monitored files right now, so --- 'checkFileMonitorChanged' will look for file system changes relative to --- this snapshot. --- --- This is typically done once the action has been completed successfully and --- we have the action's result and we know what files it looked at. See --- 'FileMonitor' for a full explanation. --- --- If we do take the snapshot after the action has completed then we have a --- problem. The problem is that files might have changed /while/ the action was --- running but /after/ the action read them. If we take the snapshot after the --- action completes then we will miss these changes. The solution is to record --- a timestamp before beginning execution of the action and then we make the --- conservative assumption that any file that has changed since then has --- already changed, ie the file monitor state for these files will be such that --- 'checkFileMonitorChanged' will report that they have changed. --- --- So if you do use 'updateFileMonitor' after the action (so you can discover --- the files used rather than predicting them in advance) then use --- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively, --- if you take the snapshot in advance of the action, or you're not monitoring --- any files then you can use @Nothing@ for the timestamp parameter. -updateFileMonitor - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -- ^ cache file path - -> FilePath - -- ^ root directory - -> Maybe MonitorTimestamp - -- ^ timestamp when the update action started - -> [MonitorFilePath] - -- ^ files of interest relative to root - -> a - -- ^ the current key value - -> b - -- ^ the current result value - -> IO () -updateFileMonitor - monitor - root - startTime - monitorFiles - cachedKey - cachedResult = do - hashcache <- readCacheFileHashes monitor - msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles - rewriteCacheFile monitor msfs cachedKey cachedResult - --- | A timestamp to help with the problem of file changes during actions. --- See 'updateFileMonitor' for details. -newtype MonitorTimestamp = MonitorTimestamp ModTime - --- | Record a timestamp at the beginning of an action, and when the action --- completes call 'updateFileMonitor' passing it the timestamp. --- See 'updateFileMonitor' for details. -beginUpdateFileMonitor :: IO MonitorTimestamp -beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime - --- | Take the snapshot of the monitored files. That is, given the --- specification of the set of files we need to monitor, inspect the state --- of the file system now and collect the information we'll need later to --- determine if anything has changed. -buildMonitorStateFileSet - :: Maybe MonitorTimestamp - -- ^ optional: timestamp - -- of the start of the action - -> FileHashCache - -- ^ existing file hashes - -> FilePath - -- ^ root directory - -> [MonitorFilePath] - -- ^ patterns of interest - -- relative to root - -> IO MonitorStateFileSet -buildMonitorStateFileSet mstartTime hashcache root = - go [] [] - where - go - :: [MonitorStateFile] - -> [MonitorStateGlob] - -> [MonitorFilePath] - -> IO MonitorStateFileSet - go !singlePaths !globPaths [] = - return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths)) - go - !singlePaths - !globPaths - (MonitorFile kindfile kinddir path : monitors) = do - monitorState <- - MonitorStateFile kindfile kinddir path - <$> buildMonitorStateFile - mstartTime - hashcache - kindfile - kinddir - root - path - go (monitorState : singlePaths) globPaths monitors - go - !singlePaths - !globPaths - (MonitorFileGlob kindfile kinddir globPath : monitors) = do - monitorState <- - buildMonitorStateGlob - mstartTime - hashcache - kindfile - kinddir - root - globPath - go singlePaths (monitorState : globPaths) monitors - -buildMonitorStateFile - :: Maybe MonitorTimestamp - -- ^ start time of update - -> FileHashCache - -- ^ existing file hashes - -> MonitorKindFile - -> MonitorKindDir - -> FilePath - -- ^ the root directory - -> FilePath - -> IO MonitorStateFileStatus -buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do - let abspath = root path - isFile <- doesFileExist abspath - isDir <- doesDirectoryExist abspath - case (isFile, kindfile, isDir, kinddir) of - (_, FileNotExists, _, DirNotExists) -> - -- we don't need to care if it exists now, since we check at probe time - return MonitorStateNonExistent - (False, _, False, _) -> - return MonitorStateAlreadyChanged - (True, FileExists, _, _) -> - return MonitorStateFileExists - (True, FileModTime, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateFileModTime mtime) - (True, FileHashed, _, _) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else do - hash <- getFileHash hashcache abspath abspath mtime - return (MonitorStateFileHashed mtime hash) - (_, _, True, DirExists) -> - return MonitorStateDirExists - (_, _, True, DirModTime) -> - handleIOException MonitorStateAlreadyChanged $ do - mtime <- getModTime abspath - if changedDuringUpdate mstartTime mtime - then return MonitorStateAlreadyChanged - else return (MonitorStateDirModTime mtime) - (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged - (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged - --- | If we have a timestamp for the beginning of the update, then any file --- mtime later than this means that it changed during the update and we ought --- to consider the file as already changed. -changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool -changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime = - mtime > startTime -changedDuringUpdate _ _ = False - --- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case --- of a file glob. --- --- This gets used both by 'buildMonitorStateFileSet' when we're taking the --- file system snapshot, but also by 'probeGlobStatus' as part of checking --- the monitored (globed) files for changes when we find a whole new subtree. -buildMonitorStateGlob - :: Maybe MonitorTimestamp - -- ^ start time of update - -> FileHashCache - -- ^ existing file hashes - -> MonitorKindFile - -> MonitorKindDir - -> FilePath - -- ^ the root directory - -> RootedGlob - -- ^ the matching glob - -> IO MonitorStateGlob -buildMonitorStateGlob - mstartTime - hashcache - kindfile - kinddir - relroot - (RootedGlob globroot globPath) = do - root <- liftIO $ getFilePathRootDirectory globroot relroot - MonitorStateGlob kindfile kinddir globroot - <$> buildMonitorStateGlobRel - mstartTime - hashcache - kindfile - kinddir - root - "." - globPath - -buildMonitorStateGlobRel - :: Maybe MonitorTimestamp - -- ^ start time of update - -> FileHashCache - -- ^ existing file hashes - -> MonitorKindFile - -> MonitorKindDir - -> FilePath - -- ^ the root directory - -> FilePath - -- ^ directory we are examining - -- relative to the root - -> Glob - -- ^ the matching glob - -> IO MonitorStateGlobRel -buildMonitorStateGlobRel - mstartTime - hashcache - kindfile - kinddir - root - dir - globPath = do - let absdir = root dir - dirEntries <- listDirectory absdir - dirMTime <- getModTime absdir - case globPath of - GlobDirRecursive glob -> do - -- evaluate globPath' over the current directory - let files = filter (matchGlobPieces glob) dirEntries - filesStates <- - for (sort files) $ \file -> do - fstate <- - buildMonitorStateFile - mstartTime - hashcache - kindfile - kinddir - root - (dir file) - return (file, fstate) - -- evaluate globPath' over every subdirectory - subdirs <- - filterM (\subdir -> doesDirectoryExist (absdir subdir)) dirEntries - subdirStates <- - for (sort subdirs) $ \subdir -> do - fstate <- - buildMonitorStateGlobRel - mstartTime - hashcache - kindfile - kinddir - root - (dir subdir) - globPath - return (subdir, fstate) - - return $! MonitorStateGlobRecursive glob dirMTime filesStates subdirStates - GlobDir glob globPath' -> do - subdirs <- - filterM (\subdir -> doesDirectoryExist (absdir subdir)) $ - filter (matchGlobPieces glob) dirEntries - subdirStates <- - for (sort subdirs) $ \subdir -> do - fstate <- - buildMonitorStateGlobRel - mstartTime - hashcache - kindfile - kinddir - root - (dir subdir) - globPath' - return (subdir, fstate) - return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates - GlobFile glob -> do - let files = filter (matchGlobPieces glob) dirEntries - filesStates <- - for (sort files) $ \file -> do - fstate <- - buildMonitorStateFile - mstartTime - hashcache - kindfile - kinddir - root - (dir file) - return (file, fstate) - return $! MonitorStateGlobFiles glob dirMTime filesStates - GlobDirTrailing -> - return MonitorStateGlobDirTrailing - --- | We really want to avoid re-hashing files all the time. We already make --- the assumption that if a file mtime has not changed then we don't need to --- bother checking if the content hash has changed. We can apply the same --- assumption when updating the file monitor state. In the typical case of --- updating a file monitor the set of files is the same or largely the same so --- we can grab the previously known content hashes with their corresponding --- mtimes. -type FileHashCache = Map FilePath (ModTime, HashValue) - --- | We declare it a cache hit if the mtime of a file is the same as before. -lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe HashValue -lookupFileHashCache hashcache file mtime = do - (mtime', hash) <- Map.lookup file hashcache - guard (mtime' == mtime) - return hash - --- | Either get it from the cache or go read the file -getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO HashValue -getFileHash hashcache relfile absfile mtime = - case lookupFileHashCache hashcache relfile mtime of - Just hash -> return hash - Nothing -> readFileHashValue absfile - --- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While --- in principle we could preserve the structure of the previous state, given --- that the set of files to monitor can change then it's simpler just to throw --- away the structure and use a finite map. -readCacheFileHashes - :: (Binary a, Structured a, Binary b, Structured b) - => FileMonitor a b - -> IO FileHashCache -readCacheFileHashes monitor = - handleDoesNotExist Map.empty $ - handleErrorCall Map.empty $ - withCacheFile monitor $ \case - Left _ -> return Map.empty - Right (msfs, _, _) -> return (mkFileHashCache msfs) - where - mkFileHashCache :: MonitorStateFileSet -> FileHashCache - mkFileHashCache (MonitorStateFileSet singlePaths globPaths) = - collectAllFileHashes singlePaths - `Map.union` collectAllGlobHashes globPaths - - collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, HashValue) - collectAllFileHashes singlePaths = - Map.fromList - [ (fpath, (mtime, hash)) - | MonitorStateFile - _ - _ - fpath - (MonitorStateFileHashed mtime hash) <- - singlePaths - ] - - collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, HashValue) - collectAllGlobHashes globPaths = - Map.fromList - [ (fpath, (mtime, hash)) - | MonitorStateGlob _ _ _ gstate <- globPaths - , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate - ] - - collectDirHashes :: FilePath -> [(FilePath, MonitorStateGlobRel)] -> [(FilePath, (ModTime, HashValue))] - collectDirHashes dir entries = - [ res - | (subdir, fstate) <- entries - , res <- collectGlobHashes (dir subdir) fstate - ] - - collectFileHashes :: FilePath -> [(FilePath, MonitorStateFileStatus)] -> [(FilePath, (ModTime, HashValue))] - collectFileHashes dir entries = - [ (dir fname, (mtime, hash)) - | (fname, MonitorStateFileHashed mtime hash) <- entries - ] - - collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, HashValue))] - collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) = - collectDirHashes dir entries - collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) = - collectFileHashes dir entries - collectGlobHashes dir (MonitorStateGlobRecursive _ _ fileEntries dirEntries) = - collectFileHashes dir fileEntries - ++ collectDirHashes dir dirEntries - collectGlobHashes _dir MonitorStateGlobDirTrailing = - [] - ------------------------------------------------------------------------------- --- Utils --- - --- | Within the @root@ directory, check if @file@ has its 'ModTime' is --- the same as @mtime@, short-circuiting if it is different. -probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM () -probeFileModificationTime root file mtime = do - unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime - unless unchanged (somethingChanged file) - --- | Within the @root@ directory, check if @file@ has its 'ModTime' and --- 'HashValue' is the same as @mtime@ and @hash@, short-circuiting if it is --- different. -probeFileModificationTimeAndHash - :: FilePath - -> FilePath - -> ModTime - -> HashValue - -> ChangedM () -probeFileModificationTimeAndHash root file mtime hash = do - unchanged <- - liftIO $ - checkFileModificationTimeAndHashUnchanged root file mtime hash - unless unchanged (somethingChanged file) - --- | Within the @root@ directory, check if @file@ still exists as a file. --- If it *does not* exist, short-circuit. -probeFileExistence :: FilePath -> FilePath -> ChangedM () -probeFileExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - unless existsFile (somethingChanged file) - --- | Within the @root@ directory, check if @dir@ still exists. --- If it *does not* exist, short-circuit. -probeDirExistence :: FilePath -> FilePath -> ChangedM () -probeDirExistence root dir = do - existsDir <- liftIO $ doesDirectoryExist (root dir) - unless existsDir (somethingChanged dir) - --- | Within the @root@ directory, check if @file@ still does not exist. --- If it *does* exist, short-circuit. -probeFileNonExistence :: FilePath -> FilePath -> ChangedM () -probeFileNonExistence root file = do - existsFile <- liftIO $ doesFileExist (root file) - existsDir <- liftIO $ doesDirectoryExist (root file) - when (existsFile || existsDir) (somethingChanged file) - --- | Returns @True@ if, inside the @root@ directory, @file@ has the same --- 'ModTime' as @mtime@. -checkModificationTimeUnchanged - :: FilePath - -> FilePath - -> ModTime - -> IO Bool -checkModificationTimeUnchanged root file mtime = - handleIOException False $ do - mtime' <- getModTime (root file) - return (mtime == mtime') - --- | Returns @True@ if, inside the @root@ directory, @file@ has the --- same 'ModTime' and 'HashValue' as @mtime and @chash@. -checkFileModificationTimeAndHashUnchanged - :: FilePath - -> FilePath - -> ModTime - -> HashValue - -> IO Bool -checkFileModificationTimeAndHashUnchanged root file mtime chash = - handleIOException False $ do - mtime' <- getModTime (root file) - if mtime == mtime' - then return True - else do - chash' <- readFileHashValue (root file) - return (chash == chash') - --- | Given a directory @dir@, return @Nothing@ if its 'ModTime' --- is the same as @mtime@, and the new 'ModTime' if it is not. -checkDirectoryModificationTime :: FilePath -> ModTime -> IO (Maybe ModTime) -checkDirectoryModificationTime dir mtime = - handleIOException Nothing $ do - mtime' <- getModTime dir - if mtime == mtime' - then return Nothing - else return (Just mtime') - --- | Run an IO computation, returning the first argument @e@ if there is an 'error' --- call. ('ErrorCall') -handleErrorCall :: a -> IO a -> IO a -handleErrorCall e = handle handler - where - handler (ErrorCall _) = return e - --- | Run an IO computation, returning @e@ if there is any 'IOException'. --- --- This policy is OK in the file monitor code because it just causes the --- monitor to report that something changed, and then code reacting to that --- will normally encounter the same IO exception when it re-runs the action --- that uses the file. -handleIOException :: a -> IO a -> IO a -handleIOException e = - handle (anyIOException e) - where - anyIOException :: a -> IOException -> IO a - anyIOException x _ = return x - ------------------------------------------------------------------------------- --- Instances --- diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs index c94b91196fa..11f090314d5 100644 --- a/cabal-install/src/Distribution/Client/Glob.hs +++ b/cabal-install/src/Distribution/Client/Glob.hs @@ -24,7 +24,6 @@ import Distribution.Simple.Glob.Internal , GlobPieces ) -import System.Directory import System.FilePath -------------------------------------------------------------------------------- @@ -53,19 +52,6 @@ isTrivialRootedGlob (RootedGlob root pathglob) = ) go _ _ = Nothing --- | Get the 'FilePath' corresponding to a 'FilePathRoot'. --- --- The 'FilePath' argument is required to supply the path for the --- 'FilePathRelative' case. -getFilePathRootDirectory - :: FilePathRoot - -> FilePath - -- ^ root for relative paths - -> IO FilePath -getFilePathRootDirectory FilePathRelative root = return root -getFilePathRootDirectory (FilePathRoot root) _ = return root -getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory - ------------------------------------------------------------------------------ -- Matching -- diff --git a/cabal-install/src/Distribution/Client/HashValue.hs b/cabal-install/src/Distribution/Client/HashValue.hs index a3a67c9ff29..c3da651445e 100644 --- a/cabal-install/src/Distribution/Client/HashValue.hs +++ b/cabal-install/src/Distribution/Client/HashValue.hs @@ -1,23 +1,23 @@ module Distribution.Client.HashValue ( HashValue , hashValue - , truncateHash - , showHashValue - , readFileHashValue , hashFromTUF + , rawHashValue + , readFileHashValue + , showHashValue + , truncateHash ) where -import Control.Monad ((<=<)) import Distribution.Client.Compat.Prelude import Prelude () import qualified Hackage.Security.Client as Sec +import Control.Monad ((<=<)) import qualified Crypto.Hash.SHA256 as SHA256 import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS - import System.IO (IOMode (..), withBinaryFile) ----------------------------------------------- @@ -49,13 +49,27 @@ instance Structured HashValue hashValue :: LBS.ByteString -> HashValue hashValue = HashValue . SHA256.hashlazy +-- | Convert a raw hash value, given as a bytestring, into a 'HashValue'. No +-- well-formedness guarantees are provided; the caller is responsible for +-- ensuring that the provided hash is valid. +rawHashValue :: BS.ByteString -> HashValue +rawHashValue = HashValue + showHashValue :: HashValue -> String showHashValue (HashValue digest) = BS.unpack (Base16.encode digest) -- | Hash the content of a file. Uses SHA256. readFileHashValue :: FilePath -> IO HashValue readFileHashValue tarball = - withBinaryFile tarball ReadMode (evaluate . hashValue <=< LBS.hGetContents) + withBinaryFile tarball ReadMode $ + evaluate . hashValue <=< LBS.hGetContents + +-- | Truncate a 32 byte SHA256 hash to the given number of bytes. +-- +-- For example 20 bytes render as 40 hex chars, which we use for unit-ids. +-- Or even 4 bytes for 'hashedInstalledPackageIdShort' +truncateHash :: Int -> HashValue -> HashValue +truncateHash n (HashValue h) = HashValue (BS.take n h) -- | Convert a hash from TUF metadata into a 'PackageSourceHash'. -- @@ -66,12 +80,5 @@ hashFromTUF (Sec.Hash hashstr) = -- TODO: [code cleanup] either we should get TUF to use raw bytestrings or -- perhaps we should also just use a base16 string as the internal rep. case Base16.decode (BS.pack hashstr) of - Right hash -> HashValue hash + Right hash -> rawHashValue hash Left _ -> error "hashFromTUF: cannot decode base16" - --- | Truncate a 32 byte SHA256 hash to --- --- For example 20 bytes render as 40 hex chars, which we use for unit-ids. --- Or even 4 bytes for 'hashedInstalledPackageIdShort' -truncateHash :: Int -> HashValue -> HashValue -truncateHash n (HashValue h) = HashValue (BS.take n h) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index b696417515c..5d1c1808fc1 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -138,7 +138,7 @@ import Distribution.Client.SetupWrapper import Distribution.Client.Store import Distribution.Client.Targets (UserConstraint, userToPackageConstraint) import Distribution.Client.Types -import Distribution.Client.Utils (concatMapM, duplicatesBy, incVersion) +import Distribution.Client.Utils (concatMapM, incVersion) import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.IndexUtils as IndexUtils diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index adb3e049660..e4c49eec692 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -1,4 +1,12 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} -- | An abstraction for re-running actions if values or files have changed. -- @@ -59,49 +67,48 @@ module Distribution.Client.RebuildMonad import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Simple.RebuildMonad + import Distribution.Client.FileMonitor import Distribution.Client.Glob hiding (matchFileGlob) import qualified Distribution.Client.Glob as Glob (matchFileGlob) import Distribution.Client.JobControl import Distribution.Simple.PreProcess.Types (Suffix (..)) -import Distribution.Simple.Utils (debug, ordNub) +import Distribution.Simple.Utils (ordNub) -import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) -import Control.Monad import Control.Monad.Reader as Reader -import Control.Monad.State as State -import qualified Data.Map.Strict as Map +import Control.Monad.Writer as Writer import System.Directory import System.FilePath --- | A monad layered on top of 'IO' to help with re-running actions when the --- input files and values they depend on change. The crucial operations are --- 'rerunIfChanged' and 'monitorFiles'. -newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a) +-- | A custom rebuild monad to be used for file monitoring within +-- @cabal-install@. On top of the basic 'MonadRebuild' functionality, it keeps +-- the current root path in a 'ReaderT' context. +newtype Rebuild a = Rebuild (ReaderT FilePath (WriterT [MonitorFilePath] IO) a) deriving (Functor, Applicative, Monad, MonadIO) --- | Use this within the body action of 'rerunIfChanged' to declare that the --- action depends on the given files. This can be based on what the action --- actually did. It is these files that will be checked for changes next --- time 'rerunIfChanged' is called for that 'FileMonitor'. --- --- Relative paths are interpreted as relative to an implicit root, ultimately --- passed in to 'runRebuild'. -monitorFiles :: [MonitorFilePath] -> Rebuild () -monitorFiles filespecs = Rebuild (State.modify (filespecs ++)) +deriving newtype instance MonadWriter [MonitorFilePath] Rebuild + +instance MonadRebuild Rebuild where + withRunRebuildInIO action = do + rootDir <- askRoot + let runInIO = unRebuild rootDir + (result, files) <- liftIO $ action runInIO + Writer.tell files + return result -- | Run a 'Rebuild' IO action. unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) -unRebuild rootDir (Rebuild action) = runStateT (runReaderT action rootDir) [] +unRebuild rootDir (Rebuild action) = runWriterT (runReaderT action rootDir) -- | Run a 'Rebuild' IO action. runRebuild :: FilePath -> Rebuild a -> IO a -runRebuild rootDir (Rebuild action) = evalStateT (runReaderT action rootDir) [] +runRebuild rootDir (Rebuild action) = fst <$> runWriterT (runReaderT action rootDir) -- | Run a 'Rebuild' IO action. execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] -execRebuild rootDir (Rebuild action) = execStateT (runReaderT action rootDir) [] +execRebuild rootDir (Rebuild action) = execWriterT (runReaderT action rootDir) -- | The root that relative paths are interpreted as being relative to. askRoot :: Rebuild FilePath @@ -114,6 +121,8 @@ askRoot = Rebuild Reader.ask -- -- The result is still in the 'Rebuild' monad, so these can be nested. -- +-- See also 'rerunIfChanged''. +-- -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) @@ -130,7 +139,7 @@ rerunIfChanged verbosity monitor key action = do [x] -> return x _ -> error "rerunIfChanged: impossible!" --- | Like 'rerunIfChanged' meets 'mapConcurrently': For when we want multiple actions +-- | 'rerunIfChanged' meets 'mapConcurrently': For when we want multiple actions -- that need to do be re-run-if-changed asynchronously. The function returns -- when all values have finished computing. rerunConcurrentlyIfChanged @@ -141,114 +150,11 @@ rerunConcurrentlyIfChanged -> Rebuild [b] rerunConcurrentlyIfChanged verbosity mkJobControl triples = do rootDir <- askRoot - dacts <- forM triples $ \(monitor, key, action) -> do - let monitorName = takeFileName (fileMonitorCacheFile monitor) - changed <- liftIO $ checkFileMonitorChanged monitor rootDir key - case changed of - MonitorUnchanged result files -> do - liftIO $ - debug verbosity $ - "File monitor '" - ++ monitorName - ++ "' unchanged." - monitorFiles files - return (return (result, [])) - MonitorChanged reason -> do - liftIO $ - debug verbosity $ - "File monitor '" - ++ monitorName - ++ "' changed: " - ++ showReason reason - return $ do - startTime <- beginUpdateFileMonitor - (result, files) <- unRebuild rootDir action - updateFileMonitor - monitor - rootDir - (Just startTime) - files - key - result - return (result, files) - - (results, files) <- liftIO $ - withJobControl mkJobControl $ \jobControl -> do - unzip <$> mapConcurrentWithJobs jobControl id dacts - monitorFiles (concat files) - return results - where - showReason (MonitoredFileChanged file) = "file " ++ file - showReason (MonitoredValueChanged _) = "monitor value changed" - showReason MonitorFirstRun = "first run" - showReason MonitorCorruptCache = "invalid cache file" - --- | When using 'rerunIfChanged' for each element of a list of actions, it is --- sometimes the case that each action needs to make use of some resource. e.g. --- --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- mkResource --- > ... -- use the resource --- > | ... ] --- --- For efficiency one would like to share the resource between the actions --- but the straightforward way of doing this means initialising it every time --- even when no actions need re-running. --- --- > resource <- mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > ... -- use the resource --- > | ... ] --- --- This utility allows one to get the best of both worlds: --- --- > getResource <- delayInitSharedResource mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- getResource --- > ... -- use the resource --- > | ... ] -delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) -delayInitSharedResource action = do - var <- liftIO (newMVar Nothing) - return (liftIO (getOrInitResource var)) - where - getOrInitResource :: MVar (Maybe a) -> IO a - getOrInitResource var = - modifyMVar var $ \case - Just x -> return (Just x, x) - Nothing -> do - x <- action - return (Just x, x) - --- | Much like 'delayInitSharedResource' but for a keyed set of resources. --- --- > getResource <- delayInitSharedResource mkResource --- > sequence --- > [ rerunIfChanged verbosity monitor key $ do --- > resource <- getResource key --- > ... -- use the resource --- > | ... ] -delayInitSharedResources - :: forall k v - . Ord k - => (k -> IO v) - -> Rebuild (k -> Rebuild v) -delayInitSharedResources action = do - var <- liftIO (newMVar Map.empty) - return (liftIO . getOrInitResource var) + rerunIfChanged' verbosity rootDir chainIOs triples where - getOrInitResource :: MVar (Map k v) -> k -> IO v - getOrInitResource var k = - modifyMVar var $ \m -> - case Map.lookup k m of - Just x -> return (m, x) - Nothing -> do - x <- action k - let !m' = Map.insert k x m - return (m', x) + chainIOs dacts = + withJobControl mkJobControl $ \jobControl -> + mapConcurrentWithJobs jobControl id dacts -- | Utility to match a file glob against the file system, starting from a -- given root directory. The results are all relative to the given root. @@ -261,30 +167,6 @@ matchFileGlob glob = do monitorFiles [monitorFileGlobExistence glob] liftIO $ Glob.matchFileGlob root glob -getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath] -getDirectoryContentsMonitored dir = do - exists <- monitorDirectoryStatus dir - if exists - then liftIO $ listDirectory dir - else return [] - -createDirectoryMonitored :: Bool -> FilePath -> Rebuild () -createDirectoryMonitored createParents dir = do - monitorFiles [monitorDirectoryExistence dir] - liftIO $ createDirectoryIfMissing createParents dir - --- | Monitor a directory as in 'monitorDirectory' if it currently exists or --- as 'monitorNonExistentDirectory' if it does not. -monitorDirectoryStatus :: FilePath -> Rebuild Bool -monitorDirectoryStatus dir = do - exists <- liftIO $ doesDirectoryExist dir - monitorFiles - [ if exists - then monitorDirectory dir - else monitorNonExistentDirectory dir - ] - return exists - -- | Like 'doesFileExist', but in the 'Rebuild' monad. This does -- NOT track the contents of 'FilePath'; use 'need' in that case. doesFileExistMonitored :: FilePath -> Rebuild Bool diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index 4298a823e8c..5e2df60c471 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -62,13 +62,21 @@ import Data.Bits import qualified Data.ByteString.Lazy as BS import Data.List ( elemIndex - , groupBy ) import Distribution.Client.Errors import Distribution.Compat.Environment import Distribution.Compat.Time (getModTime) import Distribution.Simple.Setup (Flag, pattern Flag, pattern NoFlag) -import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap, removeFileForcibly) +import Distribution.Simple.Utils + ( MergeResult (..) + , dieWithException + , duplicates + , duplicatesBy + , findPackageDesc + , mergeBy + , noticeNoWrap + , removeFileForcibly + ) import Distribution.Utils.Path ( CWD , FileOrDir (..) @@ -119,34 +127,6 @@ import GHC.IO.Encoding.Failure import qualified System.Directory as Dir import qualified System.IO.Error as IOError --- | Generic merging utility. For sorted input lists this is a full outer join. -mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] -mergeBy cmp = merge - where - merge :: [a] -> [b] -> [MergeResult a b] - merge [] ys = [OnlyInRight y | y <- ys] - merge xs [] = [OnlyInLeft x | x <- xs] - merge (x : xs) (y : ys) = - case x `cmp` y of - GT -> OnlyInRight y : merge (x : xs) ys - EQ -> InBoth x y : merge xs ys - LT -> OnlyInLeft x : merge xs (y : ys) - -data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b - -duplicates :: Ord a => [a] -> [NonEmpty a] -duplicates = duplicatesBy compare - -duplicatesBy :: forall a. (a -> a -> Ordering) -> [a] -> [NonEmpty a] -duplicatesBy cmp = mapMaybe moreThanOne . groupBy eq . sortBy cmp - where - eq :: a -> a -> Bool - eq a b = case cmp a b of - EQ -> True - _ -> False - moreThanOne (x : xs@(_ : _)) = Just (x :| xs) - moreThanOne _ = Nothing - -- | A variant of 'withTempFile' that only gives us the file name, and while -- it will clean up the file afterwards, it's lenient if the file is -- moved\/deleted. diff --git a/cabal-install/tests/LongTests.hs b/cabal-install/tests/LongTests.hs index 07a76b95aae..1d3ce6cff54 100644 --- a/cabal-install/tests/LongTests.hs +++ b/cabal-install/tests/LongTests.hs @@ -3,7 +3,6 @@ module Main (main) where import Test.Tasty import qualified UnitTests.Distribution.Client.Described -import qualified UnitTests.Distribution.Client.FileMonitor import qualified UnitTests.Distribution.Client.VCS import qualified UnitTests.Distribution.Solver.Modular.QuickCheck import UnitTests.Options @@ -24,7 +23,5 @@ tests = UnitTests.Distribution.Solver.Modular.QuickCheck.tests , testGroup "UnitTests.Distribution.Client.VCS" $ UnitTests.Distribution.Client.VCS.tests mtimeChange - , testGroup "UnitTests.Distribution.Client.FileMonitor" $ - UnitTests.Distribution.Client.FileMonitor.tests mtimeChange , UnitTests.Distribution.Client.Described.tests ] diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index c38f65d40c1..0a026a22a86 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -7,7 +7,6 @@ import qualified UnitTests.Distribution.Client.Configure import qualified UnitTests.Distribution.Client.FetchUtils import qualified UnitTests.Distribution.Client.GZipUtils import qualified UnitTests.Distribution.Client.Get -import qualified UnitTests.Distribution.Client.Glob import qualified UnitTests.Distribution.Client.HttpUtils import qualified UnitTests.Distribution.Client.IndexUtils import qualified UnitTests.Distribution.Client.IndexUtils.ActiveRepos @@ -45,9 +44,6 @@ main = do , testGroup "UnitTests.Distribution.Client.Get" UnitTests.Distribution.Client.Get.tests - , testGroup - "UnitTests.Distribution.Client.Glob" - UnitTests.Distribution.Client.Glob.tests , testGroup "UnitTests.Distribution.Client.HttpUtils" UnitTests.Distribution.Client.HttpUtils.tests diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 50f41e3eff1..13637e199c1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -23,8 +23,6 @@ module UnitTests.Distribution.Client.ArbitraryInstances import Distribution.Client.Compat.Prelude import Prelude () -import Data.Char (isLetter) -import Data.List ((\\)) import Data.Monoid (Last (..)) import Distribution.Simple.Setup @@ -32,7 +30,6 @@ import Distribution.Types.Flag (mkFlagAssignment) import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod) -import Distribution.Client.Glob (FilePathRoot (..), Glob (..), GlobPiece (..), RootedGlob (..)) import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) @@ -48,7 +45,6 @@ import Network.URI (URI (..), URIAuth (..), isUnreserved) import Test.QuickCheck ( Arbitrary (..) , Gen - , NonEmptyList (..) , arbitraryBoundedEnum , choose , elements @@ -336,114 +332,3 @@ instance Arbitrary InstallOutcome where instance Arbitrary Outcome where arbitrary = genericArbitrary shrink = genericShrink - -------------------------------------------------------------------------------- --- Glob -------------------------------------------------------------------------------- - -instance Arbitrary RootedGlob where - arbitrary = - (RootedGlob <$> arbitrary <*> arbitrary) - `suchThat` validFilePathGlob - - shrink (RootedGlob root pathglob) = - [ RootedGlob root' pathglob' - | (root', pathglob') <- shrink (root, pathglob) - , validFilePathGlob (RootedGlob root' pathglob') - ] - -validFilePathGlob :: RootedGlob -> Bool -validFilePathGlob (RootedGlob FilePathRelative pathglob) = - case pathglob of - GlobDirTrailing -> False - GlobDir [Literal "~"] _ -> False - GlobDir [Literal (d : ":")] _ - | isLetter d -> False - _ -> True -validFilePathGlob _ = True - -instance Arbitrary FilePathRoot where - arbitrary = - frequency - [ (3, pure FilePathRelative) - , (1, pure (FilePathRoot unixroot)) - , (1, FilePathRoot <$> windrive) - , (1, pure FilePathHomeDir) - ] - where - unixroot = "/" - windrive = do d <- choose ('A', 'Z'); return (d : ":\\") - - shrink FilePathRelative = [] - shrink (FilePathRoot _) = [FilePathRelative] - shrink FilePathHomeDir = [FilePathRelative] - -instance Arbitrary Glob where - arbitrary = sized $ \sz -> - oneof $ - take - (max 1 sz) - [ pure GlobDirTrailing - , GlobFile . getGlobPieces <$> arbitrary - , (GlobDir . getGlobPieces <$> arbitrary) - <*> resize (sz `div` 2) arbitrary - ] - - shrink GlobDirTrailing = [] - shrink (GlobFile glob) = - GlobDirTrailing - : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)] - shrink (GlobDir glob pathglob) = - pathglob - : GlobFile glob - : [ GlobDir (getGlobPieces glob') pathglob' - | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) - ] - shrink (GlobDirRecursive glob) = - GlobDirTrailing - : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)] - -newtype GlobPieces = GlobPieces {getGlobPieces :: [GlobPiece]} - deriving (Eq) - -instance Arbitrary GlobPieces where - arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary - - shrink (GlobPieces glob) = - [ GlobPieces (mergeLiterals (getNonEmpty glob')) - | glob' <- shrink (NonEmpty glob) - ] - -mergeLiterals :: [GlobPiece] -> [GlobPiece] -mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps) -mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps --- Two consecutive wildcards are semantically equivalent to a single one, but --- would syntactically produce a recursive wildcard when pretty-printed, so --- whenever we end up generating two or more consecutive wildcards, we merge --- them together to avoid this problem. -mergeLiterals (WildCard : WildCard : ps) = mergeLiterals (WildCard : ps) -mergeLiterals (p : ps) = p : mergeLiterals ps -mergeLiterals [] = [] - -instance Arbitrary GlobPiece where - arbitrary = sized $ \sz -> - frequency - [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars)) - , (1, pure WildCard) - , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary))) - ] - - shrink (Literal str) = - [ Literal str' - | str' <- shrink str - , not (null str') - , all (`elem` globLiteralChars) str' - ] - shrink WildCard = [] - shrink (Union as) = - [ Union (map getGlobPieces (getNonEmpty as')) - | as' <- shrink (NonEmpty (map GlobPieces as)) - ] - -globLiteralChars :: [Char] -globLiteralChars = ['\0' .. '\128'] \\ "*{},/\\" diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs deleted file mode 100644 index eb7a4feae0c..00000000000 --- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -module UnitTests.Distribution.Client.Glob (tests) where - -import Distribution.Client.Compat.Prelude hiding (last) -import Prelude () - -import Distribution.Client.Glob -import Distribution.Utils.Structured (structureHash) -import UnitTests.Distribution.Client.ArbitraryInstances () - -import GHC.Fingerprint (Fingerprint (..)) -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = - [ testProperty "print/parse roundtrip" prop_roundtrip_printparse - , testCase "parse examples" testParseCases - , testGroup - "Structured hashes" - [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782 - , testCase "Glob" $ structureHash (Proxy :: Proxy Glob) @?= Fingerprint 0x3a5af41e8194eaa3 0xd8e461fdfdb0e07b - , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5 - , testCase "RootedGlob" $ structureHash (Proxy :: Proxy RootedGlob) @?= Fingerprint 0x0031d198379cd1bf 0x7246ab9b6c6e0e7d - ] - ] - --- TODO: [nice to have] tests for trivial globs, tests for matching, --- tests for windows style file paths - -prop_roundtrip_printparse :: RootedGlob -> Property -prop_roundtrip_printparse pathglob = - counterexample (prettyShow pathglob) $ - eitherParsec (prettyShow pathglob) === Right pathglob - --- first run, where we don't even call updateMonitor -testParseCases :: Assertion -testParseCases = do - RootedGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/" - RootedGlob FilePathHomeDir GlobDirTrailing <- testparse "~/" - - RootedGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/" - RootedGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/" - RootedGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\" - RootedGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:" - - RootedGlob - FilePathRelative - (GlobDirRecursive [WildCard]) <- - testparse "**/*" - RootedGlob - FilePathRelative - (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard])) <- - testparse "foo/**/*" - RootedGlob - FilePathRelative - (GlobDir [Literal "foo"] (GlobDirRecursive [WildCard, Literal ".txt"])) <- - testparse "foo/**/*.txt" - - RootedGlob - FilePathRelative - (GlobFile [Literal "."]) <- - testparse "." - - RootedGlob - FilePathRelative - (GlobFile [Literal "~"]) <- - testparse "~" - - RootedGlob - FilePathRelative - (GlobDir [Literal "."] GlobDirTrailing) <- - testparse "./" - - RootedGlob - FilePathRelative - (GlobFile [Literal "foo"]) <- - testparse "foo" - - RootedGlob - FilePathRelative - ( GlobDir - [Literal "foo"] - (GlobFile [Literal "bar"]) - ) <- - testparse "foo/bar" - - RootedGlob - FilePathRelative - ( GlobDir - [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing) - ) <- - testparse "foo/bar/" - - RootedGlob - (FilePathRoot "/") - ( GlobDir - [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing) - ) <- - testparse "/foo/bar/" - - RootedGlob - (FilePathRoot "C:\\") - ( GlobDir - [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing) - ) <- - testparse "C:\\foo\\bar\\" - - RootedGlob - FilePathRelative - (GlobFile [WildCard]) <- - testparse "*" - - RootedGlob - FilePathRelative - (GlobFile [WildCard, WildCard]) <- - testparse "**" -- not helpful, but valid (?) - RootedGlob - FilePathRelative - (GlobFile [WildCard, Literal "foo", WildCard]) <- - testparse "*foo*" - - RootedGlob - FilePathRelative - (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- - testparse "foo*bar" - - RootedGlob - FilePathRelative - (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- - testparse "{*,foo}" - - parseFail "{" - parseFail "}" - parseFail "," - parseFail "{" - parseFail "{{}" - parseFail "{}" - parseFail "{,}" - parseFail "{foo,}" - parseFail "{,foo}" - - return () - -testparse :: String -> IO RootedGlob -testparse s = - case eitherParsec s of - Right p -> return p - Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err) - -parseFail :: String -> Assertion -parseFail s = - case eitherParsec s :: Either String RootedGlob of - Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p) - Left _ -> return () diff --git a/changelog.d/12065.md b/changelog.d/12065.md new file mode 100644 index 00000000000..e5b64abca28 --- /dev/null +++ b/changelog.d/12065.md @@ -0,0 +1,22 @@ +--- +synopsis: Code restructuring between Cabal and cabal-install +packages: [Cabal, cabal-install] +prs: 12065 +--- + +Moved file-monitoring code from cabal-install into Cabal, and relevant tests +from cabal-install tests to Cabal-tests. + +The following functionality is now available through the Cabal library: + +- File monitoring +- Globs +- Hash functions + +Additionally, a typeclass MonadRebuild has been introduced, which captures the +generic behavior of the Rebuild monad; most functionality from +cabal-install that uses the Rebuild monad has been rewritten to only depend on +MonadRebuild, and moved to Cabal. + +To keep code backwards compatible, all moved / rewritten functions are +re-exported under their old names from their previous modules. From 080633b1672b00ada5613edf2483ff4c95641636 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 31 Aug 2026 10:47:11 +0200 Subject: [PATCH 08/17] Address review concerns --- Cabal/Cabal.cabal | 2 +- Cabal/src/Distribution/Simple/FileMonitor.hs | 8 ++--- Cabal/src/Distribution/Simple/RebuildMonad.hs | 29 ++++++++++++++----- cabal-install/cabal-install.cabal | 1 + .../src/Distribution/Client/RebuildMonad.hs | 18 ++++++++---- 5 files changed, 40 insertions(+), 18 deletions(-) diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 2dd4f917c99..17b828650a8 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -333,7 +333,7 @@ library -- Parsec parser-related modules build-depends: , transformers >= 0.5.6 && < 0.7 - , mtl >= 2.1 && < 2.4 + , mtl >= 2.3 && < 2.4 , parsec >= 3.1.13.0 && < 3.2 other-modules: diff --git a/Cabal/src/Distribution/Simple/FileMonitor.hs b/Cabal/src/Distribution/Simple/FileMonitor.hs index 0c341ffe0c5..29d4db1913a 100644 --- a/Cabal/src/Distribution/Simple/FileMonitor.hs +++ b/Cabal/src/Distribution/Simple/FileMonitor.hs @@ -584,8 +584,8 @@ probeMonitorStateFiles -- directory modification time changed: -- a matching file may have been added or deleted matches <- - return . filter (matchGlobPieces glob) - =<< liftIO (listDirectory (root dirName)) + filter (matchGlobPieces glob) + <$> liftIO (listDirectory (root dirName)) traverse_ probeMergeResult $ mergeBy @@ -788,8 +788,8 @@ probeMonitorStateGlobRel -- directory modification time changed: -- a matching file may have been added or deleted matches <- - return . filter (matchGlobPieces glob) - =<< liftIO (listDirectory (root dirName)) + filter (matchGlobPieces glob) + <$> liftIO (listDirectory (root dirName)) traverse_ probeMergeResult $ mergeBy diff --git a/Cabal/src/Distribution/Simple/RebuildMonad.hs b/Cabal/src/Distribution/Simple/RebuildMonad.hs index 093ba85467e..1f6ada514fd 100644 --- a/Cabal/src/Distribution/Simple/RebuildMonad.hs +++ b/Cabal/src/Distribution/Simple/RebuildMonad.hs @@ -21,6 +21,7 @@ module Distribution.Simple.RebuildMonad -- * Setting up file monitoring , monitorFiles , MonitorFilePath + , MonitorFilePaths , monitorFile , monitorFileHashed , monitorNonExistentFile @@ -60,16 +61,25 @@ import Distribution.Simple.Utils (debug) import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) import Control.Monad -import Control.Monad.Writer as Writer +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT) +import Control.Monad.Writer (MonadWriter) +import qualified Control.Monad.Writer as Writer import qualified Data.Map.Strict as Map +import Data.Monoid (Dual (..)) import System.Directory import System.FilePath +-- | We use 'Dual' internally to avoid the performance problems associated with +-- appending to linked lists (as the more obvious @WriterT [MonitorFilePath]@ +-- type would cause). +type MonitorFilePaths = Dual [MonitorFilePath] + -- | A monad layered on top of 'IO' to help with re-running actions when the -- input files and values they depend on change. The crucial operations are -- 'rerunIfChanged'' and 'monitorFiles'. class - (Monad m, MonadIO m, MonadWriter [MonitorFilePath] m) => + (Monad m, MonadIO m, MonadWriter MonitorFilePaths m) => MonadRebuild m where -- | Lift an 'IO' action into a 'MonadRebuild' context, such that other @@ -102,12 +112,17 @@ class :: ((forall a. m a -> IO (a, [MonitorFilePath])) -> IO (b, [MonitorFilePath])) -> m b --- | Minimal instance for a simple @WriterT [MonitorFilePath] IO@. -instance MonadRebuild (WriterT [MonitorFilePath] IO) where +-- | Minimal instance for a simple @WriterT MonitorFilePaths IO@. +instance MonadRebuild (WriterT MonitorFilePaths IO) where withRunRebuildInIO inner = do - (result, files) <- liftIO $ inner runWriterT - Writer.tell files + (result, files) <- liftIO $ inner runRebuildT + Writer.tell (Dual files) return result + where + runRebuildT :: Monad m => WriterT MonitorFilePaths m a -> m (a, [MonitorFilePath]) + runRebuildT action = do + (result, Dual files) <- runWriterT action + return (result, files) -- | Use this within the body action of 'rerunIfChanged' to declare that the -- action depends on the given files. This can be based on what the action @@ -118,7 +133,7 @@ instance MonadRebuild (WriterT [MonitorFilePath] IO) where -- passed in to 'runRebuild'. monitorFiles :: MonadRebuild m => [MonitorFilePath] -> m () monitorFiles filespecs = - Writer.tell filespecs + Writer.tell (Dual filespecs) -- | This captures the standard use pattern for a 'FileMonitor': given a -- monitor, an action and the input value the action depends on, either diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index c4adb43d607..b65e8f93db6 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -261,6 +261,7 @@ library , stm >= 2.0 && < 2.6 , tar >= 0.5.0.3 && < 0.8 , time >= 1.5.0.1 && < 1.17 + , transformers >= 0.5.6 && < 0.7 , zlib >= 0.6 && < 0.8 , hackage-security >= 0.6.2.0 && < 0.7 , text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2 diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index e4c49eec692..2ccb87cbe88 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -78,29 +78,34 @@ import Distribution.Simple.PreProcess.Types (Suffix (..)) import Distribution.Simple.Utils (ordNub) import Control.Monad.Reader as Reader -import Control.Monad.Writer as Writer +import Control.Monad.Trans.Writer.CPS (WriterT, execWriterT, runWriterT) +import Control.Monad.Writer (MonadWriter) +import qualified Control.Monad.Writer as Writer +import Data.Monoid import System.Directory import System.FilePath -- | A custom rebuild monad to be used for file monitoring within -- @cabal-install@. On top of the basic 'MonadRebuild' functionality, it keeps -- the current root path in a 'ReaderT' context. -newtype Rebuild a = Rebuild (ReaderT FilePath (WriterT [MonitorFilePath] IO) a) +newtype Rebuild a = Rebuild (ReaderT FilePath (WriterT MonitorFilePaths IO) a) deriving (Functor, Applicative, Monad, MonadIO) -deriving newtype instance MonadWriter [MonitorFilePath] Rebuild +deriving newtype instance MonadWriter MonitorFilePaths Rebuild instance MonadRebuild Rebuild where withRunRebuildInIO action = do rootDir <- askRoot let runInIO = unRebuild rootDir (result, files) <- liftIO $ action runInIO - Writer.tell files + Writer.tell (Dual files) return result -- | Run a 'Rebuild' IO action. unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath]) -unRebuild rootDir (Rebuild action) = runWriterT (runReaderT action rootDir) +unRebuild rootDir (Rebuild action) = do + (result, Dual files) <- runWriterT (runReaderT action rootDir) + return (result, files) -- | Run a 'Rebuild' IO action. runRebuild :: FilePath -> Rebuild a -> IO a @@ -108,7 +113,8 @@ runRebuild rootDir (Rebuild action) = fst <$> runWriterT (runReaderT action root -- | Run a 'Rebuild' IO action. execRebuild :: FilePath -> Rebuild a -> IO [MonitorFilePath] -execRebuild rootDir (Rebuild action) = execWriterT (runReaderT action rootDir) +execRebuild rootDir (Rebuild action) = + getDual <$> execWriterT (runReaderT action rootDir) -- | The root that relative paths are interpreted as being relative to. askRoot :: Rebuild FilePath From afa0469058e7080e55258a8e9aeca997c8662c27 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 14 Jul 2026 10:23:28 +0200 Subject: [PATCH 09/17] Fix #11411 This replaces the previous preprocessor re-run logic ("if the preprocessor output exists and is newer than the input, don't re-run the preprocessor") with a file monitor, which takes both the input file and the preprocessor itself into account, solving #11411. To make this possible, each preprocessor is now tagged with a hash that uniquely identifies the specific preprocessor version. The process of finding the actual preprocessor (`runPreProcessor`) to run has been split off from the actual running; this was necessary so that we can get a unique hash of the preprocessor (including version) without having to actually run it, while also avoiding duplicate work and a potential mismatch between the hash and the actual preprocessor. Hence, we now have `configurePreProcessor`, which returns a pair of the former `runPreProcessor` action and the preprocessor hash. Other changes: - Use GHC.Fingerprint instead of SHA256 in FileMonitor (avoiding a dependency on cryptohash-sha256, which is not a boot library). - Clean up the ProgramDb API, so that we can be explicit about whether we want to configure preprocessors on the fly as needed or not. --- Cabal/src/Distribution/Simple/FileMonitor.hs | 4 +- Cabal/src/Distribution/Simple/Haddock.hs | 2 +- Cabal/src/Distribution/Simple/PreProcess.hs | 345 ++++++++++++------ .../Distribution/Simple/PreProcess/Types.hs | 43 ++- Cabal/src/Distribution/Simple/Program.hs | 3 + Cabal/src/Distribution/Simple/Program/Db.hs | 120 ++++-- .../AutogenModulesToggling/Setup.hs | 8 +- .../PackageTests/CustomPreProcess/Setup.hs | 22 +- .../Regression/T11411/T11411.cabal | 16 + .../PackageTests/Regression/T11411/cabal.out | 32 ++ .../Regression/T11411/cabal.project | 1 + .../Regression/T11411/cabal.test.hs | 12 + .../T11411/repo/alex-3.4.0.0/alex.cabal | 10 + .../T11411/repo/alex-3.4.0.0/app/Main.hs | 18 + .../T11411/repo/alex-3.5.0.0/alex.cabal | 10 + .../T11411/repo/alex-3.5.0.0/app/Main.hs | 18 + .../Regression/T11411/src/Hello.x | 1 + changelog.d/12021-renaming | 10 + changelog.d/12021.md | 28 ++ 19 files changed, 547 insertions(+), 156 deletions(-) create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/T11411.cabal create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/cabal.out create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/cabal.project create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/alex.cabal create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/app/Main.hs create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/alex.cabal create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/app/Main.hs create mode 100644 cabal-testsuite/PackageTests/Regression/T11411/src/Hello.x create mode 100644 changelog.d/12021-renaming create mode 100644 changelog.d/12021.md diff --git a/Cabal/src/Distribution/Simple/FileMonitor.hs b/Cabal/src/Distribution/Simple/FileMonitor.hs index 29d4db1913a..66fe50d02b6 100644 --- a/Cabal/src/Distribution/Simple/FileMonitor.hs +++ b/Cabal/src/Distribution/Simple/FileMonitor.hs @@ -34,6 +34,8 @@ import qualified Data.Binary as Binary import Data.Binary.Get (runGetOrFail) import qualified Data.ByteString.Lazy as BS import qualified Data.Map.Strict as Map +import GHC.Fingerprint (Fingerprint) +import qualified GHC.Fingerprint as Fingerprint import Control.Exception import Control.Monad.Except @@ -45,8 +47,6 @@ import Control.Monad.Except import Control.Monad.State (StateT, mapStateT) import qualified Control.Monad.State as State import Control.Monad.Trans (MonadIO, liftIO) -import GHC.Fingerprint (Fingerprint) -import qualified GHC.Fingerprint as Fingerprint import Distribution.Compat.Time import Distribution.Simple.FileMonitor.Types diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index 201bb8c4b30..50230f12838 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -1554,7 +1554,7 @@ hscolour' suffixes flags = either noHsColourPath (\(hscolourProg, _, _) -> go hscolourProg) - =<< lookupProgramVersion + =<< lookupAndConfigureProgramVersion verbosity hscolourProgram (orLaterVersion (mkVersion [1, 8])) diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 0bc8972f7fa..5c42e84416a 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} -- | @@ -27,6 +28,7 @@ module Distribution.Simple.PreProcess , builtinHaskellSuffixes , builtinHaskellBootSuffixes , PreProcessor (..) + , PreProcessorKey (..) , mkSimplePreProcessor , runSimplePreProcessor , ppCpp @@ -60,6 +62,7 @@ import Distribution.Simple.PreProcess.Types import Distribution.Simple.PreProcess.Unlit import Distribution.Simple.Program import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.RebuildMonad import Distribution.Simple.Test.LibV09 import Distribution.Simple.Utils import Distribution.System @@ -68,6 +71,16 @@ import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version +-- @mtl@ versions before 2.3.0 re-exported @Control.Monad@ from +-- @Control.Monad.Writer@ (see https://github.com/haskell/mtl/blob/master/docs/Mtl-2.3.x-Migration.md), +-- triggering a redundant import warning here; from @mtl-2.3.0@ onwards, this +-- re-export no longer exists, so we need to explicitly import @Control.Monad@ +-- here. +#if MIN_VERSION_mtl(2,3,0) +import Control.Monad (sequence) +#endif +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Writer.CPS import System.Directory (doesDirectoryExist, doesFileExist) import System.FilePath ( normalise @@ -118,8 +131,9 @@ runSimplePreProcessor -> FilePath -> Verbosity -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity +runSimplePreProcessor pp inFile outFile verbosity = do + (runPreProcessor, _) <- getPreProcessor pp verbosity + runPreProcessor (".", inFile) (".", outFile) verbosity -- | A preprocessor for turning non-Haskell files with the given 'Suffix' -- (i.e. file extension) into plain Haskell source files. @@ -202,6 +216,12 @@ preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = BenchmarkUnsupported tt -> dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt where + orderingFromHandlers + :: Verbosity + -> [SymbolicPath Pkg (Dir Source)] + -> [(Suffix, PreProcessor)] + -> [ModuleName] + -> IO [ModuleName] orderingFromHandlers v d hndlrs mods = foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs builtinCSuffixes = map Suffix cSourceExtensions @@ -314,7 +334,6 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS -- found a pre-processable file in one of the source dirs Just (psrcLoc, psrcRelFile) -> do let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile - psrcFile = psrcLoc psrcRelFile pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") @@ -329,20 +348,28 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS -- the tarball). -- TODO: eliminate sdist variant, just supply different handlers when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> - i psrcFile `moreRecentFile` i ppsrcFile - when recomp $ do - let destDir = i buildLoc takeDirectory srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack - pp - (psrcLoc, getSymbolicPath psrcRelFile) - (buildLoc, srcStem <.> "hs") + -- Use file monitoring to only re-run the preprocessor if either the + -- input file or the preprocessor itself have changed. + -- See Note [Preprocessor monitoring]. + (runPreProcessor, key) <- getPreProcessor pp verbosity + let recompile = liftIO $ do + let destDir = i buildLoc takeDirectory srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack + runPreProcessor + (psrcLoc, getSymbolicPath psrcRelFile) + (buildLoc, srcStem <.> "hs") + void . execWriterT $ + rerunIfChanged' + verbosity + (interpretSymbolicPath mbWorkDir (makeSymbolicPath "")) + sequence + [ + ( newFileMonitor (i buildLoc srcStem <.> ext <> "-cache") + , key + , recompile + ) + ] where i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path buildAsSrcLoc :: SymbolicPath Pkg (Dir Source) @@ -354,7 +381,12 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS -- done another way. Possibly we should also be looking for .lhs-boot -- files, but I think that preprocessors only produce .hs files. runPreProcessorWithHsBootHack - pp + :: PreProcessCommand + -> (SymbolicPathX allowAbsolute1 Pkg to1, FilePath) + -> (SymbolicPathX allowAbsolute Pkg to, FilePath) + -> IO () + runPreProcessorWithHsBootHack + runPreProcessor (inBaseDir, inRelativeFile) (outBaseDir, outRelativeFile) = do -- Preprocessors are expected to take into account the working @@ -362,7 +394,6 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS -- computed with mbWorkDirLBI. -- Hence the use of 'getSymbolicPath' here. runPreProcessor - pp (getSymbolicPath inBaseDir, inRelativeFile) (getSymbolicPath outBaseDir, outRelativeFile) verbosity @@ -390,9 +421,11 @@ ppUnlit = PreProcessor { platformIndependent = True , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) (dieWithException verbosity) (unlit inFile contents) + , getPreProcessor = \_ -> do + let runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) (dieWithException verbosity) (unlit inFile contents) + return (runPreProcessor, PreProcessorBuiltin) } ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor @@ -420,13 +453,18 @@ ppGhcCpp program xHs extraArgs _bi lbi clbi = PreProcessor { platformIndependent = False , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (prog, version, _) <- - requireProgramVersion - verbosity - program - anyVersion - (withPrograms lbi) + , getPreProcessor = \verbosity' -> do + progVersion <- getProgVersion verbosity' + let ppInfo = PreProcessorPrograms [fst progVersion] + return (runPreProcessor progVersion, ppInfo) + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + runPreProcessor (prog, version) = + mkSimplePreProcessor $ \inFile outFile verbosity -> do runProgramCwd verbosity (mbWorkDirLBI lbi) prog $ ["-E", "-cpp"] -- This is a bit of an ugly hack. We're going to @@ -438,24 +476,36 @@ ppGhcCpp program xHs extraArgs _bi lbi clbi = ++ ["-optP-include", "-optP" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] ++ ["-o", outFile, inFile] ++ extraArgs - } - where - -- See Note [Symbolic paths] in Distribution.Utils.Path - u :: SymbolicPath Pkg to -> FilePath - u = interpretSymbolicPathCWD + + getProgVersion + :: Verbosity + -> IO (ConfiguredProgram, Version) + getProgVersion verbosity = do + (prog, version) <- + requireConfiguredProgramVersion + verbosity + program + anyVersion + (withPrograms lbi) + return (prog, version) ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppCpphs extraArgs _bi lbi clbi = PreProcessor { platformIndependent = False , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- - requireProgramVersion - verbosity - cpphsProgram - anyVersion - (withPrograms lbi) + , getPreProcessor = \verbosity -> do + progVersion <- getProgVersion verbosity + let ppInfo = PreProcessorPrograms [fst progVersion] + return (runPreProcessor progVersion, ppInfo) + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + runPreProcessor (cpphsProg, cpphsVersion) = + mkSimplePreProcessor $ \inFile outFile verbosity -> do runProgramCwd verbosity (mbWorkDirLBI lbi) cpphsProg $ ("-O" ++ outFile) : inFile @@ -463,25 +513,38 @@ ppCpphs extraArgs _bi lbi clbi = : "--strip" : ["--include=" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName) | cpphsVersion >= mkVersion [1, 6]] ++ extraArgs - } - where - -- See Note [Symbolic paths] in Distribution.Utils.Path - u :: SymbolicPath Pkg to -> FilePath - u = interpretSymbolicPathCWD + + getProgVersion + :: Verbosity + -> IO (ConfiguredProgram, Version) + getProgVersion verbosity = do + (prog, version) <- + requireConfiguredProgramVersion + verbosity + cpphsProgram + anyVersion + (withPrograms lbi) + return (prog, version) ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppHsc2hs bi lbi clbi = PreProcessor { platformIndependent = False , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - (hsc2hsProg, hsc2hsVersion, _) <- - requireProgramVersion - verbosity - hsc2hsProgram - anyVersion - (withPrograms lbi) + , getPreProcessor = \verbosity -> do + progVersion <- getProgVersion verbosity + let (gccProg, hsc2hsProg, _) = progVersion + let ppInfo = PreProcessorPrograms [gccProg, hsc2hsProg] + return (runPreProcessor progVersion, ppInfo) + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPathX allowAbs Pkg to -> FilePath + u = interpretSymbolicPathCWD + mbWorkDir = mbWorkDirLBI lbi + + runPreProcessor (gccProg, hsc2hsProg, hsc2hsVersion) = + mkSimplePreProcessor $ \inFile outFile verbosity -> do let runHsc2hs = runProgramCwd verbosity mbWorkDir hsc2hsProg -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. let isCross = hostPlatform lbi /= buildPlatform @@ -500,12 +563,19 @@ ppHsc2hs bi lbi clbi = runHsc2hs (prependCrossFlags ["@" ++ responseFileName]) ) else runHsc2hs (prependCrossFlags pureArgs) - } - where - -- See Note [Symbolic paths] in Distribution.Utils.Path - u :: SymbolicPathX allowAbs Pkg to -> FilePath - u = interpretSymbolicPathCWD - mbWorkDir = mbWorkDirLBI lbi + + getProgVersion + :: Verbosity + -> IO (ConfiguredProgram, ConfiguredProgram, Version) + getProgVersion verbosity = do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + (hsc2hsProg, hsc2hsVersion) <- + requireConfiguredProgramVersion + verbosity + hsc2hsProgram + anyVersion + (withPrograms lbi) + pure (gccProg, hsc2hsProg, hsc2hsVersion) -- Returns a list of command line arguments that can either be passed -- directly, or via a response file. @@ -660,49 +730,11 @@ ppC2hs bi lbi clbi = PreProcessor { platformIndependent = False , ppOrdering = unsorted - , runPreProcessor = - \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) - verbosity -> do - (c2hsProg, _, _) <- - requireProgramVersion - verbosity - c2hsProgram - (orLaterVersion (mkVersion [0, 15])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - runProgramCwd verbosity mbWorkDir c2hsProg $ - -- Options from the current package: - ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] - ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] - ++ ["--cppopts=-include" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] - ++ ["--include=" ++ outBaseDir] - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- - ["-I" ++ opt | opt <- Installed.includeDirs pkg] - ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg, - -- c2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- - -- DO NOT add Installed.cxxOptions unless this changes! - c `elem` "DIU" - ] - ] - -- TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile - ] + , getPreProcessor = \verbosity -> do + progVersion <- getProgVersion verbosity + let (gccProg, c2hsProg, _) = progVersion + let ppInfo = PreProcessorPrograms [gccProg, c2hsProg] + return (runPreProcessor progVersion, ppInfo) } where pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) @@ -711,6 +743,54 @@ ppC2hs bi lbi clbi = u :: SymbolicPath Pkg to -> FilePath u = interpretSymbolicPathCWD + runPreProcessor + (gccProg, c2hsProg, _) + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity = do + runProgramCwd verbosity mbWorkDir c2hsProg $ + -- Options from the current package: + ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--cppopts=-include" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + ++ ["--include=" ++ outBaseDir] + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg, + -- c2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- + -- DO NOT add Installed.cxxOptions unless this changes! + c `elem` "DIU" + ] + ] + -- TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile + ] + + getProgVersion verbosity = do + (c2hsProg, c2hsVersion) <- + requireConfiguredProgramVersion + verbosity + c2hsProgram + (orLaterVersion (mkVersion [0, 15])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + return (gccProg, c2hsProg, c2hsVersion) + ppC2hsExtras :: PreProcessorExtras ppC2hsExtras mbWorkDir buildBaseDir = do fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir @@ -842,14 +922,20 @@ standardPP lbi prog args = PreProcessor { platformIndependent = False , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgramCwd - verbosity - (mbWorkDirLBI lbi) - prog - (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) + , getPreProcessor = \_ -> + pure + ( runPreProcessor + , PreProcessorPrograms . maybeToList $ lookupProgram prog (withPrograms lbi) + ) } + where + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgramCwd + verbosity + (mbWorkDirLBI lbi) + prog + (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) -- | Convenience function; get the suffixes of these preprocessors. ppSuffixes :: [PPSuffixHandler] -> [Suffix] @@ -926,3 +1012,42 @@ preprocessExtras verbosity comp lbi = case comp of ++ map exeName (executables pkg_descr) ++ map testName (testSuites pkg_descr) ++ map benchmarkName (benchmarks pkg_descr) + +{- + +Note [Preprocessor monitoring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to decide whether a given pre-processed file must be (re)generated, we +need to check two things: the input file, and the preprocessor that is used to +generate it. If either of these changes, *or* if the output file doesn't exist, +we need to (re-)run the preprocessor. + +We reuse the existing file monitoring infrastructure for this (see +"Distribution.Simple.FileMonitor"), which allows us to specify a set of files to +monitor (our input file), and a /key/, which is an arbitrary value which, when +changed, will trigger a re-run. + +That key will be different for each known preprocessor, but it will generally be +one of two things: + +- A dummy value to indicate that we're dealing with a built-in preprocessor + (e.g. @unlit@), which never changes between builds using the same Cabal + version +- A set of configured programs ('ConfiguredProgram'), each representing an + on-disk binary that will handle (part of) the preprocessing, with a full path + and any arguments and environment variables that will be passed to it. + +The 'PreProcessorKey' type (defined in "Distribution.Simple.PreProcess.Types") +represents these keys. + +Further, to make sure that we can get that key without actually having to run +the preprocessor (which is the very thing we try to avoid), the 'PreProcessor' +data structure exposes the 'getPreProcessor' function, which in turn +produces the actual preprocessor action together with the corresponding key, +thus making sure that the two always match. + +Crucially, the re-run logic here __relies on the fact that all preprocessors +will be pre-configured__, such that 'lookupProgramVersion' never actually has to +configure any programs at this point. + +-} diff --git a/Cabal/src/Distribution/Simple/PreProcess/Types.hs b/Cabal/src/Distribution/Simple/PreProcess/Types.hs index e5a2a64260c..0cae8878d24 100644 --- a/Cabal/src/Distribution/Simple/PreProcess/Types.hs +++ b/Cabal/src/Distribution/Simple/PreProcess/Types.hs @@ -14,6 +14,7 @@ module Distribution.Simple.PreProcess.Types ( Suffix (..) , PreProcessor (..) , PreProcessCommand + , PreProcessorKey (..) , builtinHaskellSuffixes , builtinHaskellBootSuffixes ) @@ -24,12 +25,13 @@ import Prelude () import Distribution.ModuleName (ModuleName) import Distribution.Pretty +import Distribution.Simple.Program.Types (ConfiguredProgram) import Distribution.Utils.Path import Distribution.Verbosity import qualified Text.PrettyPrint as Disp -- | The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of +-- external program, but need not be. The arguments are the name of -- the input file, the name of the output file and a verbosity level. -- Here is a simple example that merely prepends a comment to the given -- source file: @@ -39,11 +41,14 @@ import qualified Text.PrettyPrint as Disp -- > PreProcessor { -- > platformIndependent = True, -- > ppOrdering = \_ _ -> return, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return () +-- > getPreProcessor = \_ -> do +-- > let runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return () +-- > ppKey = PreProcessorBuiltin +-- > return (runPreProcessor, ppKey) -- -- We split the input and output file names into a base directory and the -- rest of the file name. The input base dir is the path in the list of search @@ -85,10 +90,32 @@ data PreProcessor = PreProcessor -- well-behaved and not reorder modules it doesn't have dominion over! -- -- @since 3.8.1.0 - , runPreProcessor - :: PreProcessCommand + , getPreProcessor + :: Verbosity + -> IO (PreProcessCommand, PreProcessorKey) } +-- | Uniquely identifies a specific preprocessor (version) for change +-- monitoring purposes. +-- This value should change iff the preprocessor itself changes in a way that +-- requires re-running it for a given input file. +-- See Note [Preprocessor monitoring] in Distribution.Simple.PreProcess +data PreProcessorKey + = -- | A built-in preprocessor; these only change when Cabal itself does, so + -- there is no need to track changes for these. + PreProcessorBuiltin + | -- | A preprocessor that runs some program, identified uniquely by the + -- configured program. + PreProcessorPrograms [ConfiguredProgram] + | -- | A custom preprocessor, identified uniquely by a supplied string. Use + -- this for preprocessors that may change between builds, but cannot be + -- implemented using 'ConfiguredProgram'. + PreProcessorCustom String + deriving (Generic, Eq) + +instance Binary PreProcessorKey +instance Structured PreProcessorKey + -- | A command to run a given preprocessor on a single source file. -- -- The input and output file paths are passed in as arguments, as it is diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index 9b329feeb51..918da631afe 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -90,12 +90,15 @@ module Distribution.Simple.Program , userSpecifiedArgs , lookupProgram , lookupProgramVersion + , lookupAndConfigureProgramVersion + , lookupConfiguredProgramVersion , updateProgram , configureProgram , configureAllKnownPrograms , reconfigurePrograms , requireProgram , requireProgramVersion + , requireConfiguredProgramVersion , needProgram , runDbProgram , runDbProgramCwd diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index 4143e32c66a..e546ee0ae1b 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -26,37 +26,48 @@ module Distribution.Simple.Program.Db , restoreProgramDb -- ** Query and manipulate the program db + + -- *** Known programs , addKnownProgram , addKnownPrograms - , clearUnconfiguredPrograms - , prependProgramSearchPath - , prependProgramSearchPathNoLogging - , lookupKnownProgram , knownPrograms - , getProgramSearchPath - , setProgramSearchPath - , modifyProgramSearchPath - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs + + -- *** Query configured programs + , lookupAndConfigureProgramVersion + , lookupConfiguredProgramVersion + , lookupKnownProgram , lookupProgram , lookupProgramByName - , updateProgram - , configuredPrograms + , lookupProgramVersion + , needProgram + , requireConfiguredProgramVersion + , requireProgram + , requireProgramVersion - -- ** Query and manipulate the program db + -- *** Manage program configurations + , clearUnconfiguredPrograms + , configureAllKnownPrograms + , configuredPrograms , configureProgram , configureUnconfiguredProgram - , configureAllKnownPrograms - , unconfigureProgram - , lookupProgramVersion , reconfigurePrograms - , requireProgram - , requireProgramVersion - , needProgram + , unconfigureProgram + , updateProgram + + -- *** Search paths + , getProgramSearchPath + , modifyProgramSearchPath + , setProgramSearchPath + , prependProgramSearchPath + , prependProgramSearchPathNoLogging + + -- *** User specify + , userMaybeSpecifyPath + , userSpecifiedArgs + , userSpecifyArgs + , userSpecifyArgss + , userSpecifyPath + , userSpecifyPaths -- * Internal functions , UnconfiguredProgs @@ -571,7 +582,21 @@ needProgram verbosity prog progdb = do Nothing -> return Nothing Just configuredProg -> return (Just (configuredProg, progdb')) +{-# DEPRECATED lookupProgramVersion "Use lookupAndConfigureProgramVersion instead" #-} + +-- | Check that a program is configured and available to be run. +-- +-- Alias for 'lookupConfiguredProgramVersion' +lookupProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb)) +lookupProgramVersion = lookupAndConfigureProgramVersion + -- | Check that a program is configured and available to be run. +-- Configures the program if it was unconfigured. -- -- Additionally check that the program version number is suitable and return -- it. For example you could require 'AnyVersion' or @'orLaterVersion' @@ -580,13 +605,13 @@ needProgram verbosity prog progdb = do -- It returns the configured program, its version number and a possibly updated -- 'ProgramDb'. If the program could not be configured or the version is -- unsuitable, it returns an error value. -lookupProgramVersion +lookupAndConfigureProgramVersion :: Verbosity -> Program -> VersionRange -> ProgramDb -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb)) -lookupProgramVersion verbosity prog range programDb = do +lookupAndConfigureProgramVersion verbosity prog range programDb = do -- If it's not already been configured, try to configure it now programDb' <- case lookupProgram prog programDb of Nothing -> configureProgram verbosity prog programDb @@ -604,7 +629,7 @@ lookupProgramVersion verbosity prog range programDb = do Nothing -> return $! Left $ UnknownVersionDb (programName prog) range (locationPath location) --- | Like 'lookupProgramVersion', but raises an exception in case of error +-- | Like 'lookupAndConfigureProgramVersion', but raises an exception in case of error -- instead of returning 'Left errMsg'. requireProgramVersion :: Verbosity @@ -614,4 +639,47 @@ requireProgramVersion -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = either (dieWithException verbosity) return - =<< lookupProgramVersion verbosity prog range programDb + =<< lookupAndConfigureProgramVersion verbosity prog range programDb + +-- | Like 'lookupConfiguredProgramVersion', but raises an exception in case of +-- error instead of returning 'Left errMsg'. +requireConfiguredProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version) +requireConfiguredProgramVersion verbosity prog range programDb = + either (dieWithException verbosity) return $ + lookupConfiguredProgramVersion prog range programDb + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the program version number is suitable and return +-- it. For example you could require 'AnyVersion' or @'orLaterVersion' +-- ('Version' [1,0] [])@ +-- +-- It returns the configured program and its version number. +-- If the program has not been configured or the version is unsuitable, it +-- returns an error value. +-- +-- Unlike 'lookupAndConfigureProgramVersion', this function will not configure +-- a program that hasn't been configured yet, and it will not modify the +-- program database. +lookupConfiguredProgramVersion + :: Program + -> VersionRange + -> ProgramDb + -> Either CabalException (ConfiguredProgram, Version) +lookupConfiguredProgramVersion prog range programDb = do + case lookupProgram prog programDb of + Nothing -> Left $ NoProgramFound (programName prog) range + Just configuredProg@ConfiguredProgram{programLocation = location} -> + case programVersion configuredProg of + Just version + | withinRange version range -> + return (configuredProg, version) + | otherwise -> + Left $ BadVersionDb (programName prog) version range (locationPath location) + Nothing -> + Left $ UnknownVersionDb (programName prog) range (locationPath location) diff --git a/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs b/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs index 76fec15e076..961c086a379 100644 --- a/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs +++ b/cabal-testsuite/PackageTests/AutogenModulesToggling/Setup.hs @@ -15,8 +15,12 @@ ppHGen :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor ppHGen _bi lbi _clbi = PreProcessor { platformIndependent = True , ppOrdering = unsorted - , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - copyFile inFile outFile + , getPreProcessor = \_ -> + pure + ( mkSimplePreProcessor $ \inFile outFile verbosity -> + copyFile inFile outFile + , PreProcessorBuiltin + ) } main :: IO () diff --git a/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs b/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs index 769f1309339..c2c4a2ddcf1 100644 --- a/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs +++ b/cabal-testsuite/PackageTests/CustomPreProcess/Setup.hs @@ -34,15 +34,23 @@ main = defaultMainWithHooks myCustomPreprocessor :: BuildInfo -> LocalBuildInfo -> PreProcessor myCustomPreprocessor _bi lbi = #endif - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - do info verbosity ("Preprocessing " ++ inFile ++ " to " ++ outFile) + PreProcessor + { platformIndependent = True +#if MIN_VERSION_Cabal(3,17,0) + , getPreProcessor = \_ -> pure + ( mkSimplePreProcessor $ \inFile outFile verbosity -> + do info verbosity ("Preprocessing " ++ inFile ++ " to " ++ outFile) + callProcess progPath [inFile, outFile] + , PreProcessorCustom progPath + ) +#else + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + do info verbosity ("Preprocessing " ++ inFile ++ " to " ++ outFile) + callProcess progPath [inFile, outFile] +#endif #if MIN_VERSION_Cabal(3,7,0) - callProcess progPath [inFile, outFile], - ppOrdering = unsorted + , ppOrdering = unsorted #else - callProcess progPath [inFile, outFile] #endif } where diff --git a/cabal-testsuite/PackageTests/Regression/T11411/T11411.cabal b/cabal-testsuite/PackageTests/Regression/T11411/T11411.cabal new file mode 100644 index 00000000000..33f2909b0b4 --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/T11411.cabal @@ -0,0 +1,16 @@ +cabal-version: 3.0 +name: T11411 +version: 0.1.0.0 +build-type: Simple + +library + hs-source-dirs: + src + exposed-modules: + Hello + build-depends: + base + build-tool-depends: + alex:alex + default-language: + Haskell2010 diff --git a/cabal-testsuite/PackageTests/Regression/T11411/cabal.out b/cabal-testsuite/PackageTests/Regression/T11411/cabal.out new file mode 100644 index 00000000000..256f20dc3eb --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/cabal.out @@ -0,0 +1,32 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - alex-3.4.0.0 (exe:alex) (requires build) + - T11411-0.1.0.0 (lib) (first run) +Configuring executable 'alex' for alex-3.4.0.0... +Preprocessing executable 'alex' for alex-3.4.0.0... +Building executable 'alex' for alex-3.4.0.0... +Installing executable alex in +Warning: The directory /cabal.dist/home/.cabal/store/ghc-/incoming/new-/cabal.dist/home/.cabal/store/ghc-/-/bin is not in the system search path. +Configuring library for T11411-0.1.0.0... +Preprocessing library for T11411-0.1.0.0... +Building library for T11411-0.1.0.0... +Error: [Cabal-7125] +Failed to build T11411-0.1.0.0-inplace. +# cabal v2-build +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - alex-3.5.0.0 (exe:alex) (requires build) + - T11411-0.1.0.0 (lib) (configuration changed) +Configuring executable 'alex' for alex-3.5.0.0... +Preprocessing executable 'alex' for alex-3.5.0.0... +Building executable 'alex' for alex-3.5.0.0... +Installing executable alex in +Warning: The directory /cabal.dist/home/.cabal/store/ghc-/incoming/new-/cabal.dist/home/.cabal/store/ghc-/-/bin is not in the system search path. +Configuring library for T11411-0.1.0.0... +Preprocessing library for T11411-0.1.0.0... +Building library for T11411-0.1.0.0... diff --git a/cabal-testsuite/PackageTests/Regression/T11411/cabal.project b/cabal-testsuite/PackageTests/Regression/T11411/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/Regression/T11411/cabal.test.hs b/cabal-testsuite/PackageTests/Regression/T11411/cabal.test.hs new file mode 100644 index 00000000000..f35ecbd2cfd --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/cabal.test.hs @@ -0,0 +1,12 @@ +import Test.Cabal.Prelude + +-- Test for #11411: cabal should re-invoke build tools (in this case, alex) +-- whose version changes in between builds. +main :: IO () +main = cabalTest $ withRepo "repo" $ do + -- Expect failure on first build: alex 3.4 outputs invalid Haskell. + fails $ cabal "v2-build" ["all", "-c", "any.alex==3.4.*"] + -- Second build should succeed: switching to alex 3.5 should cause cabal + -- to re-invoke alex, which will output valid Haskell this time around. + -- If this fails, it's because cabal didn't re-run the preprocessing step. + cabal "v2-build" ["all", "-c", "any.alex==3.5.*"] diff --git a/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/alex.cabal b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/alex.cabal new file mode 100644 index 00000000000..394998a4261 --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/alex.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: alex +version: 3.4.0.0 +build-type: Simple + +executable alex + main-is: Main.hs + hs-source-dirs: app + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/app/Main.hs b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/app/Main.hs new file mode 100644 index 00000000000..e360dd43b31 --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.4.0.0/app/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import System.Environment (getArgs) + +-- Fake alex 3.4: writes invalid Haskell so that GHC rejects the output. +main :: IO () +main = do + args <- getArgs + case args of + "--version" : _ -> + putStrLn "Alex version 3.4.0, (c) 2003 Chris Dornan and Simon Marlow" + _ -> + writeFile (outputFile args) "module Hello where\nTHIS IS NOT VALID HASKELL\n" + +outputFile :: [String] -> FilePath +outputFile ("-o" : f : _) = f +outputFile (_ : rest) = outputFile rest +outputFile [] = error "alex: no -o flag" diff --git a/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/alex.cabal b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/alex.cabal new file mode 100644 index 00000000000..d6f7bbd14eb --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/alex.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.0 +name: alex +version: 3.5.0.0 +build-type: Simple + +executable alex + main-is: Main.hs + hs-source-dirs: app + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/app/Main.hs b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/app/Main.hs new file mode 100644 index 00000000000..3de0c822e03 --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/repo/alex-3.5.0.0/app/Main.hs @@ -0,0 +1,18 @@ +module Main where + +import System.Environment (getArgs) + +-- Fake alex 3.5: writes valid Haskell so that GHC accepts the output. +main :: IO () +main = do + args <- getArgs + case args of + "--version" : _ -> + putStrLn "Alex version 3.5.0, (c) 2003 Chris Dornan and Simon Marlow" + _ -> + writeFile (outputFile args) "module Hello where\nhello :: String\nhello = \"hello from alex 3.5\"\n" + +outputFile :: [String] -> FilePath +outputFile ("-o" : f : _) = f +outputFile (_ : rest) = outputFile rest +outputFile [] = error "alex: no -o flag" diff --git a/cabal-testsuite/PackageTests/Regression/T11411/src/Hello.x b/cabal-testsuite/PackageTests/Regression/T11411/src/Hello.x new file mode 100644 index 00000000000..93ebfb15aa0 --- /dev/null +++ b/cabal-testsuite/PackageTests/Regression/T11411/src/Hello.x @@ -0,0 +1 @@ +(contents irrelevant) diff --git a/changelog.d/12021-renaming b/changelog.d/12021-renaming new file mode 100644 index 00000000000..f52ab2e8356 --- /dev/null +++ b/changelog.d/12021-renaming @@ -0,0 +1,10 @@ +--- +synopsis: Rename lookup*Program* functions +packages: [Cabal, cabal-install] +prs: 12021 +--- +Introduce `lookupAndConfigureProgramVersion` and +`lookupConfiguredProgramVersion`, deprecating the (functionally +identical) `lookupProgramVersion`. The new functions are explicit about whether +the program should be configured on the fly, or expected to be already +configured. diff --git a/changelog.d/12021.md b/changelog.d/12021.md new file mode 100644 index 00000000000..50578baec28 --- /dev/null +++ b/changelog.d/12021.md @@ -0,0 +1,28 @@ +--- +synopsis: Use file monitoring for pre-processor re-run checks +packages: [Cabal, cabal-install] +prs: 12021 +--- +This fixes a bug where pre-processors were not re-run if the build tool itself +changed, but the preprocessor input did not (see [issue +11411](https://github.com/haskell/cabal/issues/11411])). We use the existing +file monitoring infrastructure for this. + +To make this possible, the `PreProcessor` data structure needed to be changed; +the previous `runPreProcessor` field has been replaced by a `getPreProcessor`, +which returns a pair of the actual preprocessor function (the equivalent of +`runPreProcessor`) and a `PreProcessorKey`. The latter captures the +preprocessor's dependencies, which indicate whether the preprocessor itself has +changed or not, and can be one of: + +- `PreProcessorBuiltin`: indicates that this is a preprocessor built into GHC + or Cabal; no checks are needed, because the only way it will change is if we + select a different Cabal or GHC version, in which case the build will happen + in a different location. +- `PreProcessorPrograms`: a list of configured programs that are used to + preprocess the input. Cabal will compare paths to infer whether any of them + have changed. +- `PreProcessorCustom`: indicates that this is a custom preprocessor + (implemented as an arbitrary `IO` action); the string parameter should be + picked such that it changes exactly when the custom preprocessor changes, but + how that is achieved is up to the user. From 73991e73f6d7fe32b0add441d994302078d6f23e Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 17 Sep 2026 12:14:28 +0200 Subject: [PATCH 10/17] Fix another build error --- cabal-install/cabal-install.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index b65e8f93db6..7f6d995c2ae 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -497,5 +497,6 @@ test-suite long-tests , tasty >= 1.2.3 && <1.6 , tasty-expected-failure , tasty-quickcheck <0.12 + , tasty-hunit >= 0.10 , QuickCheck >= 2.14 && <2.19 , pretty-show >= 1.6.15 From 369d949c9dea64d0a9bee6136f736e63bd4de8eb Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 24 Sep 2026 07:39:39 +0200 Subject: [PATCH 11/17] Preliminary refactoring, introducing DependencyResolver typeclass --- .../src/Distribution/Solver/Modular.hs | 101 ++++++++++++++---- .../Solver/Types/DependencyResolver.hs | 57 +++++++--- .../src/Distribution/Client/Dependency.hs | 34 +++--- 3 files changed, 144 insertions(+), 48 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index b653d1459ed..591b55b5e98 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -1,7 +1,12 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Solver.Modular - ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where + ( ModularResolver (..) + , modularResolver + , SolverConfig(..) + , PruneAfterFirstSuccess(..) + ) where -- Here, we try to map between the external cabal-install solver -- interface and the internal interface that the solver actually @@ -50,7 +55,7 @@ import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Solver ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) import Distribution.Solver.Types.DependencyResolver - ( DependencyResolver ) + ( DependencyResolver (..), ResolverParams (..) ) import Distribution.Solver.Types.LabeledPackageConstraint ( LabeledPackageConstraint, unlabelPackageConstraint ) import Distribution.Solver.Types.PackageConstraint @@ -74,29 +79,87 @@ import Distribution.Simple.Utils import Distribution.Verbosity import Distribution.Solver.Modular.Message ( renderSummarizedMessage ) --- | Ties the two worlds together: classic cabal-install vs. the modular --- solver. Performs the necessary translations before and after. -modularResolver :: SolverConfig -> DependencyResolver loc -modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = - uncurry postprocess <$> -- convert install plan - solve' sc cinfo idx pkgConfigDB pprefs gcs pns +newtype ModularResolver = + ModularResolver + { modularResolverConfig :: SolverConfig + } + +data ModularResolverInputs = + ModularResolverInputs + { mrCompilerInfo :: CompilerInfo + , mrIndex :: Index + , mrPkgConfigDb :: Maybe PkgConfigDb + , mrPkgPrefs :: PN -> PackagePreferences + , mrPkgConstraints :: Map PN [LabeledPackageConstraint] + , mrPkgNames :: Set PN + } + +instance DependencyResolver ModularResolver where + type ResolverInputs ModularResolver = ModularResolverInputs + type ResolverOutput ModularResolver = (Assignment, RevDepMap) + runResolver mr inputs = + solve' + (modularResolverConfig mr) + (mrCompilerInfo inputs) + (mrIndex inputs) + (mrPkgConfigDb inputs) + (mrPkgPrefs inputs) + (mrPkgConstraints inputs) + (mrPkgNames inputs) + convInputs mr rp = + ModularResolverInputs + { mrCompilerInfo = rpCompilerInfo rp + , mrIndex = convPIs os arch + (rpCompilerInfo rp) + gcs + (shadowPkgs sc) + (strongFlags sc) + (solveExecutables sc) + (rpInstalledPackages rp) + (rpSourcePackages rp) + , mrPkgConfigDb = rpPkgConfigDb rp + , mrPkgPrefs = rpPkgPrefs rp + , mrPkgConstraints = gcs + , mrPkgNames = rpPkgNames rp + } where - -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx - -- Constraints have to be converted into a finite map indexed by PN. - gcs = M.fromListWith (++) (map pair pcs) - where - pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) + sc = modularResolverConfig mr + gcs = M.fromListWith (++) (map pair $ rpPkgConstraints rp) + pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) + Platform arch os = rpPlatform rp + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraint scope _) = scopeToPackageName scope + convOutput _mr rp = uncurry postprocess + where -- Results have to be converted into an install plan. 'convCP' removes -- package qualifiers, which means that linked packages become duplicates -- and can be removed. - postprocess a rdm = ordNubBy nodeKey $ - map (convCP iidx sidx) (toCPs a rdm) + postprocess a rdm = + ordNubBy nodeKey $ + map + (convCP (rpInstalledPackages rp) (rpSourcePackages rp)) + (toCPs a rdm) + +modularResolver :: SolverConfig -> ModularResolver +modularResolver sc = ModularResolver sc - -- Helper function to extract the PN from a constraint. - pcName :: PackageConstraint -> PN - pcName (PackageConstraint scope _) = scopeToPackageName scope +-- uncurry postprocess <$> -- convert install plan +-- solve' sc cinfo idx pkgConfigDB pprefs gcs pns +-- where +-- -- Indices have to be converted into solver-specific uniform index. +-- idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx +-- -- Constraints have to be converted into a finite map indexed by PN. +-- gcs = M.fromListWith (++) (map pair pcs) +-- where +-- pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) +-- +-- -- Results have to be converted into an install plan. 'convCP' removes +-- -- package qualifiers, which means that linked packages become duplicates +-- -- and can be removed. +-- postprocess a rdm = ordNubBy nodeKey $ +-- map (convCP iidx sidx) (toCPs a rdm) -- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display -- in the error case. diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 956a4e14849..1acc00917de 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} + module Distribution.Solver.Types.DependencyResolver - ( DependencyResolver + ( ResolverParams (..) + , DependencyResolver (..) ) where -import Distribution.Solver.Compat.Prelude ( Maybe, String, Set ) +import Distribution.Solver.Compat.Prelude ( Maybe, String, Set {-, Binary -}) import Prelude () +import Data.Kind import Distribution.Solver.Types.LabeledPackageConstraint ( LabeledPackageConstraint ) @@ -23,20 +27,45 @@ import Distribution.Package ( PackageName ) import Distribution.Compiler ( CompilerInfo ) import Distribution.System ( Platform ) --- | A dependency resolver is a function that works out an installation plan --- given the set of installed and available packages and a set of deps to --- solve for. + +-- type DependencyResolver loc = Platform +-- -> CompilerInfo +-- -> InstalledPackageIndex +-- -> PackageIndex (SourcePackage loc) +-- -> Maybe PkgConfigDb +-- -> (PackageName -> PackagePreferences) +-- -> [LabeledPackageConstraint] +-- -> Set PackageName +-- -> Progress SummarizedMessage String [ResolverPackage loc] + +data ResolverParams loc = + ResolverParams + { rpPlatform :: Platform + , rpCompilerInfo :: CompilerInfo + , rpInstalledPackages :: InstalledPackageIndex + , rpSourcePackages :: PackageIndex (SourcePackage loc) + , rpPkgConfigDb :: Maybe PkgConfigDb + , rpPkgPrefs :: PackageName -> PackagePreferences + , rpPkgConstraints :: [LabeledPackageConstraint] + , rpPkgNames :: Set PackageName + } + +-- | A dependency resolver consists of a function that works out an +-- installation plan given the set of installed and available packages and a +-- set of deps to solve for, together with a pair of resolver-specific input +-- and output types, and a pair of conversion that translate between these +-- resolver-specific types and the resolver-independent 'ResolverParams' type. -- -- The reason for this interface is because there are dozens of approaches to -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. -- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex - -> PackageIndex (SourcePackage loc) - -> Maybe PkgConfigDb - -> (PackageName -> PackagePreferences) - -> [LabeledPackageConstraint] - -> Set PackageName - -> Progress SummarizedMessage String [ResolverPackage loc] +-- Both the input and the output type must be binary-serializable, because we +-- need to use them as keys for re-run checks. +class {- (Binary (ResolverInputs a), Binary (ResolverOutput a)) + => -} DependencyResolver a where + type ResolverInputs a :: Type + type ResolverOutput a :: Type + runResolver :: a -> ResolverInputs a -> Progress SummarizedMessage String (ResolverOutput a) + convInputs :: a -> ResolverParams loc -> ResolverInputs a + convOutput :: a -> ResolverParams loc -> ResolverOutput a -> [ResolverPackage loc] diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 04815cea7d5..9c3fbcece95 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -121,6 +121,7 @@ import Distribution.Solver.Modular ( PruneAfterFirstSuccess (..) , SolverConfig (..) , modularResolver + , ModularResolver ) import Distribution.Solver.Modular.Message ( renderSummarizedMessage @@ -850,8 +851,8 @@ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = -- ------------------------------------------------------------ -runSolver :: SolverConfig -> DependencyResolver UnresolvedPkgLoc -runSolver = modularResolver +getSolver :: SolverConfig -> ModularResolver +getSolver = modularResolver -- | Run the dependency solver. -- @@ -866,10 +867,9 @@ resolveDependencies -> Progress String String SolverInstallPlan resolveDependencies platform comp pkgConfigDB params = do step (showDepResolverParams finalparams) - pkgs <- - formatProgress $ - runSolver - ( SolverConfig + pkgs <- do + let config = + SolverConfig reordGoals cntConflicts fineGrained @@ -885,15 +885,19 @@ resolveDependencies platform comp pkgConfigDB params = do order verbosity (PruneAfterFirstSuccess False) - ) - platform - comp - installedPkgIndex - sourcePkgIndex - pkgConfigDB - preferences - constraints - targets + solver = getSolver config + rparams = ResolverParams + platform + comp + installedPkgIndex + sourcePkgIndex + pkgConfigDB + preferences + constraints + targets + inputs = convInputs solver rparams + formatProgress $ + convOutput solver rparams <$> runResolver solver inputs validateSolverResult platform comp indGoals pkgs where finalparams@( DepResolverParams From 832e8624184ea0434a2d5d2f98e6bd5017a2148d Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Fri, 25 Sep 2026 23:33:55 +0200 Subject: [PATCH 12/17] WIP --- .../src/Distribution/Client/Dependency.hs | 165 +++++++++++------- .../Distribution/Client/ProjectPlanning.hs | 1 + 2 files changed, 102 insertions(+), 64 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 9c3fbcece95..e6c94f2cd86 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -19,6 +19,12 @@ module Distribution.Client.Dependency , Progress (..) , foldProgress + -- * Converting to and from resolver-specific representations of inputs and + -- outputs + , getSolver + , getFinalParams + , getSolverConfig + -- * Alternate, simple resolver that does not do dependencies recursively , resolveWithoutDependencies @@ -153,7 +159,6 @@ import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePreferences -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) import Distribution.Solver.Types.Progress import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.Settings @@ -854,85 +859,117 @@ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = getSolver :: SolverConfig -> ModularResolver getSolver = modularResolver +getFinalParams :: CompilerInfo -> DepResolverParams -> DepResolverParams +getFinalParams comp params = + if isJust (compilerInfoWiredInUnitIds comp) || asBool (depResolverAllowBootLibInstalls params) + then dependOnWiredIns comp params + else dontInstallNonReinstallablePackages params + +getSolverConfig :: DepResolverParams -> SolverConfig +getSolverConfig + (DepResolverParams + _targets + _constraints + _prefs + _defpref + _installedPkgIndex + _sourcePkgIndex + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + _allowBootLibs + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity) = + + SolverConfig + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + (PruneAfterFirstSuccess False) + +-- solver = getSolver config +-- rparams = ResolverParams +-- platform +-- comp +-- installedPkgIndex +-- sourcePkgIndex +-- pkgConfigDB +-- preferences +-- constraints +-- targets +-- inputs = convInputs solver rparams +-- +-- preferences :: PackageName -> PackagePreferences +-- preferences = interpretPackagesPreference targets defpref prefs + -- | Run the dependency solver. -- -- Since this is potentially an expensive operation, the result is wrapped in a -- a 'Progress' structure that can be unfolded to provide progress information, -- logging messages and the final result or an error. resolveDependencies - :: Platform - -> CompilerInfo - -> Maybe PkgConfigDb + :: DependencyResolver s + => s -> DepResolverParams + -> ResolverParams UnresolvedPkgLoc + -> ResolverInputs s -> Progress String String SolverInstallPlan -resolveDependencies platform comp pkgConfigDB params = do - step (showDepResolverParams finalparams) +resolveDependencies solver params rparams inputs = do + step (showDepResolverParams params) pkgs <- do - let config = - SolverConfig - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity - (PruneAfterFirstSuccess False) - solver = getSolver config - rparams = ResolverParams - platform - comp - installedPkgIndex - sourcePkgIndex - pkgConfigDB - preferences - constraints - targets - inputs = convInputs solver rparams formatProgress $ convOutput solver rparams <$> runResolver solver inputs - validateSolverResult platform comp indGoals pkgs + validateSolverResult + (rpPlatform rparams) + (rpCompilerInfo rparams) indGoals pkgs where - finalparams@( DepResolverParams - targets - constraints - prefs - defpref - installedPkgIndex - sourcePkgIndex - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - _allowBootLibs - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity - ) = - if isJust (compilerInfoWiredInUnitIds comp) || asBool (depResolverAllowBootLibInstalls params) - then dependOnWiredIns comp params - else dontInstallNonReinstallablePackages params + DepResolverParams + _targets + _constraints + _prefs + _defpref + _installedPkgIndex + _sourcePkgIndex + _reordGoals + _cntConflicts + _fineGrained + _minimize + indGoals + _noReinstalls + _shadowing + _strFlags + _allowBootLibs + _onlyConstrained_ + _maxBkjumps + _enableBj + _solveExes + _order + _verbosity + = params formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p - preferences :: PackageName -> PackagePreferences - preferences = interpretPackagesPreference targets defpref prefs - -- | Give an interpretation to the global 'PackagesPreference' as -- specific per-package 'PackageVersionPreference'. interpretPackagesPreference diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 5d1c1808fc1..9efc6768807 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1400,6 +1400,7 @@ planPackages localPackages pkgStanzasEnable = resolveDependencies + getSolver platform (compilerInfo comp) pkgConfigDB From 26d3f0cccbd4a17ec62f7d0c1e05f644a73f467e Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 6 Oct 2026 13:41:09 +0200 Subject: [PATCH 13/17] Make it compile again --- .../Solver/Types/DependencyResolver.hs | 12 +---- .../src/Distribution/Client/Configure.hs | 25 ++++++++-- .../src/Distribution/Client/Dependency.hs | 36 ++++++++++++-- .../src/Distribution/Client/Fetch.hs | 28 ++++++++--- .../src/Distribution/Client/Freeze.hs | 26 +++++++--- .../src/Distribution/Client/Install.hs | 24 +++++++-- .../Distribution/Client/ProjectPlanning.hs | 49 ++++++++++++------- .../NewBuild/CmdRepl/ScriptRerun/cabal.out | 1 + 8 files changed, 149 insertions(+), 52 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 1acc00917de..79c8881ab27 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -27,17 +27,6 @@ import Distribution.Package ( PackageName ) import Distribution.Compiler ( CompilerInfo ) import Distribution.System ( Platform ) - --- type DependencyResolver loc = Platform --- -> CompilerInfo --- -> InstalledPackageIndex --- -> PackageIndex (SourcePackage loc) --- -> Maybe PkgConfigDb --- -> (PackageName -> PackagePreferences) --- -> [LabeledPackageConstraint] --- -> Set PackageName --- -> Progress SummarizedMessage String [ResolverPackage loc] - data ResolverParams loc = ResolverParams { rpPlatform :: Platform @@ -69,3 +58,4 @@ class {- (Binary (ResolverInputs a), Binary (ResolverOutput a)) runResolver :: a -> ResolverInputs a -> Progress SummarizedMessage String (ResolverOutput a) convInputs :: a -> ResolverParams loc -> ResolverInputs a convOutput :: a -> ResolverParams loc -> ResolverOutput a -> [ResolverPackage loc] + diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 9b4e31177b7..5db0e69380e 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -57,6 +57,7 @@ import Distribution.Client.Types as Source import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageIndex @@ -423,8 +424,8 @@ planLocalPackage benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags - resolverParams :: DepResolverParams - resolverParams = + depResolverParams :: DepResolverParams + depResolverParams = removeLowerBounds (fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags) . removeUpperBounds @@ -472,7 +473,25 @@ planLocalPackage (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerInfo comp) pkgConfigDb resolverParams) + solver = getSolver depResolverParams + + -- inputs :: ResolverInputs ModularResolver + inputs = convInputs solver rparams + + -- rparams :: ResolverParams UnresolvedPkgLoc + rparams = mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams + + return $ + resolveDependencies + solver + depResolverParams + rparams + inputs -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index e6c94f2cd86..cc974cb7f49 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -14,7 +14,7 @@ -- Top level interface to dependency resolution. module Distribution.Client.Dependency ( -- * The main package dependency resolver - DepResolverParams + DepResolverParams (..) , resolveDependencies , Progress (..) , foldProgress @@ -24,6 +24,7 @@ module Distribution.Client.Dependency , getSolver , getFinalParams , getSolverConfig + , mkResolverParams -- * Alternate, simple resolver that does not do dependencies recursively , resolveWithoutDependencies @@ -34,6 +35,7 @@ module Distribution.Client.Dependency , scopeToplevel , PackagesPreferenceDefault (..) , PackagePreference (..) + , interpretPackagesPreference -- ** Standard policy , basicInstallPolicy @@ -135,6 +137,9 @@ import Distribution.Solver.Modular.Message import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage (..) ) +import Distribution.Solver.Types.PkgConfigDb + ( PkgConfigDb + ) import Distribution.System ( Platform ) @@ -856,8 +861,8 @@ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = -- ------------------------------------------------------------ -getSolver :: SolverConfig -> ModularResolver -getSolver = modularResolver +getSolver :: DepResolverParams -> ModularResolver +getSolver = modularResolver . getSolverConfig getFinalParams :: CompilerInfo -> DepResolverParams -> DepResolverParams getFinalParams comp params = @@ -1356,3 +1361,28 @@ instance Show ResolveNoDepsError where ++ prettyShow name ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) + +mkResolverParams :: Platform + -> CompilerInfo + -> InstalledPackageIndex + -> Maybe PkgConfigDb + -> DepResolverParams + -> ResolverParams UnresolvedPkgLoc +mkResolverParams platform comp installedPkgIndex pkgConfigDB depResolverParams = + ResolverParams + { rpPlatform = platform + , rpCompilerInfo = comp + , rpInstalledPackages = installedPkgIndex + , rpSourcePackages = depResolverSourcePkgIndex depResolverParams + , rpPkgConfigDb = pkgConfigDB + , rpPkgPrefs = pkgPrefs + , rpPkgConstraints = depResolverConstraints depResolverParams + , rpPkgNames = depResolverTargets depResolverParams + } + where + pkgPrefs :: PackageName -> PackagePreferences + pkgPrefs = + interpretPackagesPreference + (depResolverTargets depResolverParams) + (depResolverPreferenceDefault depResolverParams) + (depResolverPreferences depResolverParams) diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 13c6f23415e..66ecccd8053 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -32,6 +32,7 @@ import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Targets import Distribution.Client.Types +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza @@ -175,10 +176,10 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb - resolverParams + solver + depResolverParams + rparams + inputs -- The packages we want to fetch are those packages the 'InstallPlan' -- that are in the 'InstallPlan.Configured' state. @@ -189,10 +190,23 @@ planPackages ] | otherwise = either (dieWithException verbosity . PlanPackages . unlines . map show) return $ - resolveWithoutDependencies resolverParams + resolveWithoutDependencies depResolverParams where - resolverParams :: DepResolverParams - resolverParams = + solver = getSolver depResolverParams + + -- inputs :: ResolverInputs ModularResolver + inputs = convInputs solver rparams + + rparams :: ResolverParams UnresolvedPkgLoc + rparams = mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams + + depResolverParams :: DepResolverParams + depResolverParams = setMaxBackjumps ( if maxBackjumps < 0 then Nothing diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index ad493eb6aca..cf87ff15553 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -48,6 +48,7 @@ import Distribution.Client.Targets import Distribution.Client.Types import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb @@ -213,15 +214,28 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . FreezeException) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb - resolverParams + solver + depResolverParams + rparams + inputs return $ pruneInstallPlan installPlan pkgSpecifiers where - resolverParams :: DepResolverParams - resolverParams = + solver = getSolver depResolverParams + + -- inputs :: ResolverInputs ModularResolver + inputs = convInputs solver rparams + + rparams :: ResolverParams UnresolvedPkgLoc + rparams = mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams + + depResolverParams :: DepResolverParams + depResolverParams = setMaxBackjumps ( if maxBackjumps < 0 then Nothing diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 1806eab462d..693dafce802 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -126,6 +126,7 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Solver.Types.DependencyResolver import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint @@ -581,13 +582,26 @@ planPackages pkgConfigDb pkgSpecifiers = resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb - resolverParams + solver + depResolverParams + rparams + inputs >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return where - resolverParams = + solver = getSolver depResolverParams + + -- inputs :: ResolverInputs ModularResolver + inputs = convInputs solver rparams + + rparams :: ResolverParams UnresolvedPkgLoc + rparams = mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams + + depResolverParams = setMaxBackjumps ( if maxBackjumps < 0 then Nothing diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 9efc6768807..85f525ad486 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -156,9 +156,11 @@ import Distribution.Utils.Path hiding import qualified Hackage.Security.Client as Sec +import Distribution.Solver.Modular (ModularResolver) import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.IndexConversion import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza @@ -739,7 +741,7 @@ rebuildInstallPlan $ do compilerEtc <- phaseConfigureCompiler projectConfig _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + (solverPlan, pkgConfigDb, totalIndexState, activeRepos) <- phaseRunSolver projectConfig compilerEtc @@ -751,7 +753,7 @@ rebuildInstallPlan phaseElaboratePlan projectConfig compilerEtc - pkgConfigDB + pkgConfigDb solverPlan localPackages @@ -859,7 +861,7 @@ rebuildInstallPlan withRepoCtx (solverSettingIndexState solverSettings) (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb + pkgConfigDb <- getPkgConfigDb verbosity progdb -- TODO: [code cleanup] it'd be better if the Compiler contained the -- ConfiguredPrograms that it needs, rather than relying on the progdb @@ -877,14 +879,14 @@ rebuildInstallPlan solverSettings (installedPackages <> installedPkgIndex) sourcePkgDb - pkgConfigDB + pkgConfigDb localPackages localPackagesEnabledStanzas case planOrError of Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages dieWithException verbosity $ PhaseRunSolverErr msg - Right plan -> return (plan, pkgConfigDB, tis, ar) + Right plan -> return (plan, pkgConfigDb, tis, ar) where sourcePackages :: [SourcePackage UnresolvedPkgLoc] sourcePackages = [pkg | SpecificSourcePackage pkg <- localPackages] @@ -962,7 +964,7 @@ rebuildInstallPlan , projectConfigBuildOnly } (compiler, platform, compilerProgDb) - pkgConfigDB + pkgConfigDb solverPlan localPackages = do liftIO $ debug verbosity "Elaborating the install plan..." @@ -986,7 +988,7 @@ rebuildInstallPlan platform compiler configuredCompilerProgDb - pkgConfigDB + pkgConfigDb distDirLayout cabalStoreDirLayout solverPlan @@ -1396,21 +1398,34 @@ planPackages SolverSettings{..} installedPkgIndex sourcePkgDb - pkgConfigDB + pkgConfigDb localPackages pkgStanzasEnable = resolveDependencies - getSolver - platform - (compilerInfo comp) - pkgConfigDB - resolverParams + solver + depResolverParams + rparams + inputs + where + solver = getSolver depResolverParams + + inputs :: ResolverInputs ModularResolver + inputs = convInputs solver rparams + + rparams :: ResolverParams UnresolvedPkgLoc + rparams = mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams + -- TODO: [nice to have] disable multiple instances restriction in -- the solver, but then make sure we can cope with that in the -- output. - resolverParams :: DepResolverParams - resolverParams = + depResolverParams :: DepResolverParams + depResolverParams = setMaxBackjumps solverSettingMaxBackjumps . setIndependentGoals solverSettingIndependentGoals . setReorderGoals solverSettingReorderGoals @@ -1721,7 +1736,7 @@ elaborateInstallPlan platform compiler compilerProgDb - pkgConfigDB + pkgConfigDb distDirLayout@DistDirLayout{..} storeDirLayout@StoreDirLayout{storePackageDBStack} solverPlan @@ -2108,7 +2123,7 @@ elaborateInstallPlan ++ " from " ++ prettyShow (elabPkgSourceId elab0) ) - (pkgConfigDB >>= \db -> pkgConfigDbPkgVersion db pn) + (pkgConfigDb >>= \db -> pkgConfigDbPkgVersion db pn) ) | PkgconfigDependency pn _ <- PD.pkgconfigDepends diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out b/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out index 9c5de41fa1b..58626b036ea 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRepl/ScriptRerun/cabal.out @@ -5,6 +5,7 @@ In order, the following will be built: - fake-package-0 (interactive) (exe:script-script.hs) (first run) Configuring executable 'script-script.hs' for fake-package-0... # cabal v2-repl +Resolving dependencies... Build profile: -w ghc- -O1 In order, the following will be built: - fake-package-0 (interactive) (exe:script-script.hs) (first run) From 3a08ce13420309afb06f7a7f06ff63cbe1345d49 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 8 Oct 2026 23:35:45 +0200 Subject: [PATCH 14/17] WIP DNC --- .../cabal-install-solver.cabal | 1 + .../src/Distribution/Solver/Modular.hs | 9 ++- .../Solver/Types/DependencyResolver.hs | 10 +++- .../Solver/Types/InstalledPreference.hs | 7 ++- .../Solver/Types/LabeledPackageConstraint.hs | 7 +++ .../Solver/Types/PackageConstraint.hs | 7 ++- .../Solver/Types/PackagePreferences.hs | 7 +++ .../src/Distribution/Client/Dependency.hs | 12 +++- .../Distribution/Client/Dependency/Types.hs | 5 +- .../Distribution/Client/ProjectPlanning.hs | 60 ++++++++++++------- 10 files changed, 91 insertions(+), 34 deletions(-) diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal index c6ebae6c39d..85a63390cb5 100644 --- a/cabal-install-solver/cabal-install-solver.cabal +++ b/cabal-install-solver/cabal-install-solver.cabal @@ -101,6 +101,7 @@ library build-depends: , array >=0.4 && <0.6 , base >=4.17 && <4.24 + , binary >=0.8.9.3 && <0.9 , bytestring >=0.10.6.0 && <0.13 , Cabal ^>=3.19 , Cabal-syntax ^>=3.19 diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 591b55b5e98..e67d198caeb 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -89,7 +89,7 @@ data ModularResolverInputs = { mrCompilerInfo :: CompilerInfo , mrIndex :: Index , mrPkgConfigDb :: Maybe PkgConfigDb - , mrPkgPrefs :: PN -> PackagePreferences + , mrPkgPrefs :: Map PN PackagePreferences , mrPkgConstraints :: Map PN [LabeledPackageConstraint] , mrPkgNames :: Set PN } @@ -198,7 +198,7 @@ solve' :: SolverConfig -> CompilerInfo -> Index -> Maybe PkgConfigDb - -> (PN -> PackagePreferences) + -> Map PN PackagePreferences -> Map PN [LabeledPackageConstraint] -> Set PN -> Progress SummarizedMessage String (Assignment, RevDepMap) @@ -209,7 +209,10 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns = -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs gcs pns + solve sc' cinfo idx pkgConfigDB pprefs' gcs pns + + pprefs' :: PN -> PackagePreferences + pprefs' pn = fromMaybe (error $ "No prefs found for " ++ show pn) $ M.lookup pn pprefs createErrorMsg :: SolverFailure -> RetryLog SummarizedMessage String (Assignment, RevDepMap) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 79c8881ab27..1a9a88fbb12 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -1,11 +1,14 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveAnyClass #-} module Distribution.Solver.Types.DependencyResolver ( ResolverParams (..) , DependencyResolver (..) ) where -import Distribution.Solver.Compat.Prelude ( Maybe, String, Set {-, Binary -}) +import Distribution.Solver.Compat.Prelude + ( Binary, Generic, Maybe, String, Set, Map + ) import Prelude () import Data.Kind @@ -34,10 +37,13 @@ data ResolverParams loc = , rpInstalledPackages :: InstalledPackageIndex , rpSourcePackages :: PackageIndex (SourcePackage loc) , rpPkgConfigDb :: Maybe PkgConfigDb - , rpPkgPrefs :: PackageName -> PackagePreferences + , rpPkgPrefs :: PackagesPreferenceSource , rpPkgConstraints :: [LabeledPackageConstraint] , rpPkgNames :: Set PackageName } + deriving (Generic) + +deriving instance Binary loc => Binary (ResolverParams loc) -- | A dependency resolver consists of a function that works out an -- installation plan given the set of installed and available packages and a diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs index 7aa7215a8fb..4b4ca405424 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + module Distribution.Solver.Types.InstalledPreference ( InstalledPreference(..), ) where import Prelude (Show) +import Data.Binary (Binary) +import GHC.Generics (Generic) -- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest | PreferOldest - deriving Show + deriving (Show, Generic, Binary) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs index 8715e46fd22..50d42f660b8 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -1,14 +1,21 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + module Distribution.Solver.Types.LabeledPackageConstraint ( LabeledPackageConstraint(..) , unlabelPackageConstraint ) where +import GHC.Generics +import Data.Binary (Binary) + import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint -- | 'PackageConstraint' labeled with its source. data LabeledPackageConstraint = LabeledPackageConstraint PackageConstraint ConstraintSource + deriving (Generic, Binary) unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index a37282dbd9b..75b25f2fa01 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + -- | Per-package constraints. Package constraints must be respected by the -- solver. Multiple constraints for each package can be given, though obviously -- it is possible to construct conflicting constraints (eg impossible version @@ -50,7 +53,7 @@ data ConstraintScope -- | The package with the specified name regardless of -- qualifier. | ScopeAnyQualifier PackageName - deriving (Eq, Show) + deriving (Eq, Show, Generic, Binary) -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a @@ -110,7 +113,7 @@ instance Pretty PackageProperty where -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty - deriving (Eq, Show) + deriving (Eq, Show, Generic, Binary) instance Pretty PackageConstraint where pretty (PackageConstraint scope prop) = diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs index 88ee877a0ec..5b05d623d32 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePreferences.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + module Distribution.Solver.Types.PackagePreferences ( PackagePreferences(..) ) where +import GHC.Generics +import Data.Binary (Binary) + import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.OptionalStanza import Distribution.Version (VersionRange) @@ -20,3 +26,4 @@ import Distribution.Version (VersionRange) data PackagePreferences = PackagePreferences [VersionRange] InstalledPreference [OptionalStanza] + deriving (Generic, Binary) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index cc974cb7f49..be2c5e7fa9e 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + ----------------------------------------------------------------------------- -- | @@ -282,6 +285,7 @@ data PackagePreference | -- | If we would prefer to enable these optional stanzas -- (i.e. test suites and/or benchmarks) PackageStanzasPreference PackageName [OptionalStanza] + deriving (Generic, Binary) -- | Provide a textual representation of a package preference -- for debugging purposes. @@ -975,6 +979,10 @@ resolveDependencies solver params rparams inputs = do formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p +type PackagesPreferenceSource = + (Set PackageName, PackagesPreferenceDefault, [PackagePreference]) + deriving (Generic, Binary) + -- | Give an interpretation to the global 'PackagesPreference' as -- specific per-package 'PackageVersionPreference'. interpretPackagesPreference @@ -1380,9 +1388,9 @@ mkResolverParams platform comp installedPkgIndex pkgConfigDB depResolverParams = , rpPkgNames = depResolverTargets depResolverParams } where - pkgPrefs :: PackageName -> PackagePreferences + pkgPrefs :: PackagesPreferenceSource pkgPrefs = - interpretPackagesPreference + PackagesPreferenceSource (depResolverTargets depResolverParams) (depResolverPreferenceDefault depResolverParams) (depResolverPreferences depResolverParams) diff --git a/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal-install/src/Distribution/Client/Dependency/Types.hs index 308e66a025c..ec272b641b0 100644 --- a/cabal-install/src/Distribution/Client/Dependency/Types.hs +++ b/cabal-install/src/Distribution/Client/Dependency/Types.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + module Distribution.Client.Dependency.Types ( PreSolver (..) , Solver (..) @@ -60,4 +63,4 @@ data PackagesPreferenceDefault -- -- * This is the standard policy for install. PreferLatestForSelected - deriving (Show) + deriving (Show, Generic, Binary) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 85f525ad486..ba4c8313d99 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -870,23 +870,24 @@ rebuildInstallPlan liftIO $ do notice verbosity "Resolving dependencies..." - planOrError <- - foldProgress logMsg (pure . Left) (pure . Right) $ - planPackages - verbosity - compiler - platform - solverSettings - (installedPackages <> installedPkgIndex) - sourcePkgDb - pkgConfigDb - localPackages - localPackagesEnabledStanzas - case planOrError of - Left msg -> do - reportPlanningFailure projectConfig compiler platform localPackages - dieWithException verbosity $ PhaseRunSolverErr msg - Right plan -> return (plan, pkgConfigDb, tis, ar) + planOrError <- + planPackages + verbosity + logMsg + distProjectCacheFile + compiler + platform + solverSettings + (installedPackages <> installedPkgIndex) + sourcePkgDb + pkgConfigDb + localPackages + localPackagesEnabledStanzas + liftIO $ case planOrError of + Left msg -> do + reportPlanningFailure projectConfig compiler platform localPackages + dieWithException verbosity $ PhaseRunSolverErr msg + Right plan -> return (plan, pkgConfigDb, tis, ar) where sourcePackages :: [SourcePackage UnresolvedPkgLoc] sourcePackages = [pkg | SpecificSourcePackage pkg <- localPackages] @@ -1382,6 +1383,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do planPackages :: Verbosity + -> (String -> IO (Either String SolverInstallPlan) -> IO (Either String SolverInstallPlan)) + -> (String -> FilePath) -> Compiler -> Platform -> SolverSettings @@ -1390,9 +1393,11 @@ planPackages -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Map PackageName (Map OptionalStanza Bool) - -> Progress String String SolverInstallPlan + -> Rebuild (Either String SolverInstallPlan) planPackages verbosity + logMsg + distProjectCacheFile comp platform SolverSettings{..} @@ -1401,13 +1406,22 @@ planPackages pkgConfigDb localPackages pkgStanzasEnable = - resolveDependencies - solver - depResolverParams - rparams - inputs + rerunIfChanged + verbosity + fileMonitorResolverInputs + fileMonitorResolverInputsKey $ do + liftIO $ + foldProgress logMsg (pure . Left) (pure . Right) $ + resolveDependencies + solver + depResolverParams + rparams + inputs where + fileMonitorResolverInputs = newFileMonitor (distProjectCacheFile "rinputs") + fileMonitorResolverInputsKey = (rparams, inputs) + solver = getSolver depResolverParams inputs :: ResolverInputs ModularResolver From 54649f106eea536b3e549a031d53545761284de4 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 13 Oct 2026 13:21:25 +0200 Subject: [PATCH 15/17] Fix the bug --- Cabal-syntax/src/Distribution/Compiler.hs | 3 +- .../src/Distribution/Solver/Modular.hs | 19 +-- .../Solver/Types/DependencyResolver.hs | 130 +++++++++++++++++- .../Solver/Types/InstalledPreference.hs | 6 +- .../Solver/Types/LabeledPackageConstraint.hs | 3 +- .../Solver/Types/PackageConstraint.hs | 4 +- .../Distribution/Solver/Types/PackageIndex.hs | 1 + .../Distribution/Solver/Types/PkgConfigDb.hs | 2 +- .../src/Distribution/Client/Dependency.hs | 96 +------------ .../Distribution/Client/Dependency/Types.hs | 26 ---- 10 files changed, 155 insertions(+), 135 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 311410c0abb..7e4ad9b41a2 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -215,9 +215,10 @@ data CompilerInfo = CompilerInfo -- For instance, when using GHC plugins, one wants to use the exact same -- version of the `ghc` package as the one the compiler was linked against. } - deriving (Generic, Show, Read) + deriving (Generic, Show, Read, Eq) instance Binary CompilerInfo +instance Structured CompilerInfo data AbiTag = NoAbiTag diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index e67d198caeb..da3730fb37c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveAnyClass #-} module Distribution.Solver.Modular ( ModularResolver (..) @@ -55,7 +56,11 @@ import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Solver ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) import Distribution.Solver.Types.DependencyResolver - ( DependencyResolver (..), ResolverParams (..) ) + ( DependencyResolver (..) + , ResolverParams (..) + , PackagesPreferenceSource + , interpretPackagesPreference + ) import Distribution.Solver.Types.LabeledPackageConstraint ( LabeledPackageConstraint, unlabelPackageConstraint ) import Distribution.Solver.Types.PackageConstraint @@ -89,10 +94,11 @@ data ModularResolverInputs = { mrCompilerInfo :: CompilerInfo , mrIndex :: Index , mrPkgConfigDb :: Maybe PkgConfigDb - , mrPkgPrefs :: Map PN PackagePreferences + , mrPkgPrefs :: PackagesPreferenceSource , mrPkgConstraints :: Map PN [LabeledPackageConstraint] , mrPkgNames :: Set PN } + deriving (Generic, Eq, Binary, Structured) instance DependencyResolver ModularResolver where type ResolverInputs ModularResolver = ModularResolverInputs @@ -103,7 +109,7 @@ instance DependencyResolver ModularResolver where (mrCompilerInfo inputs) (mrIndex inputs) (mrPkgConfigDb inputs) - (mrPkgPrefs inputs) + (interpretPackagesPreference $ mrPkgPrefs inputs) (mrPkgConstraints inputs) (mrPkgNames inputs) convInputs mr rp = @@ -198,7 +204,7 @@ solve' :: SolverConfig -> CompilerInfo -> Index -> Maybe PkgConfigDb - -> Map PN PackagePreferences + -> (PN -> PackagePreferences) -> Map PN [LabeledPackageConstraint] -> Set PN -> Progress SummarizedMessage String (Assignment, RevDepMap) @@ -209,10 +215,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns = -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs' gcs pns - - pprefs' :: PN -> PackagePreferences - pprefs' pn = fromMaybe (error $ "No prefs found for " ++ show pn) $ M.lookup pn pprefs + solve sc' cinfo idx pkgConfigDB pprefs gcs pns createErrorMsg :: SolverFailure -> RetryLog SummarizedMessage String (Assignment, RevDepMap) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 1a9a88fbb12..f2d910d398f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -4,20 +4,33 @@ module Distribution.Solver.Types.DependencyResolver ( ResolverParams (..) , DependencyResolver (..) + , PackagePreference (..) + , PackagesPreferenceSource + , PackagesPreferenceDefault (..) + , showPackagePreference + , interpretPackagesPreference ) where import Distribution.Solver.Compat.Prelude - ( Binary, Generic, Maybe, String, Set, Map + ( Binary, Generic, Structured, Maybe, String, Set, Eq + , Show (show) + , (++) + , const ) import Prelude () import Data.Kind +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Distribution.Solver.Types.InstalledPreference + ( InstalledPreference ) +import qualified Distribution.Solver.Types.InstalledPreference as Preference import Distribution.Solver.Types.LabeledPackageConstraint ( LabeledPackageConstraint ) +import Distribution.Solver.Types.OptionalStanza ( OptionalStanza ) import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) -import Distribution.Solver.Types.PackagePreferences - ( PackagePreferences ) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) +import Distribution.Solver.Types.PackagePreferences ( PackagePreferences (..) ) import Distribution.Solver.Types.Progress ( Progress ) import Distribution.Solver.Types.ResolverPackage @@ -29,6 +42,10 @@ import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import Distribution.Package ( PackageName ) import Distribution.Compiler ( CompilerInfo ) import Distribution.System ( Platform ) +import Distribution.Types.VersionRange ( VersionRange, anyVersion ) +import Distribution.Pretty ( prettyShow ) +import Distribution.Version ( simplifyVersionRange ) +import Distribution.Utils.Generic ( ordNub ) data ResolverParams loc = ResolverParams @@ -44,6 +61,113 @@ data ResolverParams loc = deriving (Generic) deriving instance Binary loc => Binary (ResolverParams loc) +deriving instance Structured loc => Structured (ResolverParams loc) +deriving instance Eq loc => Eq (ResolverParams loc) + +type PackagesPreferenceSource = + (Set PackageName, PackagesPreferenceDefault, [PackagePreference]) + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +interpretPackagesPreference + :: PackagesPreferenceSource + -> (PackageName -> PackagePreferences) +interpretPackagesPreference (selected, defaultPref, prefs) = + \pkgname -> + PackagePreferences + (versionPref pkgname) + (installPref pkgname) + (stanzasPref pkgname) + where + versionPref :: PackageName -> [VersionRange] + versionPref pkgname = + Map.findWithDefault [anyVersion] pkgname versionPrefs + versionPrefs = + Map.fromListWith + (++) + [ (pkgname, [pref]) + | PackageVersionPreference pkgname pref <- prefs + ] + + installPref :: PackageName -> InstalledPreference + installPref pkgname = + Map.findWithDefault (installPrefDefault pkgname) pkgname installPrefs + installPrefs = + Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs + ] + installPrefDefault = case defaultPref of + PreferAllLatest -> const Preference.PreferLatest + PreferAllOldest -> const Preference.PreferOldest + PreferAllInstalled -> const Preference.PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else + if pkgname `Set.member` selected + then Preference.PreferLatest + else Preference.PreferInstalled + + stanzasPref :: PackageName -> [OptionalStanza] + stanzasPref pkgname = + Map.findWithDefault [] pkgname stanzasPrefs + stanzasPrefs = + Map.fromListWith + (\a b -> ordNub (a ++ b)) + [ (pkgname, pref) + | PackageStanzasPreference pkgname pref <- prefs + ] + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +data PackagesPreferenceDefault + = -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- * This is enabled by --prefer-version=latest for install + PreferAllLatest + | -- | Always prefer the oldest version irrespective of any existing + -- installed version or packages explicitly requested. + -- + -- * This is enabled by --prefer-version=oldest for install. + PreferAllOldest + | -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest source version). + PreferAllInstalled + | -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + PreferLatestForSelected + deriving (Show, Eq, Generic, Binary, Structured) + +-- | A package selection preference for a particular package. +-- +-- Preferences are soft constraints that the dependency resolver should try to +-- respect where possible. It is not specified if preferences on some packages +-- are more important than others. +data PackagePreference + = -- | A suggested constraint on the version number. + PackageVersionPreference PackageName VersionRange + | -- | If we prefer versions of packages that are already installed. + PackageInstalledPreference PackageName InstalledPreference + | -- | If we would prefer to enable these optional stanzas + -- (i.e. test suites and/or benchmarks) + PackageStanzasPreference PackageName [OptionalStanza] + deriving (Show, Eq, Generic, Binary, Structured) + +-- | Provide a textual representation of a package preference +-- for debugging purposes. +showPackagePreference :: PackagePreference -> String +showPackagePreference (PackageVersionPreference pn vr) = + prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) +showPackagePreference (PackageInstalledPreference pn ip) = + prettyShow pn ++ " " ++ show ip +showPackagePreference (PackageStanzasPreference pn st) = + prettyShow pn ++ " " ++ show st + -- | A dependency resolver consists of a function that works out an -- installation plan given the set of installed and available packages and a diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs index 4b4ca405424..772e219aee5 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstalledPreference.hs @@ -5,12 +5,14 @@ module Distribution.Solver.Types.InstalledPreference ( InstalledPreference(..), ) where -import Prelude (Show) +import Prelude (Show, Eq) import Data.Binary (Binary) import GHC.Generics (Generic) +import Distribution.Utils.Structured + -- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest | PreferOldest - deriving (Show, Generic, Binary) + deriving (Show, Eq, Generic, Binary, Structured) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs index 50d42f660b8..5f256b7a6cf 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -11,11 +11,12 @@ import Data.Binary (Binary) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint +import Distribution.Utils.Structured -- | 'PackageConstraint' labeled with its source. data LabeledPackageConstraint = LabeledPackageConstraint PackageConstraint ConstraintSource - deriving (Generic, Binary) + deriving (Generic, Eq, Binary, Structured) unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 75b25f2fa01..a09a43bac97 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -53,7 +53,7 @@ data ConstraintScope -- | The package with the specified name regardless of -- qualifier. | ScopeAnyQualifier PackageName - deriving (Eq, Show, Generic, Binary) + deriving (Eq, Show, Generic, Binary, Structured) -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a @@ -113,7 +113,7 @@ instance Pretty PackageProperty where -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty - deriving (Eq, Show, Generic, Binary) + deriving (Eq, Show, Generic, Binary, Structured) instance Pretty PackageConstraint where pretty (PackageConstraint scope prop) = diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs index 04b9b41aa7f..3dcd7d71ebf 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageIndex.hs @@ -90,6 +90,7 @@ instance Package pkg => Monoid (PackageIndex pkg) where mconcat xs = Prelude.foldr1 (<>) xs instance Binary pkg => Binary (PackageIndex pkg) +instance Structured pkg => Structured (PackageIndex pkg) invariant :: Package pkg => PackageIndex pkg -> Bool invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs index 7e0c8526384..885c8f36bf6 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -48,7 +48,7 @@ import Distribution.Verbosity (Verbosity) -- but we don't know the exact version (because parsing of the version number -- failed). newtype PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) - deriving (Show, Generic) + deriving (Show, Generic, Eq) instance Binary PkgConfigDb instance Structured PkgConfigDb diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index be2c5e7fa9e..611823ee345 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -79,9 +79,6 @@ module Distribution.Client.Dependency import Distribution.Client.Compat.Prelude -import Distribution.Client.Dependency.Types - ( PackagesPreferenceDefault (..) - ) import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Types @@ -155,7 +152,6 @@ import Distribution.Verbosity ) import Distribution.Version -import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource @@ -272,31 +268,6 @@ showDepResolverParams p = showLabeledConstraint (LabeledPackageConstraint pc src) = showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" --- | A package selection preference for a particular package. --- --- Preferences are soft constraints that the dependency resolver should try to --- respect where possible. It is not specified if preferences on some packages --- are more important than others. -data PackagePreference - = -- | A suggested constraint on the version number. - PackageVersionPreference PackageName VersionRange - | -- | If we prefer versions of packages that are already installed. - PackageInstalledPreference PackageName InstalledPreference - | -- | If we would prefer to enable these optional stanzas - -- (i.e. test suites and/or benchmarks) - PackageStanzasPreference PackageName [OptionalStanza] - deriving (Generic, Binary) - --- | Provide a textual representation of a package preference --- for debugging purposes. -showPackagePreference :: PackagePreference -> String -showPackagePreference (PackageVersionPreference pn vr) = - prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr) -showPackagePreference (PackageInstalledPreference pn ip) = - prettyShow pn ++ " " ++ show ip -showPackagePreference (PackageStanzasPreference pn st) = - prettyShow pn ++ " " ++ show st - basicDepResolverParams :: InstalledPackageIndex -> PackageIndex.PackageIndex UnresolvedSourcePackage @@ -979,63 +950,6 @@ resolveDependencies solver params rparams inputs = do formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p -type PackagesPreferenceSource = - (Set PackageName, PackagesPreferenceDefault, [PackagePreference]) - deriving (Generic, Binary) - --- | Give an interpretation to the global 'PackagesPreference' as --- specific per-package 'PackageVersionPreference'. -interpretPackagesPreference - :: Set PackageName - -> PackagesPreferenceDefault - -> [PackagePreference] - -> (PackageName -> PackagePreferences) -interpretPackagesPreference selected defaultPref prefs = - \pkgname -> - PackagePreferences - (versionPref pkgname) - (installPref pkgname) - (stanzasPref pkgname) - where - versionPref :: PackageName -> [VersionRange] - versionPref pkgname = - Map.findWithDefault [anyVersion] pkgname versionPrefs - versionPrefs = - Map.fromListWith - (++) - [ (pkgname, [pref]) - | PackageVersionPreference pkgname pref <- prefs - ] - - installPref :: PackageName -> InstalledPreference - installPref pkgname = - Map.findWithDefault (installPrefDefault pkgname) pkgname installPrefs - installPrefs = - Map.fromList - [ (pkgname, pref) - | PackageInstalledPreference pkgname pref <- prefs - ] - installPrefDefault = case defaultPref of - PreferAllLatest -> const Preference.PreferLatest - PreferAllOldest -> const Preference.PreferOldest - PreferAllInstalled -> const Preference.PreferInstalled - PreferLatestForSelected -> \pkgname -> - -- When you say cabal install foo, what you really mean is, prefer the - -- latest version of foo, but the installed version of everything else - if pkgname `Set.member` selected - then Preference.PreferLatest - else Preference.PreferInstalled - - stanzasPref :: PackageName -> [OptionalStanza] - stanzasPref pkgname = - Map.findWithDefault [] pkgname stanzasPrefs - stanzasPrefs = - Map.fromListWith - (\a b -> ordNub (a ++ b)) - [ (pkgname, pref) - | PackageStanzasPreference pkgname pref <- prefs - ] - -- ------------------------------------------------------------ -- * Checking the result of the solver @@ -1348,7 +1262,7 @@ resolveWithoutDependencies ] packagePreferences :: PackageName -> PackagePreferences - packagePreferences = interpretPackagesPreference targets defpref prefs + packagePreferences = interpretPackagesPreference (targets, defpref, prefs) collectEithers :: [Either a b] -> Either [a] [b] collectEithers = collect . partitionEithers @@ -1390,7 +1304,7 @@ mkResolverParams platform comp installedPkgIndex pkgConfigDB depResolverParams = where pkgPrefs :: PackagesPreferenceSource pkgPrefs = - PackagesPreferenceSource - (depResolverTargets depResolverParams) - (depResolverPreferenceDefault depResolverParams) - (depResolverPreferences depResolverParams) + ( depResolverTargets depResolverParams + , depResolverPreferenceDefault depResolverParams + , depResolverPreferences depResolverParams + ) diff --git a/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal-install/src/Distribution/Client/Dependency/Types.hs index ec272b641b0..152081bd52a 100644 --- a/cabal-install/src/Distribution/Client/Dependency/Types.hs +++ b/cabal-install/src/Distribution/Client/Dependency/Types.hs @@ -4,7 +4,6 @@ module Distribution.Client.Dependency.Types ( PreSolver (..) , Solver (..) - , PackagesPreferenceDefault (..) ) where import Distribution.Client.Compat.Prelude @@ -39,28 +38,3 @@ instance Parsec PreSolver where case map toLower name of "modular" -> return AlwaysModular _ -> P.unexpected $ "PreSolver: " ++ name - --- | Global policy for all packages to say if we prefer package versions that --- are already installed locally or if we just prefer the latest available. -data PackagesPreferenceDefault - = -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- * This is enabled by --prefer-version=latest for install - PreferAllLatest - | -- | Always prefer the oldest version irrespective of any existing - -- installed version or packages explicitly requested. - -- - -- * This is enabled by --prefer-version=oldest for install. - PreferAllOldest - | -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest source version). - PreferAllInstalled - | -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - PreferLatestForSelected - deriving (Show, Generic, Binary) From 93fe0f7ea9566c0af845240a14f6ba2f9445fa97 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 13 Oct 2026 19:55:33 +0200 Subject: [PATCH 16/17] HLint --- cabal-install/src/Distribution/Client/Dependency.hs | 3 --- cabal-install/src/Distribution/Client/Dependency/Types.hs | 1 - 2 files changed, 4 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 611823ee345..a02aac6d61a 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} - ----------------------------------------------------------------------------- -- | diff --git a/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal-install/src/Distribution/Client/Dependency/Types.hs index 152081bd52a..94068b94af1 100644 --- a/cabal-install/src/Distribution/Client/Dependency/Types.hs +++ b/cabal-install/src/Distribution/Client/Dependency/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} module Distribution.Client.Dependency.Types ( PreSolver (..) From d4c8b47d897c8a9ae378cf7e16744cf2cd51d16c Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 13 Oct 2026 19:59:52 +0200 Subject: [PATCH 17/17] Fourmolu --- .../src/Distribution/Client/Configure.hs | 13 +- .../src/Distribution/Client/Dependency.hs | 128 +++++++++--------- .../src/Distribution/Client/Fetch.hs | 15 +- .../src/Distribution/Client/Freeze.hs | 13 +- .../src/Distribution/Client/Install.hs | 15 +- .../Distribution/Client/ProjectPlanning.hs | 27 ++-- 6 files changed, 110 insertions(+), 101 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 5db0e69380e..a31e3d5454b 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -479,12 +479,13 @@ planLocalPackage inputs = convInputs solver rparams -- rparams :: ResolverParams UnresolvedPkgLoc - rparams = mkResolverParams - platform - (compilerInfo comp) - installedPkgIndex - pkgConfigDb - depResolverParams + rparams = + mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams return $ resolveDependencies diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index a02aac6d61a..eaa2002a2c8 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -20,7 +20,8 @@ module Distribution.Client.Dependency , foldProgress -- * Converting to and from resolver-specific representations of inputs and - -- outputs + + -- outputs , getSolver , getFinalParams , getSolverConfig @@ -123,20 +124,20 @@ import Distribution.Simple.Setup ( asBool ) import Distribution.Solver.Modular - ( PruneAfterFirstSuccess (..) + ( ModularResolver + , PruneAfterFirstSuccess (..) , SolverConfig (..) , modularResolver - , ModularResolver ) import Distribution.Solver.Modular.Message ( renderSummarizedMessage ) -import Distribution.Solver.Types.SummarizedMessage - ( SummarizedMessage (..) - ) import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) +import Distribution.Solver.Types.SummarizedMessage + ( SummarizedMessage (..) + ) import Distribution.System ( Platform ) @@ -844,45 +845,45 @@ getFinalParams comp params = getSolverConfig :: DepResolverParams -> SolverConfig getSolverConfig - (DepResolverParams - _targets - _constraints - _prefs - _defpref - _installedPkgIndex - _sourcePkgIndex - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - _allowBootLibs - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity) = - - SolverConfig - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity - (PruneAfterFirstSuccess False) + ( DepResolverParams + _targets + _constraints + _prefs + _defpref + _installedPkgIndex + _sourcePkgIndex + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + _allowBootLibs + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + ) = + SolverConfig + reordGoals + cntConflicts + fineGrained + minimize + indGoals + noReinstalls + shadowing + strFlags + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + (PruneAfterFirstSuccess False) -- solver = getSolver config -- rparams = ResolverParams @@ -895,7 +896,7 @@ getSolverConfig -- constraints -- targets -- inputs = convInputs solver rparams --- +-- -- preferences :: PackageName -> PackagePreferences -- preferences = interpretPackagesPreference targets defpref prefs @@ -917,8 +918,10 @@ resolveDependencies solver params rparams inputs = do formatProgress $ convOutput solver rparams <$> runResolver solver inputs validateSolverResult - (rpPlatform rparams) - (rpCompilerInfo rparams) indGoals pkgs + (rpPlatform rparams) + (rpCompilerInfo rparams) + indGoals + pkgs where DepResolverParams _targets @@ -941,8 +944,8 @@ resolveDependencies solver params rparams inputs = do _enableBj _solveExes _order - _verbosity - = params + _verbosity = + params formatProgress :: Progress SummarizedMessage String a -> Progress String String a formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p @@ -1281,12 +1284,13 @@ instance Show ResolveNoDepsError where ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver) -mkResolverParams :: Platform - -> CompilerInfo - -> InstalledPackageIndex - -> Maybe PkgConfigDb - -> DepResolverParams - -> ResolverParams UnresolvedPkgLoc +mkResolverParams + :: Platform + -> CompilerInfo + -> InstalledPackageIndex + -> Maybe PkgConfigDb + -> DepResolverParams + -> ResolverParams UnresolvedPkgLoc mkResolverParams platform comp installedPkgIndex pkgConfigDB depResolverParams = ResolverParams { rpPlatform = platform @@ -1299,9 +1303,9 @@ mkResolverParams platform comp installedPkgIndex pkgConfigDB depResolverParams = , rpPkgNames = depResolverTargets depResolverParams } where - pkgPrefs :: PackagesPreferenceSource - pkgPrefs = - ( depResolverTargets depResolverParams - , depResolverPreferenceDefault depResolverParams - , depResolverPreferences depResolverParams - ) + pkgPrefs :: PackagesPreferenceSource + pkgPrefs = + ( depResolverTargets depResolverParams + , depResolverPreferenceDefault depResolverParams + , depResolverPreferences depResolverParams + ) diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 66ecccd8053..4fd12aa422a 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -32,8 +32,8 @@ import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Targets import Distribution.Client.Types -import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) @@ -198,12 +198,13 @@ planPackages inputs = convInputs solver rparams rparams :: ResolverParams UnresolvedPkgLoc - rparams = mkResolverParams - platform - (compilerInfo comp) - installedPkgIndex - pkgConfigDb - depResolverParams + rparams = + mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams depResolverParams :: DepResolverParams depResolverParams = diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index cf87ff15553..37daef284fc 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -227,12 +227,13 @@ planPackages inputs = convInputs solver rparams rparams :: ResolverParams UnresolvedPkgLoc - rparams = mkResolverParams - platform - (compilerInfo comp) - installedPkgIndex - pkgConfigDb - depResolverParams + rparams = + mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams depResolverParams :: DepResolverParams depResolverParams = diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 693dafce802..d1e9c2f677c 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -126,9 +126,9 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.DependencyResolver import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex @@ -594,12 +594,13 @@ planPackages inputs = convInputs solver rparams rparams :: ResolverParams UnresolvedPkgLoc - rparams = mkResolverParams - platform - (compilerInfo comp) - installedPkgIndex - pkgConfigDb - depResolverParams + rparams = + mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams depResolverParams = setMaxBackjumps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ba4c8313d99..e8f5003c82a 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1406,18 +1406,18 @@ planPackages pkgConfigDb localPackages pkgStanzasEnable = - rerunIfChanged - verbosity - fileMonitorResolverInputs - fileMonitorResolverInputsKey $ do - liftIO $ - foldProgress logMsg (pure . Left) (pure . Right) $ + rerunIfChanged + verbosity + fileMonitorResolverInputs + fileMonitorResolverInputsKey + $ do + liftIO $ + foldProgress logMsg (pure . Left) (pure . Right) $ resolveDependencies solver depResolverParams rparams inputs - where fileMonitorResolverInputs = newFileMonitor (distProjectCacheFile "rinputs") fileMonitorResolverInputsKey = (rparams, inputs) @@ -1428,12 +1428,13 @@ planPackages inputs = convInputs solver rparams rparams :: ResolverParams UnresolvedPkgLoc - rparams = mkResolverParams - platform - (compilerInfo comp) - installedPkgIndex - pkgConfigDb - depResolverParams + rparams = + mkResolverParams + platform + (compilerInfo comp) + installedPkgIndex + pkgConfigDb + depResolverParams -- TODO: [nice to have] disable multiple instances restriction in -- the solver, but then make sure we can cope with that in the