From 20489a78afa5ead536598ffb3f469684a224a072 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 6 Mar 2025 17:54:46 +0800 Subject: [PATCH 001/122] feat(Cabal,Cabal-syntax): add per-file options to extra source files --- Cabal-described/src/Distribution/Described.hs | 10 ++- Cabal-syntax/Cabal-syntax.cabal | 1 + .../src/Distribution/PackageDescription.hs | 4 ++ .../PackageDescription/FieldGrammar.hs | 19 ++++-- .../src/Distribution/Types/BuildInfo.hs | 20 +++--- .../src/Distribution/Types/BuildInfo/Lens.hs | 13 ++-- .../src/Distribution/Types/ExtraSource.hs | 48 +++++++++++++ Cabal-tests/tests/NoThunks.hs | 2 + .../Distribution/Utils/Structured.hs | 4 +- .../src/Data/TreeDiff/Instances/Cabal.hs | 2 + .../PackageDescription/Check/Target.hs | 14 ++-- Cabal/src/Distribution/Simple/Build.hs | 20 +++--- Cabal/src/Distribution/Simple/BuildTarget.hs | 10 +-- .../Simple/GHC/Build/ExtraSources.hs | 63 +++++++++-------- Cabal/src/Distribution/Simple/GHC/Internal.hs | 68 ++++++------------- Cabal/src/Distribution/Simple/GHCJS.hs | 30 ++++---- Cabal/src/Distribution/Simple/SrcDist.hs | 10 +-- .../src/Distribution/Client/SourceFiles.hs | 11 +-- .../src/Distribution/Client/TargetSelector.hs | 5 +- cabal-install/tests/IntegrationTests2.hs | 4 +- .../PackageTests/ExtraSources/cbits/test.c | 3 + .../ExtraSources/extra-sources.cabal | 10 +++ .../PackageTests/ExtraSources/setup.out | 5 ++ .../PackageTests/ExtraSources/setup.test.hs | 5 ++ .../PackageTests/ExtraSources/src/MyLib.hs | 4 ++ 25 files changed, 237 insertions(+), 148 deletions(-) create mode 100644 Cabal-syntax/src/Distribution/Types/ExtraSource.hs create mode 100644 cabal-testsuite/PackageTests/ExtraSources/cbits/test.c create mode 100644 cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal create mode 100644 cabal-testsuite/PackageTests/ExtraSources/setup.out create mode 100644 cabal-testsuite/PackageTests/ExtraSources/setup.test.hs create mode 100644 cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index 231111af1e4..e54eb5af099 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} module Distribution.Described ( Described (..), describeDoc, @@ -79,6 +80,7 @@ import Distribution.Types.Dependency (Dependency) import Distribution.Types.ExecutableScope (ExecutableScope) import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.ExposedModule (ExposedModule) +import Distribution.Types.ExtraSource (ExtraSource) import Distribution.Types.Flag (FlagAssignment, FlagName) import Distribution.Types.ForeignLib (LibVersionInfo) import Distribution.Types.ForeignLibOption (ForeignLibOption) @@ -98,7 +100,7 @@ import Distribution.Types.SourceRepo (RepoType) import Distribution.Types.TestType (TestType) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Utils.Path (SymbolicPath, RelativePath) +import Distribution.Utils.Path (SymbolicPath, RelativePath, FileOrDir(..), Pkg) import Distribution.Verbosity (Verbosity) import Distribution.Version (Version, VersionRange) import Language.Haskell.Extension (Extension, Language, knownLanguages) @@ -405,6 +407,12 @@ instance Described ExposedModule where instance Described Extension where describe _ = RETodo +instance Described ExtraSource where + describe _ = REAppend + [ describe (Proxy :: Proxy (SymbolicPath Pkg File)) + , REOpt (reChar '(' <> reSpacedList (describe (Proxy :: Proxy Token')) <> reChar ')') + ] + instance Described FlagAssignment where describe _ = REMunch RESpaces1 $ REUnion [fromString "+", fromString "-"] <> describe (Proxy :: Proxy FlagName) diff --git a/Cabal-syntax/Cabal-syntax.cabal b/Cabal-syntax/Cabal-syntax.cabal index 85137dc147c..b10bb93c020 100644 --- a/Cabal-syntax/Cabal-syntax.cabal +++ b/Cabal-syntax/Cabal-syntax.cabal @@ -141,6 +141,7 @@ library Distribution.Types.Executable Distribution.Types.Executable.Lens Distribution.Types.ExecutableScope + Distribution.Types.ExtraSource Distribution.Types.ExposedModule Distribution.Types.Flag Distribution.Types.ForeignLib diff --git a/Cabal-syntax/src/Distribution/PackageDescription.hs b/Cabal-syntax/src/Distribution/PackageDescription.hs index 47d46673e5f..85b8c8943b8 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription.hs @@ -48,6 +48,9 @@ module Distribution.PackageDescription , module Distribution.Types.HookedBuildInfo , module Distribution.Types.SetupBuildInfo + -- * Extra sources + , module Distribution.Types.ExtraSource + -- * Flags , module Distribution.Types.Flag @@ -99,6 +102,7 @@ import Distribution.Types.Dependency import Distribution.Types.ExeDependency import Distribution.Types.Executable import Distribution.Types.ExecutableScope +import Distribution.Types.ExtraSource import Distribution.Types.Flag import Distribution.Types.ForeignLib import Distribution.Types.ForeignLibOption diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 24861389b8f..5aa64f08e82 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -174,6 +174,7 @@ libraryFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) + , c (List VCat (Identity ExtraSource) ExtraSource) , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) @@ -224,6 +225,7 @@ foreignLibFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) + , c (List VCat (Identity ExtraSource) ExtraSource) , c (List FSep (Identity ForeignLibOption) ForeignLibOption) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) @@ -263,6 +265,7 @@ executableFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) + , c (List VCat (Identity ExtraSource) ExtraSource) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -339,6 +342,7 @@ testSuiteFieldGrammar , c (List CommaFSep Token String) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) + , c (List VCat (Identity ExtraSource) ExtraSource) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -483,6 +487,7 @@ benchmarkFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) + , c (List VCat (Identity ExtraSource) ExtraSource) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -585,6 +590,7 @@ buildInfoFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) + , c (List VCat (Identity ExtraSource) ExtraSource) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -629,14 +635,14 @@ buildInfoFieldGrammar = <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends <*> monoidalFieldAla "frameworks" (alaList' FSep RelativePathNT) L.frameworks <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep SymbolicPathNT) L.extraFrameworkDirs - <*> monoidalFieldAla "asm-sources" (alaList' VCat SymbolicPathNT) L.asmSources + <*> monoidalFieldAla "asm-sources" formatExtraSources L.asmSources ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-sources" (alaList' VCat SymbolicPathNT) L.cmmSources + <*> monoidalFieldAla "cmm-sources" formatExtraSources L.cmmSources ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "c-sources" (alaList' VCat SymbolicPathNT) L.cSources - <*> monoidalFieldAla "cxx-sources" (alaList' VCat SymbolicPathNT) L.cxxSources + <*> monoidalFieldAla "c-sources" formatExtraSources L.cSources + <*> monoidalFieldAla "cxx-sources" formatExtraSources L.cxxSources ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "js-sources" (alaList' VCat SymbolicPathNT) L.jsSources + <*> monoidalFieldAla "js-sources" formatExtraSources L.jsSources <*> hsSourceDirsGrammar <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules @@ -836,6 +842,9 @@ formatOtherExtensions = alaList' FSep MQuoted formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName formatOtherModules = alaList' VCat MQuoted +formatExtraSources :: [ExtraSource] -> List VCat (Identity ExtraSource) ExtraSource +formatExtraSources = alaList' VCat Identity + ------------------------------------------------------------------------------- -- newtypes ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index e68fcbc5c22..5ef5ee7f422 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -21,6 +21,7 @@ import Prelude () import Distribution.Types.Dependency import Distribution.Types.ExeDependency +import Distribution.Types.ExtraSource import Distribution.Types.LegacyExeDependency import Distribution.Types.Mixin import Distribution.Types.PkgconfigDependency @@ -72,14 +73,17 @@ data BuildInfo = BuildInfo , frameworks :: [RelativePath Framework File] -- ^ support frameworks for Mac OS X , extraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)] - -- ^ extra locations to find frameworks. - , asmSources :: [SymbolicPath Pkg File] - -- ^ Assembly files. - , cmmSources :: [SymbolicPath Pkg File] - -- ^ C-- files. - , cSources :: [SymbolicPath Pkg File] - , cxxSources :: [SymbolicPath Pkg File] - , jsSources :: [SymbolicPath Pkg File] + -- ^ extra locations to find frameworks + , asmSources :: [ExtraSource] + -- ^ Assembly source files + , cmmSources :: [ExtraSource] + -- ^ C-- source files + , cSources :: [ExtraSource] + -- ^ C source files + , cxxSources :: [ExtraSource] + -- ^ C++ source files + , jsSources :: [ExtraSource] + -- ^ JavaScript source file , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] -- ^ where to look for the Haskell module hierarchy , -- NB: these are symbolic paths are not relative paths, diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 72a24caa734..a10115a4b36 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -15,6 +15,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.Types.BuildInfo (BuildInfo) import Distribution.Types.Dependency (Dependency) import Distribution.Types.ExeDependency (ExeDependency) +import Distribution.Types.ExtraSource (ExtraSource) import Distribution.Types.LegacyExeDependency (LegacyExeDependency) import Distribution.Types.Mixin (Mixin) import Distribution.Types.PkgconfigDependency (PkgconfigDependency) @@ -83,23 +84,23 @@ class HasBuildInfo a where extraFrameworkDirs = buildInfo . extraFrameworkDirs {-# INLINE extraFrameworkDirs #-} - asmSources :: Lens' a [SymbolicPath Pkg File] + asmSources :: Lens' a [ExtraSource] asmSources = buildInfo . asmSources {-# INLINE asmSources #-} - cmmSources :: Lens' a [SymbolicPath Pkg File] + cmmSources :: Lens' a [ExtraSource] cmmSources = buildInfo . cmmSources {-# INLINE cmmSources #-} - cSources :: Lens' a [SymbolicPath Pkg File] + cSources :: Lens' a [ExtraSource] cSources = buildInfo . cSources {-# INLINE cSources #-} - cxxSources :: Lens' a [SymbolicPath Pkg File] + cxxSources :: Lens' a [ExtraSource] cxxSources = buildInfo . cxxSources {-# INLINE cxxSources #-} - jsSources :: Lens' a [SymbolicPath Pkg File] + jsSources :: Lens' a [ExtraSource] jsSources = buildInfo . jsSources {-# INLINE jsSources #-} @@ -274,7 +275,7 @@ instance HasBuildInfo BuildInfo where cSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cSources s)) {-# INLINE cSources #-} - cxxSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cxxSources s)) + cxxSources f s = fmap (\x -> s{T.cxxSources = x}) (f (T.cxxSources s)) {-# INLINE cxxSources #-} jsSources f s = fmap (\x -> s{T.jsSources = x}) (f (T.jsSources s)) diff --git a/Cabal-syntax/src/Distribution/Types/ExtraSource.hs b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs new file mode 100644 index 00000000000..354fa00e9fb --- /dev/null +++ b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.ExtraSource + ( ExtraSource (..) + , extraSourceFromPath + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Path (FileOrDir (..), Pkg, SymbolicPath) + +import qualified Distribution.Compat.CharParsing as P +import Distribution.FieldGrammar.Newtypes (SymbolicPathNT (..)) +import qualified Text.PrettyPrint as PP + +data ExtraSource = ExtraSource + { extraSourceFile :: SymbolicPath Pkg File + , extraSourceOpts :: [String] + } + deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) + +instance Binary ExtraSource +instance Structured ExtraSource +instance NFData ExtraSource where rnf = genericRnf + +instance Parsec ExtraSource where + parsec = do + SymbolicPathNT path <- parsec <* P.spaces + opts <- P.optional (parensLax (P.sepBy p P.spaces)) + return (ExtraSource path (fromMaybe mempty opts)) + where + p :: P.CharParsing p => p String + p = some $ P.satisfy (\c -> not (isSpace c) && not (c == ')')) + +parensLax :: P.CharParsing m => m a -> m a +parensLax p = P.between (P.char '(' *> P.spaces) (P.char ')' *> P.spaces) p + +instance Pretty ExtraSource where + pretty (ExtraSource path opts) = + pretty (SymbolicPathNT path) <<>> PP.parens (PP.hsep (map PP.text opts)) + +extraSourceFromPath :: SymbolicPath Pkg File -> ExtraSource +extraSourceFromPath fp = ExtraSource fp mempty diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs index a53d404dd1e..2a541d8f8ef 100644 --- a/Cabal-tests/tests/NoThunks.hs +++ b/Cabal-tests/tests/NoThunks.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} #if !(__GLASGOW_HASKELL__ >= 806 && defined(MIN_VERSION_nothunks)) module Main (main) where main :: IO () @@ -73,6 +74,7 @@ instance NoThunks ConfVar instance NoThunks Dependency instance NoThunks Executable instance NoThunks ExecutableScope +instance NoThunks ExtraSource instance NoThunks FlagName instance NoThunks ForeignLib instance NoThunks ForeignLibOption diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index e298681f272..1e4b41216c9 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -29,8 +29,8 @@ md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion md5CheckGenericPackageDescription proxy = md5Check proxy - 0xc039c6741dead5203ad2b33bd3bf4dc8 + 0xe6490e868f1f18e90046d07228c7034b md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion md5CheckLocalBuildInfo proxy = md5Check proxy - 0xea86b170fa32ac289cbd1fb6174b5cbf + 0xa5356c060cd3a6bd599819de2994d5e2 diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index f7e7ca5b7b6..517bb3aec57 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE FlexibleInstances #-} module Data.TreeDiff.Instances.Cabal () where import Data.TreeDiff @@ -75,6 +76,7 @@ instance ToExpr ExeDependency instance ToExpr Executable instance ToExpr ExecutableScope instance ToExpr ExposedModule +instance ToExpr ExtraSource instance ToExpr FlagAssignment instance ToExpr FlagName instance ToExpr ForeignLib diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs index ee0fff7ca84..d59ae78289c 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Target.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Target.hs @@ -459,11 +459,11 @@ checkBuildInfoPathsContent bi = do -- Paths well-formedness check for BuildInfo. checkBuildInfoPathsWellFormedness :: Monad m => BuildInfo -> CheckM m () checkBuildInfoPathsWellFormedness bi = do - mapM_ (checkPath False "asm-sources" PathKindFile . getSymbolicPath) (asmSources bi) - mapM_ (checkPath False "cmm-sources" PathKindFile . getSymbolicPath) (cmmSources bi) - mapM_ (checkPath False "c-sources" PathKindFile . getSymbolicPath) (cSources bi) - mapM_ (checkPath False "cxx-sources" PathKindFile . getSymbolicPath) (cxxSources bi) - mapM_ (checkPath False "js-sources" PathKindFile . getSymbolicPath) (jsSources bi) + mapM_ (checkPath False "asm-sources" PathKindFile . getSymbolicPath . extraSourceFile) (asmSources bi) + mapM_ (checkPath False "cmm-sources" PathKindFile . getSymbolicPath . extraSourceFile) (cmmSources bi) + mapM_ (checkPath False "c-sources" PathKindFile . getSymbolicPath . extraSourceFile) (cSources bi) + mapM_ (checkPath False "cxx-sources" PathKindFile . getSymbolicPath . extraSourceFile) (cxxSources bi) + mapM_ (checkPath False "js-sources" PathKindFile . getSymbolicPath . extraSourceFile) (jsSources bi) mapM_ (checkPath False "install-includes" PathKindFile . getSymbolicPath) (installIncludes bi) @@ -529,8 +529,8 @@ checkBuildInfoFeatures bi sv = do (PackageBuildWarning CVExtensionsDeprecated) -- asm-sources, cmm-sources and friends only w/ spec ≥ 1.10 - checkCVSources (map getSymbolicPath $ asmSources bi) - checkCVSources (map getSymbolicPath $ cmmSources bi) + checkCVSources (map (getSymbolicPath . extraSourceFile) $ asmSources bi) + checkCVSources (map (getSymbolicPath . extraSourceFile) $ cmmSources bi) checkCVSources (extraBundledLibs bi) checkCVSources (extraLibFlavours bi) diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 8926682ce84..8ac0765b9c8 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -644,35 +644,35 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraCSources bi extras = bi{cSources = new} where - new = ordNub (extras ++ cSources bi) + new = ordNub (map extraSourceFromPath extras ++ cSources bi) -- | Add extra C++ sources generated by preprocessing to build -- information. addExtraCxxSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraCxxSources bi extras = bi{cxxSources = new} where - new = ordNub (extras ++ cxxSources bi) + new = ordNub (map extraSourceFromPath extras ++ cxxSources bi) -- | Add extra C-- sources generated by preprocessing to build -- information. addExtraCmmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraCmmSources bi extras = bi{cmmSources = new} where - new = ordNub (extras ++ cmmSources bi) + new = ordNub (map extraSourceFromPath extras ++ cmmSources bi) -- | Add extra ASM sources generated by preprocessing to build -- information. addExtraAsmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraAsmSources bi extras = bi{asmSources = new} where - new = ordNub (extras ++ asmSources bi) + new = ordNub (map extraSourceFromPath extras ++ asmSources bi) -- | Add extra JS sources generated by preprocessing to build -- information. addExtraJsSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraJsSources bi extras = bi{jsSources = new} where - new = ordNub (extras ++ jsSources bi) + new = ordNub (map extraSourceFromPath extras ++ jsSources bi) -- | Add extra HS modules generated by preprocessing to build -- information. @@ -718,7 +718,7 @@ replComponent preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib - lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map extraSourceFromPath extras}} replLib replFlags pkg lbi lib' libClbi replComponent replFlags @@ -735,23 +735,23 @@ replComponent case comp of CLib lib -> do let libbi = libBuildInfo lib - lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map extraSourceFromPath extras}} replLib replFlags pkg_descr lbi lib' clbi CFLib flib -> replFLib replFlags pkg_descr lbi flib clbi CExe exe -> do let ebi = buildInfo exe - exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map extraSourceFromPath extras}} replExe replFlags pkg_descr lbi exe' clbi CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do let exe = testSuiteExeV10AsExe test let ebi = buildInfo exe - exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map extraSourceFromPath extras}} replExe replFlags pkg_descr lbi exe' clbi CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do let exe = benchmarkExeV10asExe bm let ebi = buildInfo exe - exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map extraSourceFromPath extras}} replExe replFlags pkg_descr lbi exe' clbi #if __GLASGOW_HASKELL__ < 811 -- silence pattern-match warnings prior to GHC 9.0 diff --git a/Cabal/src/Distribution/Simple/BuildTarget.hs b/Cabal/src/Distribution/Simple/BuildTarget.hs index ffa7a609e6b..1d987c7715f 100644 --- a/Cabal/src/Distribution/Simple/BuildTarget.hs +++ b/Cabal/src/Distribution/Simple/BuildTarget.hs @@ -497,11 +497,11 @@ pkgComponentInfo pkg = , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi , cinfoModules = componentModules c , cinfoHsFiles = map getSymbolicPath $ componentHsFiles c - , cinfoAsmFiles = map getSymbolicPath $ asmSources bi - , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi - , cinfoCFiles = map getSymbolicPath $ cSources bi - , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi - , cinfoJsFiles = map getSymbolicPath $ jsSources bi + , cinfoAsmFiles = map (getSymbolicPath . extraSourceFile) $ asmSources bi + , cinfoCmmFiles = map (getSymbolicPath . extraSourceFile) $ cmmSources bi + , cinfoCFiles = map (getSymbolicPath . extraSourceFile) $ cSources bi + , cinfoCxxFiles = map (getSymbolicPath . extraSourceFile) $ cxxSources bi + , cinfoJsFiles = map (getSymbolicPath . extraSourceFile) $ jsSources bi } | c <- pkgComponents pkg , let bi = componentBuildInfo c diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index f2ca9aba02f..72b65649afb 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -26,6 +26,7 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Setup.Common (commonSetupTempFileOptions) import Distribution.System (Arch (JavaScript), Platform (..)) import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExtraSource (ExtraSource (..)) import Distribution.Utils.Path import Distribution.Verbosity (Verbosity) @@ -53,23 +54,21 @@ buildAllExtraSources = , buildCmmSources ] -buildCSources - , buildCxxSources - , buildJsSources - , buildAsmSources - , buildCmmSources - :: Maybe (SymbolicPath Pkg File) - -- ^ An optional non-Haskell Main file - -> ConfiguredProgram - -- ^ The GHC configured program - -> SymbolicPath Pkg (Dir Artifacts) - -- ^ The build directory for this target - -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) - -- ^ Needed build ways - -> PreBuildComponentInputs - -- ^ The context and component being built in it. - -> IO (NubListR (SymbolicPath Pkg File)) - -- ^ Returns the list of extra sources that were built +type ExtraSourceBuilder = + Maybe (SymbolicPath Pkg File) + -- ^ An optional non-Haskell Main file + -> ConfiguredProgram + -- ^ The GHC configured program + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ The build directory for this target + -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) + -- ^ Needed build ways + -> PreBuildComponentInputs + -- ^ The context and component being built in it. + -> IO (NubListR (SymbolicPath Pkg File)) + -- ^ Returns the list of extra sources that were built + +buildCSources :: ExtraSourceBuilder buildCSources mbMainFile = buildExtraSources "C Sources" @@ -80,9 +79,11 @@ buildCSources mbMainFile = CExe{} | Just main <- mbMainFile , isC $ getSymbolicPath main -> - cFiles ++ [main] + cFiles ++ [ExtraSource main mempty] _otherwise -> cFiles ) + +buildCxxSources :: ExtraSourceBuilder buildCxxSources mbMainFile = buildExtraSources "C++ Sources" @@ -93,9 +94,11 @@ buildCxxSources mbMainFile = CExe{} | Just main <- mbMainFile , isCxx $ getSymbolicPath main -> - cxxFiles ++ [main] + cxxFiles ++ [ExtraSource main mempty] _otherwise -> cxxFiles ) + +buildJsSources :: ExtraSourceBuilder buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do Platform hostArch _ <- hostPlatform <$> localBuildInfo let hasJsSupport = hostArch == JavaScript @@ -114,11 +117,15 @@ buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do ghcProg buildTargetDir neededWays + +buildAsmSources :: ExtraSourceBuilder buildAsmSources _mbMainFile = buildExtraSources "Assembler Sources" Internal.componentAsmGhcOptions (asmSources . componentBuildInfo) + +buildCmmSources :: ExtraSourceBuilder buildCmmSources _mbMainFile = buildExtraSources "C-- Sources" @@ -136,14 +143,14 @@ buildExtraSources -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File + -> ExtraSource -> GhcOptions ) -- ^ Function to determine the @'GhcOptions'@ for the -- invocation of GHC when compiling these extra sources (e.g. -- @'Internal.componentCxxGhcOptions'@, -- @'Internal.componentCmmGhcOptions'@) - -> (Component -> [SymbolicPath Pkg File]) + -> (Component -> [ExtraSource]) -- ^ View the extra sources of a component, typically from -- the build info (e.g. @'asmSources'@, @'cSources'@). -- @'Executable'@ components might additionally add the @@ -189,8 +196,8 @@ buildExtraSources platform mbWorkDir - buildAction :: SymbolicPath Pkg File -> IO () - buildAction sourceFile = do + buildAction :: ExtraSource -> IO () + buildAction extraSource = do let baseSrcOpts = componentSourceGhcOptions verbosity @@ -198,7 +205,7 @@ buildExtraSources bi clbi buildTargetDir - sourceFile + extraSource vanillaSrcOpts = -- -fPIC is used in case you are using the repl -- of a dynamically linked GHC @@ -228,9 +235,9 @@ buildExtraSources odir = fromFlag (ghcOptObjDir vanillaSrcOpts) compileIfNeeded :: GhcOptions -> IO () - compileIfNeeded opts = do - needsRecomp <- checkNeedsRecompilation mbWorkDir sourceFile opts - when needsRecomp $ runGhcProg opts + compileIfNeeded opts' = do + needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile extraSource) opts' + when needsRecomp $ runGhcProg opts' createDirectoryIfMissingVerbose verbosity True (i odir) case targetComponent targetInfo of @@ -269,4 +276,4 @@ buildExtraSources else do info verbosity ("Building " ++ description ++ "...") traverse_ buildAction sources - return (toNubListR sources) + return (toNubListR (map extraSourceFile sources)) diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 9e252d7c889..e98b1198970 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -377,21 +377,23 @@ includePaths lbi bi clbi odir = | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi ] -componentCcGhcOptions - :: Verbosity +type ExtraSourceGhcOptions = + Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File + -> ExtraSource -> GhcOptions -componentCcGhcOptions verbosity lbi bi clbi odir filename = + +componentCcGhcOptions :: ExtraSourceGhcOptions +componentCcGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] + , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -408,6 +410,7 @@ componentCcGhcOptions verbosity lbi bi clbi odir filename = MaximalDebugInfo -> ["-g3"] ) ++ ccOptions bi + ++ extraSourceOpts extraSource , ghcOptCcProgram = maybeToFlag $ programPath @@ -416,21 +419,14 @@ componentCcGhcOptions verbosity lbi bi clbi odir filename = , ghcOptExtra = hcOptions GHC bi } -componentCxxGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File - -> GhcOptions -componentCxxGhcOptions verbosity lbi bi clbi odir filename = +componentCxxGhcOptions :: ExtraSourceGhcOptions +componentCxxGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] + , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -447,6 +443,7 @@ componentCxxGhcOptions verbosity lbi bi clbi odir filename = MaximalDebugInfo -> ["-g3"] ) ++ cxxOptions bi + ++ extraSourceOpts extraSource , ghcOptCcProgram = maybeToFlag $ programPath @@ -455,21 +452,14 @@ componentCxxGhcOptions verbosity lbi bi clbi odir filename = , ghcOptExtra = hcOptions GHC bi } -componentAsmGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File - -> GhcOptions -componentAsmGhcOptions verbosity lbi bi clbi odir filename = +componentAsmGhcOptions :: ExtraSourceGhcOptions +componentAsmGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] + , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -490,21 +480,14 @@ componentAsmGhcOptions verbosity lbi bi clbi odir filename = , ghcOptExtra = hcOptions GHC bi } -componentJsGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File - -> GhcOptions -componentJsGhcOptions verbosity lbi bi clbi odir filename = +componentJsGhcOptions :: ExtraSourceGhcOptions +componentJsGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] + , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] , ghcOptJSppOptions = jsppOptions bi , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True @@ -601,21 +584,14 @@ toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override? toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation -componentCmmGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File - -> GhcOptions -componentCmmGhcOptions verbosity lbi bi clbi odir filename = +componentCmmGhcOptions :: ExtraSourceGhcOptions +componentCmmGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [filename] + , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptCppOptions = cppOptions bi , ghcOptCppIncludes = @@ -626,7 +602,7 @@ componentCmmGhcOptions verbosity lbi bi clbi odir filename = , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) , ghcOptDebugInfo = toFlag (withDebugInfo lbi) - , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi + , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi ++ extraSourceOpts extraSource , ghcOptObjDir = toFlag odir } diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index a73d47f7a6e..8813d794574 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -62,6 +62,7 @@ import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.Errors import Distribution.Simple.Flag +import Distribution.Simple.GHC.Build.Utils (isCxx) import Distribution.Simple.GHC.EnvironmentParser import Distribution.Simple.GHC.ImplInfo import qualified Distribution.Simple.GHC.Internal as Internal @@ -547,8 +548,6 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do -- See Note [Symbolic paths] in Distribution.Utils.Path i = interpretSymbolicPathLBI lbi - u :: SymbolicPathX allowAbs Pkg to -> FilePath - u = getSymbolicPath (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir @@ -576,7 +575,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do -- modules? let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) jsSrcs = jsSources libBi - cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles + cObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cLikeFiles baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir linkJsLibOpts = mempty @@ -584,9 +583,9 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do [ "-link-js-lib" , getHSLibraryName uid , "-js-lib-outputdir" - , u libTargetDir + , getSymbolicPath libTargetDir ] - ++ map u jsSrcs + ++ foldMap (\(ExtraSource file opts) -> getSymbolicPath file : opts) jsSrcs } vanillaOptsNoJsLib = baseOpts @@ -740,7 +739,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do info verbosity "Linking..." let cSharedObjs = map - ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension))) + ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)) . extraSourceFile) (cSources libBi ++ cxxSources libBi) compiler_id = compilerId (compiler lbi) sharedLibFilePath = libTargetDir makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid) @@ -1153,8 +1152,8 @@ decodeMainIsArg arg -- -- Used to correctly build and link sources. data BuildSources = BuildSources - { cSourcesFiles :: [SymbolicPath Pkg File] - , cxxSourceFiles :: [SymbolicPath Pkg File] + { cSourcesFiles :: [ExtraSource] + , cxxSourceFiles :: [ExtraSource] , inputSourceFiles :: [SymbolicPath Pkg File] , inputSourceModules :: [ModuleName] } @@ -1220,11 +1219,11 @@ gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = } else let (csf, cxxsf) - | isCxx (getSymbolicPath main) = (cSources bnfo, main : cxxSources bnfo) + | isCxx (getSymbolicPath main) = (cSources bnfo, extraSourceFromPath main : cxxSources bnfo) -- if main is not a Haskell source -- and main is not a C++ source -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) + | otherwise = (extraSourceFromPath main : cSources bnfo, cxxSources bnfo) in return BuildSources { cSourcesFiles = csf @@ -1242,9 +1241,6 @@ gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = , inputSourceModules = foreignLibModules flib } - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - -- | FilePath has a Haskell extension: .hs or .lhs isHaskell :: FilePath -> Bool isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] @@ -1305,8 +1301,8 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do inputModules = inputSourceModules buildSources isGhcDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp - cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs - cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs + cObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cSrcs + cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cxxSrcs needDynamic = gbuildNeedDynamic lbi bm needProfiling = withProfExe lbi @@ -1508,7 +1504,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do -- add a warning if this occurs. odir = fromFlag (ghcOptObjDir opts) createDirectoryIfMissingVerbose verbosity True (i odir) - needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts + needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile filename) opts when needsRecomp $ runGhcProg opts | filename <- cxxSrcs @@ -1550,7 +1546,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do | otherwise = vanillaCcOpts odir = fromFlag (ghcOptObjDir opts) createDirectoryIfMissingVerbose verbosity True (i odir) - needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts + needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile filename) opts when needsRecomp $ runGhcProg opts | filename <- cSrcs diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs index d48da792fa4..123da9c9d13 100644 --- a/Cabal/src/Distribution/Simple/SrcDist.hs +++ b/Cabal/src/Distribution/Simple/SrcDist.hs @@ -566,11 +566,11 @@ allSourcesBuildInfo verbosity rip mbWorkDir bi pps modules = do return $ sources ++ catMaybes bootFiles - ++ cSources bi - ++ cxxSources bi - ++ cmmSources bi - ++ asmSources bi - ++ jsSources bi + ++ map extraSourceFile (cSources bi) + ++ map extraSourceFile (cxxSources bi) + ++ map extraSourceFile (cmmSources bi) + ++ map extraSourceFile (asmSources bi) + ++ map extraSourceFile (jsSources bi) where nonEmpty' :: b -> ([a] -> b) -> [a] -> b nonEmpty' x _ [] = x diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs index 1166f333f3c..52b203d18c8 100644 --- a/cabal-install/src/Distribution/Client/SourceFiles.hs +++ b/cabal-install/src/Distribution/Client/SourceFiles.hs @@ -28,6 +28,7 @@ import Distribution.Types.BuildInfo import Distribution.Types.Component import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec) import Distribution.Types.Executable +import Distribution.Types.ExtraSource import Distribution.Types.ForeignLib import Distribution.Types.Library import Distribution.Types.PackageDescription @@ -176,11 +177,11 @@ needBuildInfo pkg_descr bi modules = do matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) (Just $ makeSymbolicPath root) fpath traverse_ needIfExists $ concat - [ map getSymbolicPath $ cSources bi - , map getSymbolicPath $ cxxSources bi - , map getSymbolicPath $ jsSources bi - , map getSymbolicPath $ cmmSources bi - , map getSymbolicPath $ asmSources bi + [ map (getSymbolicPath . extraSourceFile) $ cSources bi + , map (getSymbolicPath . extraSourceFile) $ cxxSources bi + , map (getSymbolicPath . extraSourceFile) $ jsSources bi + , map (getSymbolicPath . extraSourceFile) $ cmmSources bi + , map (getSymbolicPath . extraSourceFile) $ asmSources bi , map getSymbolicPath $ expandedExtraSrcFiles ] for_ (fmap getSymbolicPath $ installIncludes bi) $ \f -> diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index b31655c59c6..61ca11f087a 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -72,6 +72,7 @@ import Distribution.PackageDescription , BenchmarkInterface (..) , BuildInfo (..) , Executable (..) + , ExtraSource (..) , PackageDescription , TestSuite (..) , TestSuiteInterface (..) @@ -1921,8 +1922,8 @@ collectKnownComponentInfo pkg = , cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)) , cinfoModules = ordNub (componentModules c) , cinfoHsFiles = ordNub (componentHsFiles c) - , cinfoCFiles = ordNub (map getSymbolicPath $ cSources bi) - , cinfoJsFiles = ordNub (map getSymbolicPath $ jsSources bi) + , cinfoCFiles = ordNub (map (getSymbolicPath . extraSourceFile) $ cSources bi) + , cinfoJsFiles = ordNub (map (getSymbolicPath . extraSourceFile) $ jsSources bi) } | c <- pkgComponents pkg , let bi = componentBuildInfo c diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 95f04b81a4c..e1978432cbe 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -685,7 +685,9 @@ testTargetSelectorAmbiguous reportSubCase = do withCFiles :: Executable -> [FilePath] -> Executable withCFiles exe files = - exe{buildInfo = (buildInfo exe){cSources = map unsafeMakeSymbolicPath files}} + exe{buildInfo = (buildInfo exe){cSources = map (mkExtraSource . unsafeMakeSymbolicPath) files}} + + mkExtraSource x = ExtraSource x [] withHsSrcDirs :: Executable -> [FilePath] -> Executable withHsSrcDirs exe srcDirs = diff --git a/cabal-testsuite/PackageTests/ExtraSources/cbits/test.c b/cabal-testsuite/PackageTests/ExtraSources/cbits/test.c new file mode 100644 index 00000000000..e31c5a9b7b5 --- /dev/null +++ b/cabal-testsuite/PackageTests/ExtraSources/cbits/test.c @@ -0,0 +1,3 @@ +#ifndef DOIT +#error "It does not work" +#endif diff --git a/cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal b/cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal new file mode 100644 index 00000000000..0d340f5c6bd --- /dev/null +++ b/cabal-testsuite/PackageTests/ExtraSources/extra-sources.cabal @@ -0,0 +1,10 @@ +cabal-version: 3.4 +name: extra-sources +version: 0 +build-type: Simple + +library + hs-source-dirs: src + build-depends: base + exposed-modules: MyLib + c-sources: cbits/test.c (-D DOIT=1) diff --git a/cabal-testsuite/PackageTests/ExtraSources/setup.out b/cabal-testsuite/PackageTests/ExtraSources/setup.out new file mode 100644 index 00000000000..43a3574bd1b --- /dev/null +++ b/cabal-testsuite/PackageTests/ExtraSources/setup.out @@ -0,0 +1,5 @@ +# Setup configure +Configuring extra-sources-0... +# Setup build +Preprocessing library for extra-sources-0... +Building library for extra-sources-0... diff --git a/cabal-testsuite/PackageTests/ExtraSources/setup.test.hs b/cabal-testsuite/PackageTests/ExtraSources/setup.test.hs new file mode 100644 index 00000000000..9e2abcb188b --- /dev/null +++ b/cabal-testsuite/PackageTests/ExtraSources/setup.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = setupTest $ do + setup "configure" [] + setup "build" [] diff --git a/cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs b/cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs new file mode 100644 index 00000000000..bcdf120b02c --- /dev/null +++ b/cabal-testsuite/PackageTests/ExtraSources/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib where + +someFunc :: IO () +someFunc = mempty From 5c83c482465c08bbe80974539209d6ac0ff7e99f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 5 Jun 2025 15:09:19 +0800 Subject: [PATCH 002/122] feat(Cabal): do not wrap logging by default --- Cabal/src/Distribution/Verbosity.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cabal/src/Distribution/Verbosity.hs b/Cabal/src/Distribution/Verbosity.hs index c81c6dd8630..cd522846cbd 100644 --- a/Cabal/src/Distribution/Verbosity.hs +++ b/Cabal/src/Distribution/Verbosity.hs @@ -94,7 +94,7 @@ data Verbosity = Verbosity deriving (Generic, Show, Read) mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} +mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.fromList [VNoWrap], vQuiet = False} instance Eq Verbosity where x == y = vLevel x == vLevel y From dfcc65f5b17921d70521976e002a80ada35faa9e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 13 Mar 2025 13:18:55 +0800 Subject: [PATCH 003/122] feat(Cabal, Cabal-syntax): support generated cmm-sources --- Cabal-described/src/Distribution/Described.hs | 10 ++- .../PackageDescription/FieldGrammar.hs | 22 ++++-- .../src/Distribution/Types/BuildInfo.hs | 14 ++-- .../src/Distribution/Types/BuildInfo/Lens.hs | 14 ++-- .../src/Distribution/Types/ExtraSource.hs | 75 +++++++++++++------ Cabal-syntax/src/Distribution/Utils/Path.hs | 4 +- Cabal-tests/tests/NoThunks.hs | 5 +- .../Distribution/Utils/Structured.hs | 4 +- .../src/Data/TreeDiff/Instances/Cabal.hs | 5 +- Cabal/src/Distribution/Simple/Build.hs | 20 ++--- .../Simple/GHC/Build/ExtraSources.hs | 27 +++++-- Cabal/src/Distribution/Simple/GHC/Internal.hs | 37 ++++++--- Cabal/src/Distribution/Simple/GHCJS.hs | 10 +-- .../src/Distribution/Client/TargetSelector.hs | 2 +- cabal-install/tests/IntegrationTests2.hs | 6 +- 15 files changed, 168 insertions(+), 87 deletions(-) diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index e54eb5af099..ded65c63bce 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -100,7 +100,7 @@ import Distribution.Types.SourceRepo (RepoType) import Distribution.Types.TestType (TestType) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Utils.Path (SymbolicPath, RelativePath, FileOrDir(..), Pkg) +import Distribution.Utils.Path (SymbolicPath, RelativePath, FileOrDir(..), Pkg, Build) import Distribution.Verbosity (Verbosity) import Distribution.Version (Version, VersionRange) import Language.Haskell.Extension (Extension, Language, knownLanguages) @@ -407,7 +407,13 @@ instance Described ExposedModule where instance Described Extension where describe _ = RETodo -instance Described ExtraSource where +instance Described (ExtraSource Build) where + describe _ = REAppend + [ describe (Proxy :: Proxy (SymbolicPath Build File)) + , REOpt (reChar '(' <> reSpacedList (describe (Proxy :: Proxy Token')) <> reChar ')') + ] + +instance Described (ExtraSource Pkg) where describe _ = REAppend [ describe (Proxy :: Proxy (SymbolicPath Pkg File)) , REOpt (reChar '(' <> reSpacedList (describe (Proxy :: Proxy Token')) <> reChar ')') diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 5aa64f08e82..558594f72b6 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -174,7 +174,8 @@ libraryFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) - , c (List VCat (Identity ExtraSource) ExtraSource) + , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg)) + , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build)) , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) @@ -225,7 +226,8 @@ foreignLibFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) - , c (List VCat (Identity ExtraSource) ExtraSource) + , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg)) + , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build)) , c (List FSep (Identity ForeignLibOption) ForeignLibOption) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) @@ -265,7 +267,8 @@ executableFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) - , c (List VCat (Identity ExtraSource) ExtraSource) + , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg)) + , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build)) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -342,7 +345,8 @@ testSuiteFieldGrammar , c (List CommaFSep Token String) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) - , c (List VCat (Identity ExtraSource) ExtraSource) + , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg)) + , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build)) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -487,7 +491,8 @@ benchmarkFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) - , c (List VCat (Identity ExtraSource) ExtraSource) + , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg)) + , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build)) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -590,7 +595,8 @@ buildInfoFieldGrammar , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , c (List CommaVCat (Identity Dependency) Dependency) , c (List CommaVCat (Identity Mixin) Mixin) - , c (List VCat (Identity ExtraSource) ExtraSource) + , c (List VCat (Identity (ExtraSource Pkg)) (ExtraSource Pkg)) + , c (List VCat (Identity (ExtraSource Build)) (ExtraSource Build)) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) , c (List FSep Token String) @@ -639,6 +645,8 @@ buildInfoFieldGrammar = ^^^ availableSince CabalSpecV3_0 [] <*> monoidalFieldAla "cmm-sources" formatExtraSources L.cmmSources ^^^ availableSince CabalSpecV3_0 [] + <*> monoidalFieldAla "autogen-cmm-sources" formatExtraSources L.autogenCmmSources + -- FIXME ^^^ availableSince CabalSpecV3_0 [] <*> monoidalFieldAla "c-sources" formatExtraSources L.cSources <*> monoidalFieldAla "cxx-sources" formatExtraSources L.cxxSources ^^^ availableSince CabalSpecV2_2 [] @@ -842,7 +850,7 @@ formatOtherExtensions = alaList' FSep MQuoted formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName formatOtherModules = alaList' VCat MQuoted -formatExtraSources :: [ExtraSource] -> List VCat (Identity ExtraSource) ExtraSource +formatExtraSources :: [ExtraSource pkg] -> List VCat (Identity (ExtraSource pkg)) (ExtraSource pkg) formatExtraSources = alaList' VCat Identity ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 5ef5ee7f422..f41f800be13 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -74,15 +74,17 @@ data BuildInfo = BuildInfo -- ^ support frameworks for Mac OS X , extraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)] -- ^ extra locations to find frameworks - , asmSources :: [ExtraSource] + , asmSources :: [ExtraSource Pkg] -- ^ Assembly source files - , cmmSources :: [ExtraSource] + , cmmSources :: [ExtraSource Pkg] -- ^ C-- source files - , cSources :: [ExtraSource] + , autogenCmmSources :: [ExtraSource Build] + -- ^ C-- generated source files + , cSources :: [ExtraSource Pkg] -- ^ C source files - , cxxSources :: [ExtraSource] + , cxxSources :: [ExtraSource Pkg] -- ^ C++ source files - , jsSources :: [ExtraSource] + , jsSources :: [ExtraSource Pkg] -- ^ JavaScript source file , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] -- ^ where to look for the Haskell module hierarchy @@ -175,6 +177,7 @@ instance Monoid BuildInfo where , extraFrameworkDirs = [] , asmSources = [] , cmmSources = [] + , autogenCmmSources = [] , cSources = [] , cxxSources = [] , jsSources = [] @@ -229,6 +232,7 @@ instance Semigroup BuildInfo where , extraFrameworkDirs = combineNub extraFrameworkDirs , asmSources = combineNub asmSources , cmmSources = combineNub cmmSources + , autogenCmmSources = combineNub autogenCmmSources , cSources = combineNub cSources , cxxSources = combineNub cxxSources , jsSources = combineNub jsSources diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index a10115a4b36..70e7f1e38d4 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -84,23 +84,27 @@ class HasBuildInfo a where extraFrameworkDirs = buildInfo . extraFrameworkDirs {-# INLINE extraFrameworkDirs #-} - asmSources :: Lens' a [ExtraSource] + asmSources :: Lens' a [ExtraSource Pkg] asmSources = buildInfo . asmSources {-# INLINE asmSources #-} - cmmSources :: Lens' a [ExtraSource] + autogenCmmSources :: Lens' a [ExtraSource Build] + autogenCmmSources = buildInfo . autogenCmmSources + {-# INLINE autogenCmmSources #-} + + cmmSources :: Lens' a [ExtraSource Pkg] cmmSources = buildInfo . cmmSources {-# INLINE cmmSources #-} - cSources :: Lens' a [ExtraSource] + cSources :: Lens' a [ExtraSource Pkg] cSources = buildInfo . cSources {-# INLINE cSources #-} - cxxSources :: Lens' a [ExtraSource] + cxxSources :: Lens' a [ExtraSource Pkg] cxxSources = buildInfo . cxxSources {-# INLINE cxxSources #-} - jsSources :: Lens' a [ExtraSource] + jsSources :: Lens' a [ExtraSource Pkg] jsSources = buildInfo . jsSources {-# INLINE jsSources #-} diff --git a/Cabal-syntax/src/Distribution/Types/ExtraSource.hs b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs index 354fa00e9fb..e3b05603219 100644 --- a/Cabal-syntax/src/Distribution/Types/ExtraSource.hs +++ b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Types.ExtraSource ( ExtraSource (..) - , extraSourceFromPath + , ExtraSourceClass (..) ) where import Distribution.Compat.Prelude @@ -12,37 +14,66 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty -import Distribution.Utils.Path (FileOrDir (..), Pkg, SymbolicPath) +import Distribution.Utils.Path (Build, FileOrDir (..), Pkg, RelativePath, SymbolicPath, relativeSymbolicPath, unsafeCoerceSymbolicPath) import qualified Distribution.Compat.CharParsing as P -import Distribution.FieldGrammar.Newtypes (SymbolicPathNT (..)) import qualified Text.PrettyPrint as PP -data ExtraSource = ExtraSource - { extraSourceFile :: SymbolicPath Pkg File - , extraSourceOpts :: [String] - } - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) +data family ExtraSource pkg -instance Binary ExtraSource -instance Structured ExtraSource -instance NFData ExtraSource where rnf = genericRnf +data instance ExtraSource Pkg = ExtraSourcePkg (SymbolicPath Pkg File) [String] + deriving (Generic, Show, Read, Eq, Ord, Data) -instance Parsec ExtraSource where +data instance ExtraSource Build = ExtraSourceBuild (RelativePath Build File) [String] + deriving (Generic, Show, Read, Eq, Ord, Data) + +class ExtraSourceClass e where + extraSourceOpts :: e -> [String] + extraSourceFile :: e -> SymbolicPath Pkg 'File + +instance ExtraSourceClass (ExtraSource Pkg) where + extraSourceOpts (ExtraSourcePkg _ opts) = opts + extraSourceFile (ExtraSourcePkg f _) = f + +instance ExtraSourceClass (ExtraSource Build) where + extraSourceOpts (ExtraSourceBuild _ opts) = opts + + -- FIXME + extraSourceFile (ExtraSourceBuild f _) = unsafeCoerceSymbolicPath (relativeSymbolicPath f) + +instance Binary (ExtraSource Pkg) +instance Structured (ExtraSource Pkg) +instance NFData (ExtraSource Pkg) where rnf = genericRnf + +instance Binary (ExtraSource Build) +instance Structured (ExtraSource Build) +instance NFData (ExtraSource Build) where rnf = genericRnf + +instance Parsec (ExtraSource Pkg) where parsec = do - SymbolicPathNT path <- parsec <* P.spaces + path <- parsec <* P.spaces opts <- P.optional (parensLax (P.sepBy p P.spaces)) - return (ExtraSource path (fromMaybe mempty opts)) + return (ExtraSourcePkg path (fromMaybe mempty opts)) where p :: P.CharParsing p => p String - p = some $ P.satisfy (\c -> not (isSpace c) && not (c == ')')) + p = some $ P.satisfy (\c -> not (isSpace c) && (c /= ')')) -parensLax :: P.CharParsing m => m a -> m a -parensLax p = P.between (P.char '(' *> P.spaces) (P.char ')' *> P.spaces) p +instance Parsec (ExtraSource Build) where + parsec = do + path <- parsec <* P.spaces + opts <- P.optional (parensLax (P.sepBy p P.spaces)) + return (ExtraSourceBuild path (fromMaybe mempty opts)) + where + p :: P.CharParsing p => p String + p = some $ P.satisfy (\c -> not (isSpace c) && (c /= ')')) + +instance Pretty (ExtraSource Pkg) where + pretty (ExtraSourcePkg path opts) = + pretty path <<>> PP.parens (PP.hsep (map PP.text opts)) -instance Pretty ExtraSource where - pretty (ExtraSource path opts) = - pretty (SymbolicPathNT path) <<>> PP.parens (PP.hsep (map PP.text opts)) +instance Pretty (ExtraSource Build) where + pretty (ExtraSourceBuild path opts) = + pretty path <<>> PP.parens (PP.hsep (map PP.text opts)) -extraSourceFromPath :: SymbolicPath Pkg File -> ExtraSource -extraSourceFromPath fp = ExtraSource fp mempty +parensLax :: P.CharParsing m => m a -> m a +parensLax p = P.between (P.char '(' *> P.spaces) (P.char ')' *> P.spaces) p diff --git a/Cabal-syntax/src/Distribution/Utils/Path.hs b/Cabal-syntax/src/Distribution/Utils/Path.hs index a4d09334e01..b4aa25506bf 100644 --- a/Cabal-syntax/src/Distribution/Utils/Path.hs +++ b/Cabal-syntax/src/Distribution/Utils/Path.hs @@ -460,7 +460,7 @@ data CWD -- | Abstract directory: package directory (e.g. a directory containing the @.cabal@ file). -- -- See Note [Symbolic paths] in Distribution.Utils.Path. -data Pkg +data Pkg deriving (Data) -- | Abstract directory: dist directory (e.g. @dist-newstyle@). -- @@ -490,7 +490,7 @@ data Framework -- | Abstract directory: build directory. -- -- See Note [Symbolic paths] in Distribution.Utils.Path. -data Build +data Build deriving (Data) -- | Abstract directory: directory for build artifacts, such as documentation or @.hie@ files. -- diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs index 2a541d8f8ef..98380744f67 100644 --- a/Cabal-tests/tests/NoThunks.hs +++ b/Cabal-tests/tests/NoThunks.hs @@ -26,7 +26,7 @@ import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, w import Distribution.Parsec.Source import Distribution.SPDX (License, LicenseExceptionId, LicenseExpression, LicenseId, LicenseRef, SimpleLicenseExpression) import Distribution.System (Arch, OS) -import Distribution.Utils.Path (SymbolicPathX) +import Distribution.Utils.Path (SymbolicPathX, Pkg, Build) import Distribution.Utils.ShortText (ShortText) import Distribution.Version (Version, VersionRange) import Language.Haskell.Extension (Extension, KnownExtension, Language) @@ -74,7 +74,8 @@ instance NoThunks ConfVar instance NoThunks Dependency instance NoThunks Executable instance NoThunks ExecutableScope -instance NoThunks ExtraSource +instance NoThunks (ExtraSource Build) +instance NoThunks (ExtraSource Pkg) instance NoThunks FlagName instance NoThunks ForeignLib instance NoThunks ForeignLibOption diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index 1e4b41216c9..2d0aa123e5e 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -29,8 +29,8 @@ md5Check proxy md5Int = structureHash proxy @?= md5FromInteger md5Int md5CheckGenericPackageDescription :: Proxy GenericPackageDescription -> Assertion md5CheckGenericPackageDescription proxy = md5Check proxy - 0xe6490e868f1f18e90046d07228c7034b + 0x8ba94d68856c65b2946ee48e11afdd07 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion md5CheckLocalBuildInfo proxy = md5Check proxy - 0xa5356c060cd3a6bd599819de2994d5e2 + 0x4e2dd902c8bf79bb656793174f0a6c49 diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index 517bb3aec57..77a1d5b86c3 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -28,7 +28,7 @@ import Distribution.Types.DumpBuildInfo (DumpBuildInfo) import Distribution.Types.PackageVersionConstraint import Distribution.Types.UnitId (DefUnitId, UnitId) import Distribution.Utils.NubList (NubList) -import Distribution.Utils.Path (SymbolicPathX) +import Distribution.Utils.Path (SymbolicPathX, Build, Pkg) import Distribution.Utils.ShortText (ShortText, fromShortText) import Distribution.Verbosity import Distribution.Verbosity.Internal @@ -76,7 +76,8 @@ instance ToExpr ExeDependency instance ToExpr Executable instance ToExpr ExecutableScope instance ToExpr ExposedModule -instance ToExpr ExtraSource +instance ToExpr (ExtraSource Build) +instance ToExpr (ExtraSource Pkg) instance ToExpr FlagAssignment instance ToExpr FlagName instance ToExpr ForeignLib diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 8ac0765b9c8..825f3e1425d 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -644,35 +644,35 @@ generateCode codeGens nm pdesc bi lbi clbi verbosity = do addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraCSources bi extras = bi{cSources = new} where - new = ordNub (map extraSourceFromPath extras ++ cSources bi) + new = ordNub (map (flip ExtraSourcePkg []) extras ++ cSources bi) -- | Add extra C++ sources generated by preprocessing to build -- information. addExtraCxxSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraCxxSources bi extras = bi{cxxSources = new} where - new = ordNub (map extraSourceFromPath extras ++ cxxSources bi) + new = ordNub (map (flip ExtraSourcePkg []) extras ++ cxxSources bi) -- | Add extra C-- sources generated by preprocessing to build -- information. addExtraCmmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraCmmSources bi extras = bi{cmmSources = new} where - new = ordNub (map extraSourceFromPath extras ++ cmmSources bi) + new = ordNub (map (flip ExtraSourcePkg []) extras ++ cmmSources bi) -- | Add extra ASM sources generated by preprocessing to build -- information. addExtraAsmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraAsmSources bi extras = bi{asmSources = new} where - new = ordNub (map extraSourceFromPath extras ++ asmSources bi) + new = ordNub (map (flip ExtraSourcePkg []) extras ++ asmSources bi) -- | Add extra JS sources generated by preprocessing to build -- information. addExtraJsSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo addExtraJsSources bi extras = bi{jsSources = new} where - new = ordNub (map extraSourceFromPath extras ++ jsSources bi) + new = ordNub (map (flip ExtraSourcePkg []) extras ++ jsSources bi) -- | Add extra HS modules generated by preprocessing to build -- information. @@ -718,7 +718,7 @@ replComponent preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers extras <- preprocessExtras verbosity comp lbi let libbi = libBuildInfo lib - lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map extraSourceFromPath extras}} + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map (flip ExtraSourcePkg []) extras}} replLib replFlags pkg lbi lib' libClbi replComponent replFlags @@ -735,23 +735,23 @@ replComponent case comp of CLib lib -> do let libbi = libBuildInfo lib - lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map extraSourceFromPath extras}} + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ map (flip ExtraSourcePkg []) extras}} replLib replFlags pkg_descr lbi lib' clbi CFLib flib -> replFLib replFlags pkg_descr lbi flib clbi CExe exe -> do let ebi = buildInfo exe - exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map extraSourceFromPath extras}} + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map (flip ExtraSourcePkg []) extras}} replExe replFlags pkg_descr lbi exe' clbi CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do let exe = testSuiteExeV10AsExe test let ebi = buildInfo exe - exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map extraSourceFromPath extras}} + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map (flip ExtraSourcePkg []) extras}} replExe replFlags pkg_descr lbi exe' clbi CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do let exe = benchmarkExeV10asExe bm let ebi = buildInfo exe - exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map extraSourceFromPath extras}} + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ map (flip ExtraSourcePkg []) extras}} replExe replFlags pkg_descr lbi exe' clbi #if __GLASGOW_HASKELL__ < 811 -- silence pattern-match warnings prior to GHC 9.0 diff --git a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index 72b65649afb..8689a41d300 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} @@ -52,6 +54,7 @@ buildAllExtraSources = , buildJsSources , buildAsmSources , buildCmmSources + , buildAutogenCmmSources ] type ExtraSourceBuilder = @@ -79,7 +82,7 @@ buildCSources mbMainFile = CExe{} | Just main <- mbMainFile , isC $ getSymbolicPath main -> - cFiles ++ [ExtraSource main mempty] + cFiles ++ [ExtraSourcePkg main mempty] _otherwise -> cFiles ) @@ -94,7 +97,7 @@ buildCxxSources mbMainFile = CExe{} | Just main <- mbMainFile , isCxx $ getSymbolicPath main -> - cxxFiles ++ [ExtraSource main mempty] + cxxFiles ++ [ExtraSourcePkg main mempty] _otherwise -> cxxFiles ) @@ -132,25 +135,34 @@ buildCmmSources _mbMainFile = Internal.componentCmmGhcOptions (cmmSources . componentBuildInfo) +buildAutogenCmmSources :: ExtraSourceBuilder +buildAutogenCmmSources _mbMainFile = + buildExtraSources + "C-- Generated Sources" + Internal.componentCmmGhcOptions + (autogenCmmSources . componentBuildInfo) + -- | Create 'PreBuildComponentRules' for a given type of extra build sources -- which are compiled via a GHC invocation with the given options. Used to -- define built-in extra sources, such as, C, Cxx, Js, Asm, and Cmm sources. buildExtraSources - :: String + :: forall from + . Internal.SourcePath (ExtraSource from) + => String -- ^ String describing the extra sources being built, for printing. -> ( Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) - -> ExtraSource + -> ExtraSource from -> GhcOptions ) -- ^ Function to determine the @'GhcOptions'@ for the -- invocation of GHC when compiling these extra sources (e.g. -- @'Internal.componentCxxGhcOptions'@, -- @'Internal.componentCmmGhcOptions'@) - -> (Component -> [ExtraSource]) + -> (Component -> [ExtraSource from]) -- ^ View the extra sources of a component, typically from -- the build info (e.g. @'asmSources'@, @'cSources'@). -- @'Executable'@ components might additionally add the @@ -196,7 +208,6 @@ buildExtraSources platform mbWorkDir - buildAction :: ExtraSource -> IO () buildAction extraSource = do let baseSrcOpts = componentSourceGhcOptions @@ -236,7 +247,7 @@ buildExtraSources compileIfNeeded :: GhcOptions -> IO () compileIfNeeded opts' = do - needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile extraSource) opts' + needsRecomp <- checkNeedsRecompilation mbWorkDir (Internal.sourcePath lbi extraSource) opts' when needsRecomp $ runGhcProg opts' createDirectoryIfMissingVerbose verbosity True (i odir) @@ -276,4 +287,4 @@ buildExtraSources else do info verbosity ("Building " ++ description ++ "...") traverse_ buildAction sources - return (toNubListR (map extraSourceFile sources)) + return (toNubListR (map (Internal.sourcePath lbi) sources)) diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index e98b1198970..cc8649fb814 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -48,6 +49,9 @@ module Distribution.Simple.GHC.Internal , ghcEnvironmentFileName , renderGhcEnvironmentFile , renderGhcEnvironmentFileEntry + + -- * Paths + , SourcePath (..) ) where import Distribution.Compat.Prelude @@ -377,23 +381,23 @@ includePaths lbi bi clbi odir = | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi ] -type ExtraSourceGhcOptions = +type ExtraSourceGhcOptions pkg = Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) - -> ExtraSource + -> ExtraSource pkg -> GhcOptions -componentCcGhcOptions :: ExtraSourceGhcOptions +componentCcGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg componentCcGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -419,14 +423,14 @@ componentCcGhcOptions verbosity lbi bi clbi odir extraSource = , ghcOptExtra = hcOptions GHC bi } -componentCxxGhcOptions :: ExtraSourceGhcOptions +componentCxxGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg componentCxxGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -452,14 +456,14 @@ componentCxxGhcOptions verbosity lbi bi clbi odir extraSource = , ghcOptExtra = hcOptions GHC bi } -componentAsmGhcOptions :: ExtraSourceGhcOptions +componentAsmGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg componentAsmGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -480,14 +484,14 @@ componentAsmGhcOptions verbosity lbi bi clbi odir extraSource = , ghcOptExtra = hcOptions GHC bi } -componentJsGhcOptions :: ExtraSourceGhcOptions +componentJsGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg componentJsGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptJSppOptions = jsppOptions bi , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True @@ -584,14 +588,14 @@ toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override? toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation -componentCmmGhcOptions :: ExtraSourceGhcOptions +componentCmmGhcOptions :: SourcePath (ExtraSource pkg) => ExtraSourceGhcOptions pkg componentCmmGhcOptions verbosity lbi bi clbi odir extraSource = mempty { -- Respect -v0, but don't crank up verbosity on GHC if -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! ghcOptVerbosity = toFlag (min verbosity normal) , ghcOptMode = toFlag GhcModeCompile - , ghcOptInputFiles = toNubListR [extraSourceFile extraSource] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptCppOptions = cppOptions bi , ghcOptCppIncludes = @@ -838,3 +842,12 @@ renderGhcEnvironmentFileEntry entry = case entry of UserPackageDB -> "user-package-db" SpecificPackageDB dbfile -> "package-db " ++ dbfile GhcEnvFileClearPackageDbStack -> "clear-package-db" + +class ExtraSourceClass e => SourcePath e where + sourcePath :: LocalBuildInfo -> e -> SymbolicPath Pkg 'File + +instance SourcePath (ExtraSource Pkg) where + sourcePath _ (ExtraSourcePkg f _) = f + +instance SourcePath (ExtraSource Build) where + sourcePath lbi (ExtraSourceBuild f _) = buildDir lbi f diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index 8813d794574..de942f03515 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -585,7 +585,7 @@ buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do , "-js-lib-outputdir" , getSymbolicPath libTargetDir ] - ++ foldMap (\(ExtraSource file opts) -> getSymbolicPath file : opts) jsSrcs + ++ foldMap (\e -> getSymbolicPath (extraSourceFile e) : extraSourceOpts e) jsSrcs } vanillaOptsNoJsLib = baseOpts @@ -1152,8 +1152,8 @@ decodeMainIsArg arg -- -- Used to correctly build and link sources. data BuildSources = BuildSources - { cSourcesFiles :: [ExtraSource] - , cxxSourceFiles :: [ExtraSource] + { cSourcesFiles :: [ExtraSource Pkg] + , cxxSourceFiles :: [ExtraSource Pkg] , inputSourceFiles :: [SymbolicPath Pkg File] , inputSourceModules :: [ModuleName] } @@ -1219,11 +1219,11 @@ gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = } else let (csf, cxxsf) - | isCxx (getSymbolicPath main) = (cSources bnfo, extraSourceFromPath main : cxxSources bnfo) + | isCxx (getSymbolicPath main) = (cSources bnfo, ExtraSourcePkg main [] : cxxSources bnfo) -- if main is not a Haskell source -- and main is not a C++ source -- then we assume that it is a C source - | otherwise = (extraSourceFromPath main : cSources bnfo, cxxSources bnfo) + | otherwise = (ExtraSourcePkg main [] : cSources bnfo, cxxSources bnfo) in return BuildSources { cSourcesFiles = csf diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 61ca11f087a..d74aff42e3e 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -72,7 +72,7 @@ import Distribution.PackageDescription , BenchmarkInterface (..) , BuildInfo (..) , Executable (..) - , ExtraSource (..) + , ExtraSourceClass (..) , PackageDescription , TestSuite (..) , TestSuiteInterface (..) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index e1978432cbe..1ae69ddbe07 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -71,7 +72,7 @@ import qualified Distribution.Simple.Flag as Flag import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag) import Distribution.System import Distribution.Text -import Distribution.Utils.Path (unsafeMakeSymbolicPath) +import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath) import Distribution.Version import IntegrationTests2.CPP @@ -687,7 +688,8 @@ testTargetSelectorAmbiguous reportSubCase = do withCFiles exe files = exe{buildInfo = (buildInfo exe){cSources = map (mkExtraSource . unsafeMakeSymbolicPath) files}} - mkExtraSource x = ExtraSource x [] + mkExtraSource :: SymbolicPath Pkg File -> ExtraSource Pkg + mkExtraSource x = ExtraSourcePkg x [] withHsSrcDirs :: Executable -> [FilePath] -> Executable withHsSrcDirs exe srcDirs = From 97f7aff845a4be26c36369a79dc35fc62fd6dda9 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Mar 2025 15:01:50 +0800 Subject: [PATCH 004/122] refactor(cabal-install-solver)!: remove base shim - Remove QualifiyOptions Remove QualifyOptions by setting qoSetupIndependent to be always true (the current default) and qoBaseShim false (this must have been just a hack of some sort). --- .../Distribution/Solver/Modular/Builder.hs | 6 +- .../Distribution/Solver/Modular/Dependency.hs | 197 ++++++++---------- .../Distribution/Solver/Modular/Explore.hs | 2 +- .../src/Distribution/Solver/Modular/Index.hs | 16 -- .../Distribution/Solver/Modular/Linking.hs | 8 +- .../Distribution/Solver/Modular/Package.hs | 1 - .../Distribution/Solver/Modular/Validate.hs | 8 +- .../Distribution/Solver/Types/PackagePath.hs | 12 -- 8 files changed, 99 insertions(+), 151 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index 5d196f4fd9f..9de9ea16ee2 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -50,8 +50,7 @@ data BuildState = BS { index :: Index, -- ^ information about packages and their dependencies rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) - next :: BuildType, -- ^ kind of node to generate next - qualifyOptions :: QualifyOptions -- ^ qualification options + next :: BuildType -- ^ kind of node to generate next } -- | Map of available linking targets. @@ -105,7 +104,7 @@ scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names - qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps + qfdeps = qualifyDeps qpn fdeps -- Introduce all package flags qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals @@ -255,7 +254,6 @@ buildTree idx (IndependentGoals ind) igs = , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) , open = L.map topLevelGoal qpns , next = Goals - , qualifyOptions = defaultQualifyOptions idx } , linkingState = M.empty } diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 27debc9c6f0..4a27a62390f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -1,34 +1,38 @@ {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Solver.Modular.Dependency ( - -- * Variables - Var(..) + +module Distribution.Solver.Modular.Dependency + ( -- * Variables + Var (..) , showVar , varPN + -- * Conflict sets , ConflictSet , ConflictMap , CS.showConflictSet + -- * Constrained instances - , CI(..) + , CI (..) + -- * Flagged dependencies , FlaggedDeps - , FlaggedDep(..) - , LDep(..) - , Dep(..) - , PkgComponent(..) - , ExposedComponent(..) - , DependencyReason(..) + , FlaggedDep (..) + , LDep (..) + , Dep (..) + , PkgComponent (..) + , ExposedComponent (..) + , DependencyReason (..) , showDependencyReason , flattenFlaggedDeps - , QualifyOptions(..) , qualifyDeps , unqualifyDeps + -- * Reverse dependency map , RevDepMap + -- * Goals - , Goal(..) - , GoalReason(..) + , Goal (..) + , GoalReason (..) , QGoalReason , goalToVar , varToConflictSet @@ -39,21 +43,21 @@ module Distribution.Solver.Modular.Dependency ( , dependencyReasonToConflictSetWithVersionConflict ) where -import Prelude () import qualified Data.Map as M import qualified Data.Set as S import Distribution.Solver.Compat.Prelude hiding (pi) +import Prelude () -import Language.Haskell.Extension (Extension(..), Language(..)) +import Language.Haskell.Extension (Extension (..), Language (..)) -import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) +import Distribution.Solver.Modular.ConflictSet (ConflictMap, ConflictSet) +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Var import Distribution.Solver.Modular.Version -import qualified Distribution.Solver.Modular.ConflictSet as CS -import Distribution.Solver.Types.ComponentDeps (Component(..)) +import Distribution.Solver.Types.ComponentDeps (Component (..)) import Distribution.Solver.Types.PackagePath import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange @@ -85,14 +89,14 @@ type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. -data FlaggedDep qpn = - -- | Dependencies which are conditional on a flag choice. +data FlaggedDep qpn + = -- | Dependencies which are conditional on a flag choice. Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - -- | Dependencies which are conditional on whether or not a stanza + | -- | Dependencies which are conditional on whether or not a stanza -- (e.g., a test suite or benchmark) is enabled. - | Stanza (SN qpn) (TrueFlaggedDeps qpn) - -- | Dependencies which are always enabled, for the component 'comp'. - | Simple (LDep qpn) Component + Stanza (SN qpn) (TrueFlaggedDeps qpn) + | -- | Dependencies which are always enabled, for the component 'comp'. + Simple (LDep qpn) Component -- | Conservatively flatten out flagged dependencies -- @@ -102,10 +106,10 @@ flattenFlaggedDeps = concatMap aux where aux :: FlaggedDep qpn -> [(LDep qpn, Component)] aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f - aux (Stanza _ t) = flattenFlaggedDeps t - aux (Simple d c) = [(d, c)] + aux (Stanza _ t) = flattenFlaggedDeps t + aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps qpn +type TrueFlaggedDeps qpn = FlaggedDeps qpn type FalseFlaggedDeps qpn = FlaggedDeps qpn -- | A 'Dep' labeled with the reason it was introduced. @@ -119,11 +123,16 @@ data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. -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 +data Dep qpn + = -- | dependency on a package component + Dep (PkgComponent qpn) CI + | -- | dependency on a language extension + Ext Extension + | -- | dependency on a language version + Lang Language + | -- | dependency on a pkg-config package + Pkg PkgconfigName PkgconfigVersionRange + deriving (Functor) -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. @@ -132,8 +141,8 @@ data PkgComponent qpn = PkgComponent qpn ExposedComponent -- | A component that can be depended upon by another package, i.e., a library -- or an executable. -data ExposedComponent = - ExposedLib LibraryName +data ExposedComponent + = ExposedLib LibraryName | ExposedExe UnqualComponentName deriving (Eq, Ord, Show) @@ -147,43 +156,25 @@ data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Sta -- | Print the reason that a dependency was introduced. showDependencyReason :: DependencyReason QPN -> String showDependencyReason (DependencyReason qpn flags stanzas) = - intercalate " " $ - showQPN qpn + intercalate " " $ + showQPN qpn : map (uncurry showFlagValue) (M.toList flags) - ++ map (\s -> showSBool s True) (S.toList stanzas) - --- | Options for goal qualification (used in 'qualifyDeps') --- --- See also 'defaultQualifyOptions' -data QualifyOptions = QO { - -- | Do we have a version of base relying on another version of base? - qoBaseShim :: Bool - - -- Should dependencies of the setup script be treated as independent? - , qoSetupIndependent :: Bool - } - deriving Show + ++ map (\s -> showSBool s True) (S.toList stanzas) -- | Apply built-in rules for package qualifiers -- --- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', --- it is important that these 'QualifyOptions' are _static_. Qualification --- does NOT depend on flag assignment; in other words, it behaves the same no --- matter which choices the solver makes (modulo the global 'QualifyOptions'); --- we rely on this in 'linkDeps' (see comment there). --- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. -qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN -qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go +qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN +qualifyDeps (Q pp@(PackagePath ns q) pn) = go where go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 go1 :: FlaggedDep PN -> FlaggedDep QPN go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep comp) comp + go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep comp) comp -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like @@ -197,15 +188,14 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) goD :: Dep PN -> Component -> Dep QPN - goD (Ext ext) _ = Ext ext - goD (Lang lang) _ = Lang lang - goD (Pkg pkn vr) _ = Pkg pkn vr + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci - goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp - | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci - | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci + Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci + goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) comp + | comp == ComponentSetup = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci + | otherwise = Dep (Q (PackagePath ns inheritedQ) <$> dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup @@ -216,18 +206,9 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go -- a detailed discussion. inheritedQ :: Qualifier inheritedQ = case q of - QualSetup _ -> q - QualExe _ _ -> q - QualToplevel -> q - QualBase _ -> QualToplevel - - -- Should we qualify this goal with the 'Base' package path? - qBase :: PN -> Bool - qBase dep = qoBaseShim && unPackageName dep == "base" - - -- Should we qualify this goal with the 'Setup' package path? - qSetup :: Component -> Bool - qSetup comp = qoSetupIndependent && comp == ComponentSetup + QualSetup _ -> q + QualExe _ _ -> q + QualToplevel -> q -- | Remove qualifiers from set of dependencies -- @@ -244,8 +225,8 @@ unqualifyDeps = go go1 :: FlaggedDep QPN -> FlaggedDep PN go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) - go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) - go1 (Simple dep comp) = Simple (goLDep dep) comp + go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) + go1 (Simple dep comp) = Simple (goLDep dep) comp goLDep :: LDep QPN -> LDep PN goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) @@ -271,8 +252,8 @@ data Goal qpn = Goal (Var qpn) (GoalReason qpn) deriving (Eq, Show, Functor) -- | Reason why a goal is being added to a goal set. -data GoalReason qpn = - UserGoal -- introduced by a build target +data GoalReason qpn + = UserGoal -- introduced by a build target | DependencyGoal (DependencyReason qpn) -- introduced by a package deriving (Eq, Show, Functor) @@ -288,7 +269,7 @@ varToConflictSet = CS.singleton -- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal -- leads to a conflict. goalReasonToConflictSet :: GoalReason QPN -> ConflictSet -goalReasonToConflictSet UserGoal = CS.empty +goalReasonToConflictSet UserGoal = CS.empty goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr -- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the @@ -302,14 +283,14 @@ goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) | M.null flags && S.null stanzas = CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal -goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr +goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr -- | This function returns the solver variables responsible for the dependency. -- It drops the values chosen for flag and stanza variables, which are only -- needed for log messages. dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = - CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) + CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) where -- Filter out any flags that introduced the dependency with both values. -- They don't need to be included in the conflict set, because changing the @@ -327,16 +308,19 @@ dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = -- This function currently only specifies the reason for the conflict in the -- simple case where the 'DependencyReason' does not involve any flags or -- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN - -> Ver - -> DependencyReason QPN - -> ConflictSet dependencyReasonToConflictSetWithVersionConstraintConflict - dependency excludedVersion dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConstraintConflict dependency excludedVersion - | otherwise = dependencyReasonToConflictSet dr + :: QPN + -> Ver + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConstraintConflict + dependency + excludedVersion + dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConstraintConflict dependency excludedVersion + | otherwise = dependencyReasonToConflictSet dr -- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the -- conflict occurred because the conflict set variables introduced a version of @@ -346,13 +330,16 @@ dependencyReasonToConflictSetWithVersionConstraintConflict -- This function currently only specifies the reason for the conflict in the -- simple case where the 'DependencyReason' does not involve any flags or -- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. -dependencyReasonToConflictSetWithVersionConflict :: QPN - -> CS.OrderedVersionRange - -> DependencyReason QPN - -> ConflictSet dependencyReasonToConflictSetWithVersionConflict - pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) - | M.null flags && S.null stanzas = - CS.singletonWithConflict (P qpn) $ - CS.VersionConflict pkgWithVersionConstraint constraint - | otherwise = dependencyReasonToConflictSet dr + :: QPN + -> CS.OrderedVersionRange + -> DependencyReason QPN + -> ConflictSet +dependencyReasonToConflictSetWithVersionConflict + pkgWithVersionConstraint + constraint + dr@(DependencyReason qpn flags stanzas) + | M.null flags && S.null stanzas = + CS.singletonWithConflict (P qpn) $ + CS.VersionConflict pkgWithVersionConstraint constraint + | otherwise = dependencyReasonToConflictSet dr diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs index 90038a28f5c..d047ecda38e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -270,7 +270,7 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = let (PInfo deps _ _ _) = idx M.! pn M.! i - qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps + qdeps = qualifyDeps currentQPN deps couldBeResolved :: CS.Conflict -> Maybe ConflictSet couldBeResolved CS.OtherConflict = Nothing diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index 2f28d12de85..28ed5c9cd2d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -4,7 +4,6 @@ module Distribution.Solver.Modular.Index , ComponentInfo(..) , IsVisible(..) , IsBuildable(..) - , defaultQualifyOptions , mkIndex ) where @@ -57,18 +56,3 @@ mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) groupMap :: Ord a => [(a, b)] -> Map a [b] groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) - -defaultQualifyOptions :: Index -> QualifyOptions -defaultQualifyOptions idx = QO { - qoBaseShim = or [ dep == base - | -- Find all versions of base .. - Just is <- [M.lookup base idx] - -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is - -- .. and flatten all their dependencies .. - , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps - ] - , qoSetupIndependent = True - } - where - base = mkPackageName "base" diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs index 15514472c80..ead3e10c6d4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs @@ -61,8 +61,6 @@ data ValidateState = VS { , vsLinks :: Map QPN LinkGroup , vsFlags :: FAssignment , vsStanzas :: SAssignment - , vsQualifyOptions :: QualifyOptions - -- Saved qualified dependencies. Every time 'validateLinking' makes a -- package choice, it qualifies the package's dependencies and saves them in -- this map. Then the qualified dependencies are available for subsequent @@ -101,7 +99,7 @@ validateLinking index = (`runReader` initVS) . go goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask let PInfo deps _ _ _ = vsIndex vs ! pn ! i - qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps + qdeps = qualifyDeps qpn deps newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) @@ -129,7 +127,6 @@ validateLinking index = (`runReader` initVS) . go , vsLinks = M.empty , vsFlags = M.empty , vsStanzas = M.empty - , vsQualifyOptions = defaultQualifyOptions index , vsSaved = M.empty } @@ -275,8 +272,7 @@ linkDeps target = \deps -> do requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) requalify deps = do - vs <- get - return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) + return $ qualifyDeps target (unqualifyDeps deps) pickFlag :: QFN -> Bool -> UpdateState () pickFlag qfn b = do diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index ccd0e4d4a70..3c3591144dc 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -88,7 +88,6 @@ primaryPP :: PackagePath -> Bool primaryPP (PackagePath _ns q) = go q where go QualToplevel = True - go (QualBase _) = True go (QualSetup _) = False go (QualExe _ _) = False diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index 4af149b31cf..d6de20cc1de 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -108,9 +108,7 @@ data ValidateState = VS { -- Map from package name to the components that are required from that -- package. - requiredComponents :: Map QPN ComponentDependencyReasons, - - qualifyOptions :: QualifyOptions + requiredComponents :: Map QPN ComponentDependencyReasons } newtype Validate a = Validate (Reader ValidateState a) @@ -200,11 +198,10 @@ validate = go svd <- asks saved -- obtain saved dependencies aComps <- asks availableComponents rComps <- asks requiredComponents - qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice let (PInfo deps comps _ mfr) = idx ! pn ! i -- qualify the deps in the current scope - let qdeps = qualifyDeps qo qpn deps + let qdeps = qualifyDeps qpn deps -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps @@ -577,5 +574,4 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { , pa = PA M.empty M.empty M.empty , availableComponents = M.empty , requiredComponents = M.empty - , qualifyOptions = defaultQualifyOptions idx } diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..ee0103cd838 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -43,11 +43,6 @@ data Qualifier = -- | Top-level dependency in this namespace QualToplevel - -- | Any dependency on base is considered independent - -- - -- This makes it possible to have base shims. - | QualBase PackageName - -- | Setup dependency -- -- By rights setup dependencies ought to be nestable; after all, the setup @@ -72,18 +67,11 @@ data Qualifier = -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. --- --- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is --- there to make sure different dependencies on base are all independent. --- So we want to print something like @"A.base"@, where the @"A."@ part --- is the qualifier and @"base"@ is the actual dependency (which, for the --- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = Disp.empty dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> pretty pn2 <<>> Disp.text ":exe." -dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a From 91fe71a4c9897718469726c43092daa4e5ffb6dc Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 19 Mar 2025 16:57:10 +0800 Subject: [PATCH 005/122] refactor(cabal-install,Cabal): move programDbSignature to Cabal --- Cabal/src/Distribution/Simple/Program/Db.hs | 15 +++++++++++++++ .../src/Distribution/Client/ProjectPlanning.hs | 14 -------------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index c76b38e9923..bc5d0714aa3 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -67,6 +67,7 @@ module Distribution.Simple.Program.Db , ConfiguredProgs , updateUnconfiguredProgs , updateConfiguredProgs + , programDbSignature ) where import Distribution.Compat.Prelude @@ -564,3 +565,17 @@ requireProgramVersion verbosity prog range programDb = join $ either (dieWithException verbosity) return `fmap` lookupProgramVersion verbosity prog range programDb + +-- | Select the bits of a 'ProgramDb' to monitor for value changes. +-- Use 'programsMonitorFiles' for the files to monitor. +programDbSignature :: ProgramDb -> [ConfiguredProgram] +programDbSignature progdb = + [ prog + { programMonitorFiles = [] + , programOverrideEnv = + filter + ((/= "PATH") . fst) + (programOverrideEnv prog) + } + | prog <- configuredPrograms progdb + ] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 968b915ee2a..3f92507eb01 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1036,20 +1036,6 @@ programsMonitorFiles progdb = (programPath prog) ] --- | Select the bits of a 'ProgramDb' to monitor for value changes. --- Use 'programsMonitorFiles' for the files to monitor. -programDbSignature :: ProgramDb -> [ConfiguredProgram] -programDbSignature progdb = - [ prog - { programMonitorFiles = [] - , programOverrideEnv = - filter - ((/= "PATH") . fst) - (programOverrideEnv prog) - } - | prog <- configuredPrograms progdb - ] - getInstalledPackages :: Verbosity -> Compiler From 777bad8e2ee6ad588cdd88dfd6add3eea359ce8e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 8 May 2025 15:07:59 +0800 Subject: [PATCH 006/122] refactor(cabal-install): separate GenericReadyPackage from ReadyPackage --- cabal-install/cabal-install.cabal | 1 + .../src/Distribution/Client/Configure.hs | 2 +- .../src/Distribution/Client/Install.hs | 1 + .../src/Distribution/Client/Types.hs | 4 +-- .../Client/Types/GenericReadyPackage.hs | 36 +++++++++++++++++++ .../Distribution/Client/Types/ReadyPackage.hs | 33 +---------------- 6 files changed, 42 insertions(+), 35 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 6e4256cb13d..41ef502755a 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -221,6 +221,7 @@ library Distribution.Client.Types.ConfiguredId Distribution.Client.Types.ConfiguredPackage Distribution.Client.Types.Credentials + Distribution.Client.Types.GenericReadyPackage Distribution.Client.Types.InstallMethod Distribution.Client.Types.OverwritePolicy Distribution.Client.Types.PackageLocation diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index bf0b7fdec27..cc00d0b826a 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -52,7 +52,7 @@ import Distribution.Client.Targets , userToPackageConstraint ) import Distribution.Client.Types as Source - +import Distribution.Client.Types.ReadyPackage (ReadyPackage) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 675fbd6bca3..5bdb62902f9 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -126,6 +126,7 @@ import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Targets import Distribution.Client.Types as Source import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..)) +import Distribution.Client.Types.ReadyPackage (ReadyPackage) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Solver.Types.PackageFixedDeps diff --git a/cabal-install/src/Distribution/Client/Types.hs b/cabal-install/src/Distribution/Client/Types.hs index 841a4dbc9d2..e8647b1edb5 100644 --- a/cabal-install/src/Distribution/Client/Types.hs +++ b/cabal-install/src/Distribution/Client/Types.hs @@ -22,7 +22,7 @@ module Distribution.Client.Types , module Distribution.Client.Types.BuildResults , module Distribution.Client.Types.PackageLocation , module Distribution.Client.Types.PackageSpecifier - , module Distribution.Client.Types.ReadyPackage + , module Distribution.Client.Types.GenericReadyPackage , module Distribution.Client.Types.Repo , module Distribution.Client.Types.RepoName , module Distribution.Client.Types.SourcePackageDb @@ -33,9 +33,9 @@ import Distribution.Client.Types.AllowNewer import Distribution.Client.Types.BuildResults import Distribution.Client.Types.ConfiguredId import Distribution.Client.Types.ConfiguredPackage +import Distribution.Client.Types.GenericReadyPackage import Distribution.Client.Types.PackageLocation import Distribution.Client.Types.PackageSpecifier -import Distribution.Client.Types.ReadyPackage import Distribution.Client.Types.Repo import Distribution.Client.Types.RepoName import Distribution.Client.Types.SourcePackageDb diff --git a/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs new file mode 100644 index 00000000000..a8b673cb36b --- /dev/null +++ b/cabal-install/src/Distribution/Client/Types/GenericReadyPackage.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.Types.GenericReadyPackage + ( GenericReadyPackage (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) + +import Distribution.Solver.Types.PackageFixedDeps + +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be +-- installed already, hence itself ready to be installed. +newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. + deriving + ( Eq + , Show + , Generic + , Package + , PackageFixedDeps + , HasMungedPackageId + , HasUnitId + , PackageInstalled + , Binary + ) + +-- Can't newtype derive this +instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where + type Key (GenericReadyPackage srcpkg) = Key srcpkg + nodeKey (ReadyPackage spkg) = nodeKey spkg + nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg diff --git a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs index e04b5af79c8..5eeb8e5e194 100644 --- a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs +++ b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs @@ -1,41 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilies #-} - module Distribution.Client.Types.ReadyPackage ( GenericReadyPackage (..) , ReadyPackage ) where -import Distribution.Client.Compat.Prelude -import Prelude () - -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled) - import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage) +import Distribution.Client.Types.GenericReadyPackage (GenericReadyPackage (..)) import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc) -import Distribution.Solver.Types.PackageFixedDeps - --- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be --- installed already, hence itself ready to be installed. -newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'. - deriving - ( Eq - , Show - , Generic - , Package - , PackageFixedDeps - , HasMungedPackageId - , HasUnitId - , PackageInstalled - , Binary - ) - --- Can't newtype derive this -instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where - type Key (GenericReadyPackage srcpkg) = Key srcpkg - nodeKey (ReadyPackage spkg) = nodeKey spkg - nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc) From bad3d9fa85cdd114c2a8453905142a4c1f66a6b9 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 21 Mar 2025 13:36:33 +0800 Subject: [PATCH 007/122] refactor(cabal-install): simplify the logic behind pkgsUseSharedLibrary, pkgsUseProfilingLibrary, pkgsUseProfilingLibraryShared We do not want to check the compiler. --- .../Distribution/Client/ProjectPlanning.hs | 76 +++++-------------- 1 file changed, 17 insertions(+), 59 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 3f92507eb01..d7997f43255 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -176,7 +176,6 @@ import Distribution.Simple.LocalBuildInfo , pkgComponents ) -import Distribution.Simple.BuildWay import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program import Distribution.Simple.Program.Db @@ -212,8 +211,6 @@ import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import qualified Distribution.Simple.Configure as Cabal -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.LocalBuildInfo as Cabal import qualified Distribution.Simple.Setup as Cabal @@ -1715,8 +1712,7 @@ elaborateInstallPlan (map fst src_comps) let whyNotPerComp = why_not_per_component src_comps case NE.nonEmpty whyNotPerComp of - Nothing -> do - elaborationWarnings + Nothing -> return comps Just notPerCompReasons -> do checkPerPackageOk comps notPerCompReasons @@ -1787,7 +1783,7 @@ elaborateInstallPlan <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) -- TODO: Maybe exclude Backpack too - (elab0, elaborationWarnings) = elaborateSolverToCommon spkg + elab0 = elaborateSolverToCommon spkg pkgid = elabPkgSourceId elab0 pd = elabPkgDescription elab0 @@ -2098,10 +2094,9 @@ elaborateInstallPlan -- Knot tying: the final elab includes the -- pkgInstalledId, which is calculated by hashing many -- of the other fields of the elaboratedPackage. - elaborationWarnings return elab where - (elab0@ElaboratedConfiguredPackage{..}, elaborationWarnings) = + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg elab1 = @@ -2187,7 +2182,7 @@ elaborateInstallPlan elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc - -> (ElaboratedConfiguredPackage, LogProgress ()) + -> ElaboratedConfiguredPackage elaborateSolverToCommon pkg@( SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) @@ -2196,7 +2191,7 @@ elaborateInstallPlan deps0 _exe_deps0 ) = - (elaboratedPackage, wayWarnings pkgid) + elaboratedPackage where elaboratedPackage = ElaboratedConfiguredPackage{..} @@ -2304,7 +2299,7 @@ elaborateInstallPlan elabBuildOptions = LBC.BuildOptions { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = canBuildSharedLibs && pkgid `Set.member` pkgsUseSharedLibrary + , withSharedLib = pkgid `Set.member` pkgsUseSharedLibrary , withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib , withDynExe = perPkgOptionFlag pkgid False packageConfigDynExe @@ -2315,8 +2310,8 @@ elaborateInstallPlan , withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe , withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still , withProfExe = profExe - , withProfLib = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary - , withProfLibShared = canBuildProfilingSharedLibs && pkgid `Set.member` pkgsUseProfilingLibraryShared + , withProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + , withProfLibShared = pkgid `Set.member` pkgsUseProfilingLibraryShared , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization @@ -2485,7 +2480,9 @@ elaborateInstallPlan needsSharedLib pkgid = fromMaybe - compilerShouldUseSharedLibByDefault + -- FIXME + -- compilerShouldUseSharedLibByDefault + False -- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that. ( case pkgSharedLib of Just v -> Just v @@ -2496,7 +2493,7 @@ elaborateInstallPlan -- Case 3: If --enable-profiling is passed, then we are going to -- build profiled dynamic, so no need for shared libraries. case pkgProf of - Just True -> if canBuildProfilingSharedLibs then Nothing else Just True + Just True -> Nothing _ -> Just True -- But don't necessarily turn off shared library generation if -- --disable-executable-dynamic is passed. The shared objects might @@ -2508,53 +2505,12 @@ elaborateInstallPlan pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe pkgProf = perPkgOptionMaybe pkgid packageConfigProf - -- TODO: [code cleanup] move this into the Cabal lib. It's currently open - -- coded in Distribution.Simple.Configure, but should be made a proper - -- function of the Compiler or CompilerInfo. - compilerShouldUseSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs - GHCJS -> GHCJS.isDynamic compiler - _ -> False - - compilerShouldUseProfilingLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == ProfWay && canBuildProfilingLibs - _ -> False - - compilerShouldUseProfilingSharedLibByDefault = - case compilerFlavor compiler of - GHC -> GHC.compilerBuildWay compiler == ProfDynWay && canBuildProfilingSharedLibs - _ -> False - - -- Returns False if we definitely can't build shared libs - canBuildWayLibs predicate = case predicate compiler of - Just can_build -> can_build - -- If we don't know for certain, just assume we can - -- which matches behaviour in previous cabal releases - Nothing -> True - - canBuildSharedLibs = canBuildWayLibs dynamicSupported - canBuildProfilingLibs = canBuildWayLibs profilingVanillaSupported - canBuildProfilingSharedLibs = canBuildWayLibs profilingDynamicSupported - - wayWarnings pkg = do - when - (needsProfilingLib pkg && not canBuildProfilingLibs) - (warnProgress (text "Compiler does not support building p libraries, profiling is disabled")) - when - (needsSharedLib pkg && not canBuildSharedLibs) - (warnProgress (text "Compiler does not support building dyn libraries, dynamic libraries are disabled")) - when - (needsProfilingLibShared pkg && not canBuildProfilingSharedLibs) - (warnProgress (text "Compiler does not support building p_dyn libraries, profiling dynamic libraries are disabled.")) - pkgsUseProfilingLibrary :: Set PackageId pkgsUseProfilingLibrary = packagesWithLibDepsDownwardClosedProperty needsProfilingLib needsProfilingLib pkg = - fromFlagOrDefault compilerShouldUseProfilingLibByDefault (profBothFlag <> profLibFlag) + fromFlagOrDefault False (profBothFlag <> profLibFlag) where pkgid = packageId pkg profBothFlag = lookupPerPkgOption pkgid packageConfigProf @@ -2566,7 +2522,9 @@ elaborateInstallPlan needsProfilingLibShared pkg = fromMaybe - compilerShouldUseProfilingSharedLibByDefault + -- FIXME + -- compilerShouldUseProfilingSharedLibByDefault + False -- case 1: If --enable-profiling-shared is passed explicitly, honour that ( case profLibSharedFlag of Just v -> Just v @@ -2575,7 +2533,7 @@ elaborateInstallPlan case pkgProf of -- case 2: --enable-executable-dynamic + --enable-profiling -- turn on shared profiling libraries - Just True -> if canBuildProfilingSharedLibs then Just True else Nothing + Just True -> Just True _ -> Nothing -- But don't necessarily turn off shared library generation is -- --disable-executable-dynamic is passed. The shared objects might From 07476fd926a95c20d6170d1f7b0765503ba6e7df Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 19 Mar 2025 13:31:48 +0800 Subject: [PATCH 008/122] refactor(cabal-install): remove independent goals --- .../Distribution/Solver/Modular/Builder.hs | 8 +- .../Solver/Modular/ConfiguredConversion.hs | 2 +- .../Distribution/Solver/Modular/Dependency.hs | 8 +- .../Distribution/Solver/Modular/Package.hs | 6 - .../Distribution/Solver/Modular/Preference.hs | 4 +- .../src/Distribution/Solver/Modular/Solver.hs | 6 +- .../Solver/Types/PackageConstraint.hs | 12 +- .../Distribution/Solver/Types/PackagePath.hs | 27 +- .../src/Distribution/Solver/Types/Settings.hs | 9 - .../parser-tests/Tests/ParserTests.hs | 2 - .../src/Distribution/Client/Config.hs | 1 - .../src/Distribution/Client/Dependency.hs | 21 +- .../src/Distribution/Client/Fetch.hs | 2 - .../src/Distribution/Client/Freeze.hs | 2 - .../src/Distribution/Client/Install.hs | 2 - .../src/Distribution/Client/InstallPlan.hs | 25 +- .../src/Distribution/Client/ProjectConfig.hs | 2 - .../Client/ProjectConfig/FieldGrammar.hs | 1 - .../Client/ProjectConfig/Legacy.hs | 2 - .../Distribution/Client/ProjectConfig/Lens.hs | 5 - .../Client/ProjectConfig/Types.hs | 2 - .../Distribution/Client/ProjectPlanning.hs | 7 +- .../src/Distribution/Client/Setup.hs | 23 - .../Distribution/Client/SolverInstallPlan.hs | 51 +- .../Distribution/Client/InstallPlan.hs | 3 +- .../Distribution/Client/ProjectConfig.hs | 5 - .../Distribution/Client/TreeDiffInstances.hs | 1 - .../Distribution/Solver/Modular/DSL.hs | 24 +- .../Solver/Modular/DSL/TestCaseUtils.hs | 29 +- .../Distribution/Solver/Modular/QuickCheck.hs | 52 +- .../Distribution/Solver/Modular/Solver.hs | 466 ------------------ 31 files changed, 73 insertions(+), 737 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index 9de9ea16ee2..b56dd7965ca 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -35,7 +35,6 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings -- | All state needed to build and link the search tree. It has a type variable -- because the linking phase doesn't need to know about the state used to build @@ -246,8 +245,8 @@ alreadyLinked = error "addLinking called on tree that already contains linked no -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. -buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason -buildTree idx (IndependentGoals ind) igs = +buildTree :: Index -> [PN] -> Tree () QGoalReason +buildTree idx igs = build Linker { buildState = BS { index = idx @@ -260,8 +259,7 @@ buildTree idx (IndependentGoals ind) igs = where topLevelGoal qpn = PkgGoal qpn UserGoal - qpns | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs + qpns = L.map (Q (PackagePath QualToplevel)) igs {------------------------------------------------------------------------------- Goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 0e2e8ad5baa..06938efd762 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -55,7 +55,7 @@ convPI (PI _ (I _ (Inst pi))) = Left pi convPI pi = Right (packageId (either id id (convConfId pi))) convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = +convConfId (PI (Q (PackagePath q) pn) (I v loc)) = case loc of Inst pi -> Left (PreExistingId sourceId pi) _otherwise diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 4a27a62390f..5ca70df8b76 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -166,7 +166,7 @@ showDependencyReason (DependencyReason qpn flags stanzas) = -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN -qualifyDeps (Q pp@(PackagePath ns q) pn) = go +qualifyDeps (Q pp@(PackagePath q) pn) = go where go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 @@ -192,10 +192,10 @@ qualifyDeps (Q pp@(PackagePath ns q) pn) = go goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci + Dep (Q (PackagePath (QualExe pn qpn)) <$> dep) ci goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) comp - | comp == ComponentSetup = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath ns inheritedQ) <$> dep) ci + | comp == ComponentSetup = Dep (Q (PackagePath (QualSetup pn)) <$> dep) ci + | otherwise = Dep (Q (PackagePath inheritedQ) <$> dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index 3c3591144dc..ea3352f5c7c 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -10,7 +10,6 @@ module Distribution.Solver.Modular.Package , PN , QPV , instI - , makeIndependent , primaryPP , setupPP , showI @@ -98,8 +97,3 @@ primaryPP (PackagePath _ns q) = go q setupPP :: PackagePath -> Bool setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _) = False - --- | Qualify a target package with its own name so that its dependencies are not --- required to be consistent with other targets. -makeIndependent :: PN -> QPN -makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs index 9e0d5fb4d22..39600474965 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -420,8 +420,8 @@ deferSetupExeChoices = go go x = x noSetupOrExe :: Goal QPN -> Bool - noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False - noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False + noSetupOrExe (Goal (P (Q (PackagePath (QualSetup _)) _)) _) = False + noSetupOrExe (Goal (P (Q (PackagePath (QualExe _ _)) _)) _) = False noSetupOrExe _ = True -- | Transformation that tries to avoid making weak flag choices early. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index b2c89fc1537..24f8c40dd81 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -62,7 +62,6 @@ data SolverConfig = SolverConfig { countConflicts :: CountConflicts, fineGrainedConflicts :: FineGrainedConflicts, minimizeConflictSet :: MinimizeConflictSet, - independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, shadowPkgs :: ShadowPkgs, strongFlags :: StrongFlags, @@ -144,7 +143,8 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = P.onlyConstrained pkgIsExplicit OnlyConstrainedNone -> id) - buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals) + + buildPhase = buildTree idx (S.toList userGoals) allExplicit = M.keysSet userConstraints `S.union` userGoals @@ -250,5 +250,5 @@ _removeGR = trav go dummy = DependencyGoal $ DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + (Q (PackagePath QualToplevel) (mkPackageName "$")) M.empty S.empty diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 06c5ae169fa..7887ba21840 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -68,15 +68,13 @@ scopeToPackageName (ScopeAnySetupQualifier pn) = pn scopeToPackageName (ScopeAnyQualifier pn) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = - let namespaceMatches DefaultNamespace = True - namespaceMatches (Independent namespacePn) = pn == namespacePn - in namespaceMatches ns && q == QualToplevel && pn == pn' -constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = +constraintScopeMatches (ScopeTarget pn) (Q (PackagePath q) pn') = + q == QualToplevel && pn == pn' +constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath q') pn') = q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = - let setup (PackagePath _ (QualSetup _)) = True - setup _ = False + let setup (PackagePath (QualSetup _)) = True + setup _ = False in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index ee0103cd838..9eae0acf988 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,6 +1,5 @@ module Distribution.Solver.Types.PackagePath ( PackagePath(..) - , Namespace(..) , Qualifier(..) , dispQualifier , Qualified(..) @@ -15,29 +14,9 @@ import Distribution.Package (PackageName) import Distribution.Pretty (pretty, flatStyle) 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 +data PackagePath = PackagePath Qualifier deriving (Eq, Ord, Show) --- | Top-level namespace --- --- Package choices in different namespaces are considered completely independent --- by the solver. -data Namespace = - -- | The default namespace - DefaultNamespace - - -- | A namespace for a specific build target - | Independent PackageName - deriving (Eq, Ord, Show) - --- | Pretty-prints a namespace. The result is either empty or --- ends in a period, so it can be prepended onto a qualifier. -dispNamespace :: Namespace -> Disp.Doc -dispNamespace DefaultNamespace = Disp.empty -dispNamespace (Independent i) = pretty i <<>> Disp.text "." - -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = -- | Top-level dependency in this namespace @@ -82,8 +61,8 @@ type QPN = Qualified PackageName -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc -dispQPN (Q (PackagePath ns qual) pn) = - dispNamespace ns <<>> dispQualifier qual <<>> pretty pn +dispQPN (Q (PackagePath qual) pn) = + dispQualifier qual <<>> pretty pn -- | String representation of a qualified package name. showQPN :: QPN -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs index 306c0c12185..1fb6a08b0b9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Settings.hs @@ -2,7 +2,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Solver.Types.Settings ( ReorderGoals(..) - , IndependentGoals(..) , PreferOldest(..) , MinimizeConflictSet(..) , AvoidReinstalls(..) @@ -38,9 +37,6 @@ newtype FineGrainedConflicts = FineGrainedConflicts Bool newtype MinimizeConflictSet = MinimizeConflictSet Bool deriving (BooleanFlag, Eq, Generic, Show) -newtype IndependentGoals = IndependentGoals Bool - deriving (BooleanFlag, Eq, Generic, Show) - newtype PreferOldest = PreferOldest Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -72,7 +68,6 @@ newtype SolveExecutables = SolveExecutables Bool instance Binary ReorderGoals instance Binary CountConflicts instance Binary FineGrainedConflicts -instance Binary IndependentGoals instance Binary PreferOldest instance Binary MinimizeConflictSet instance Binary AvoidReinstalls @@ -85,7 +80,6 @@ instance Binary SolveExecutables instance Structured ReorderGoals instance Structured CountConflicts instance Structured FineGrainedConflicts -instance Structured IndependentGoals instance Structured PreferOldest instance Structured MinimizeConflictSet instance Structured AvoidReinstalls @@ -125,6 +119,3 @@ instance Parsec AllowBootLibInstalls where instance Parsec PreferOldest where parsec = PreferOldest <$> parsec - -instance Parsec IndependentGoals where - parsec = IndependentGoals <$> parsec diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index d9ab2f5247f..f625cb0cfff 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -41,7 +41,6 @@ import Distribution.Solver.Types.Settings ( AllowBootLibInstalls (..) , CountConflicts (..) , FineGrainedConflicts (..) - , IndependentGoals (..) , MinimizeConflictSet (..) , OnlyConstrained (..) , PreferOldest (..) @@ -226,7 +225,6 @@ testProjectConfigShared = do projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls True) projectConfigOnlyConstrained = Flag OnlyConstrainedAll projectConfigPerComponent = Flag True - projectConfigIndependentGoals = Flag (IndependentGoals True) projectConfigPreferOldest = Flag (PreferOldest True) projectConfigProgPathExtra = toNubList ["/foo/bar", "/baz/quux"] projectConfigMultiRepl = toFlag True diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 0653b449504..e213502fcf9 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -426,7 +426,6 @@ instance Semigroup SavedConfig where , installCountConflicts = combine installCountConflicts , installFineGrainedConflicts = combine installFineGrainedConflicts , installMinimizeConflictSet = combine installMinimizeConflictSet - , installIndependentGoals = combine installIndependentGoals , installPreferOldest = combine installPreferOldest , installShadowPkgs = combine installShadowPkgs , installStrongFlags = combine installStrongFlags diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 594afb9e24f..1990b54d1ac 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -48,7 +48,6 @@ module Distribution.Client.Dependency , setCountConflicts , setFineGrainedConflicts , setMinimizeConflictSet - , setIndependentGoals , setAvoidReinstalls , setShadowPkgs , setStrongFlags @@ -192,7 +191,6 @@ data DepResolverParams = DepResolverParams , depResolverCountConflicts :: CountConflicts , depResolverFineGrainedConflicts :: FineGrainedConflicts , depResolverMinimizeConflictSet :: MinimizeConflictSet - , depResolverIndependentGoals :: IndependentGoals , depResolverAvoidReinstalls :: AvoidReinstalls , depResolverShadowPkgs :: ShadowPkgs , depResolverStrongFlags :: StrongFlags @@ -235,8 +233,6 @@ showDepResolverParams p = ++ show (asBool (depResolverFineGrainedConflicts p)) ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) - ++ "\nindependent goals: " - ++ show (asBool (depResolverIndependentGoals p)) ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p)) ++ "\nshadow packages: " @@ -297,7 +293,6 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex = , depResolverCountConflicts = CountConflicts True , depResolverFineGrainedConflicts = FineGrainedConflicts True , depResolverMinimizeConflictSet = MinimizeConflictSet False - , depResolverIndependentGoals = IndependentGoals False , depResolverAvoidReinstalls = AvoidReinstalls False , depResolverShadowPkgs = ShadowPkgs False , depResolverStrongFlags = StrongFlags False @@ -374,12 +369,6 @@ setMinimizeConflictSet minimize params = { depResolverMinimizeConflictSet = minimize } -setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams -setIndependentGoals indep params = - params - { depResolverIndependentGoals = indep - } - setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams setAvoidReinstalls avoid params = params @@ -797,7 +786,7 @@ resolveDependencies -> Progress String String SolverInstallPlan resolveDependencies platform comp pkgConfigDB params = Step (showDepResolverParams finalparams) $ - fmap (validateSolverResult platform comp indGoals) $ + fmap (validateSolverResult platform comp) $ formatProgress $ runSolver ( SolverConfig @@ -805,7 +794,6 @@ resolveDependencies platform comp pkgConfigDB params = cntConflicts fineGrained minimize - indGoals noReinstalls shadowing strFlags @@ -837,7 +825,6 @@ resolveDependencies platform comp pkgConfigDB params = cntConflicts fineGrained minimize - indGoals noReinstalls shadowing strFlags @@ -923,12 +910,11 @@ interpretPackagesPreference selected defaultPref prefs = validateSolverResult :: Platform -> CompilerInfo - -> IndependentGoals -> [ResolverPackage UnresolvedPkgLoc] -> SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = +validateSolverResult platform comp pkgs = case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of + [] -> case SolverInstallPlan.new graph of Right plan -> plan Left problems -> error (formatPlanProblems problems) problems -> error (formatPkgProblems problems) @@ -1161,7 +1147,6 @@ resolveWithoutDependencies _countConflicts _fineGrained _minimizeConflictSet - _indGoals _avoidReinstalls _shadowing _strFlags diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 033d3a01e14..4842705123a 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -197,7 +197,6 @@ planPackages then Nothing else Just maxBackjumps ) - . setIndependentGoals independentGoals . setReorderGoals reorderGoals . setCountConflicts countConflicts . setFineGrainedConflicts fineGrainedConflicts @@ -235,7 +234,6 @@ planPackages countConflicts = fromFlag (fetchCountConflicts fetchFlags) fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) - independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags) strongFlags = fromFlag (fetchStrongFlags fetchFlags) maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index a03b45b6a2d..b5002021fc3 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -226,7 +226,6 @@ planPackages then Nothing else Just maxBackjumps ) - . setIndependentGoals independentGoals . setReorderGoals reorderGoals . setCountConflicts countConflicts . setFineGrainedConflicts fineGrainedConflicts @@ -259,7 +258,6 @@ planPackages countConflicts = fromFlag (freezeCountConflicts freezeFlags) fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) - independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags) strongFlags = fromFlag (freezeStrongFlags freezeFlags) maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags) diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 5bdb62902f9..84acdd12d79 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -598,7 +598,6 @@ planPackages then Nothing else Just maxBackjumps ) - . setIndependentGoals independentGoals . setReorderGoals reorderGoals . setCountConflicts countConflicts . setFineGrainedConflicts fineGrainedConflicts @@ -668,7 +667,6 @@ planPackages countConflicts = fromFlag (installCountConflicts installFlags) fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) - independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags) shadowPkgs = fromFlag (installShadowPkgs installFlags) strongFlags = fromFlag (installStrongFlags installFlags) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index df719fa5926..ee8cd15c709 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -34,7 +34,6 @@ module Distribution.Client.InstallPlan , toMap , keys , keysSet - , planIndepGoals , depends , fromSolverInstallPlan , fromSolverInstallPlanWithProgress @@ -98,7 +97,6 @@ import Text.PrettyPrint import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.InstSolverPackage -import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Utils.LogProgress @@ -255,7 +253,6 @@ instance data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)) - , planIndepGoals :: !IndependentGoals } -- | 'GenericInstallPlan' specialised to most commonly used types. @@ -269,14 +266,12 @@ mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg) => String -> Graph (GenericPlanPackage ipkg srcpkg) - -> IndependentGoals -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph indepGoals = +mkInstallPlan loc graph = assert (valid loc graph) GenericInstallPlan { planGraph = graph - , planIndepGoals = indepGoals } internalError :: WithCallStack (String -> String -> a) @@ -306,16 +301,11 @@ instance ) => Binary (GenericInstallPlan ipkg srcpkg) where - put - GenericInstallPlan - { planGraph = graph - , planIndepGoals = indepGoals - } = put graph >> put indepGoals + put p = put (planGraph p) get = do graph <- get - indepGoals <- get - return $! mkInstallPlan "(instance Binary)" graph indepGoals + return $! mkInstallPlan "(instance Binary)" graph data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc @@ -364,10 +354,9 @@ showPlanPackageTag (Installed _) = "Installed" -- | Build an installation plan from a valid set of resolved packages. new :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) + => Graph (GenericPlanPackage ipkg srcpkg) -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals +new = mkInstallPlan "new" toGraph :: GenericInstallPlan ipkg srcpkg @@ -401,7 +390,7 @@ remove -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) + mkInstallPlan "remove" newGraph where newGraph = Graph.fromDistinctList $ @@ -521,7 +510,6 @@ fromSolverInstallPlan f plan = mkInstallPlan "fromSolverInstallPlan" (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) where (_, _, pkgs'') = foldl' @@ -567,7 +555,6 @@ fromSolverInstallPlanWithProgress f plan = do mkInstallPlan "fromSolverInstallPlanWithProgress" (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) where f' (pidMap, ipiMap, pkgs) pkg = do pkgs' <- f (mapDep pidMap ipiMap) pkg diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 32d8048b2b5..efb9b810bfd 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -391,7 +391,6 @@ resolveSolverSettings solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained solverSettingIndexState = flagToMaybe projectConfigIndexState solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos - solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals solverSettingPreferOldest = fromFlag projectConfigPreferOldest -- solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs -- solverSettingReinstall = fromFlag projectConfigReinstall @@ -414,7 +413,6 @@ resolveSolverSettings , projectConfigStrongFlags = Flag (StrongFlags False) , projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False) , projectConfigOnlyConstrained = Flag OnlyConstrainedNone - , projectConfigIndependentGoals = Flag (IndependentGoals False) , projectConfigPreferOldest = Flag (PreferOldest False) -- projectConfigShadowPkgs = Flag False, -- projectConfigReinstall = Flag False, diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 591bf0ba03d..b1832cfbbd4 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -104,7 +104,6 @@ projectConfigSharedFieldGrammar source = <*> optionalFieldDef "allow-boot-library-installs" L.projectConfigAllowBootLibInstalls mempty <*> optionalFieldDef "reject-unconstrained-dependencies" L.projectConfigOnlyConstrained mempty <*> optionalFieldDef "per-component" L.projectConfigPerComponent mempty - <*> optionalFieldDef "independent-goals" L.projectConfigIndependentGoals mempty <*> optionalFieldDef "prefer-oldest" L.projectConfigPreferOldest mempty <*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra <*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 32b3670b479..e1dad0195ed 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -759,7 +759,6 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , installFineGrainedConflicts = projectConfigFineGrainedConflicts , installMinimizeConflictSet = projectConfigMinimizeConflictSet , installPerComponent = projectConfigPerComponent - , installIndependentGoals = projectConfigIndependentGoals , installPreferOldest = projectConfigPreferOldest , -- installShadowPkgs = projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags @@ -1043,7 +1042,6 @@ convertToLegacySharedConfig , installCountConflicts = projectConfigCountConflicts , installFineGrainedConflicts = projectConfigFineGrainedConflicts , installMinimizeConflictSet = projectConfigMinimizeConflictSet - , installIndependentGoals = projectConfigIndependentGoals , installPreferOldest = projectConfigPreferOldest , installShadowPkgs = mempty -- projectConfigShadowPkgs, , installStrongFlags = projectConfigStrongFlags diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 03e05835cd6..29a2c0125bb 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -44,7 +44,6 @@ import Distribution.Solver.Types.Settings ( AllowBootLibInstalls (..) , CountConflicts (..) , FineGrainedConflicts (..) - , IndependentGoals (..) , MinimizeConflictSet (..) , OnlyConstrained (..) , PreferOldest (..) @@ -180,10 +179,6 @@ projectConfigPerComponent :: Lens' ProjectConfigShared (Flag Bool) projectConfigPerComponent f s = fmap (\x -> s{T.projectConfigPerComponent = x}) (f (T.projectConfigPerComponent s)) {-# INLINEABLE projectConfigPerComponent #-} -projectConfigIndependentGoals :: Lens' ProjectConfigShared (Flag IndependentGoals) -projectConfigIndependentGoals f s = fmap (\x -> s{T.projectConfigIndependentGoals = x}) (f (T.projectConfigIndependentGoals s)) -{-# INLINEABLE projectConfigIndependentGoals #-} - projectConfigProjectFile :: Lens' ProjectConfigShared (Flag FilePath) projectConfigProjectFile f s = fmap (\x -> s{T.projectConfigProjectFile = x}) (f (T.projectConfigProjectFile s)) {-# INLINEABLE projectConfigProjectFile #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 220834a331c..8a32ca31815 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -228,7 +228,6 @@ data ProjectConfigShared = ProjectConfigShared , projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls , projectConfigOnlyConstrained :: Flag OnlyConstrained , projectConfigPerComponent :: Flag Bool - , projectConfigIndependentGoals :: Flag IndependentGoals , projectConfigPreferOldest :: Flag PreferOldest , projectConfigProgPathExtra :: NubList FilePath , projectConfigMultiRepl :: Flag Bool @@ -449,7 +448,6 @@ data SolverSettings = SolverSettings , solverSettingOnlyConstrained :: OnlyConstrained , solverSettingIndexState :: Maybe TotalIndexState , solverSettingActiveRepos :: Maybe ActiveRepos - , solverSettingIndependentGoals :: IndependentGoals , solverSettingPreferOldest :: PreferOldest -- Things that only make sense for manual mode, not --local mode -- too much control! diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d7997f43255..149254ecde4 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -160,7 +160,6 @@ import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb -import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage @@ -1319,7 +1318,6 @@ planPackages resolverParams :: DepResolverParams resolverParams = setMaxBackjumps solverSettingMaxBackjumps - . setIndependentGoals solverSettingIndependentGoals . setReorderGoals solverSettingReorderGoals . setCountConflicts solverSettingCountConflicts . setFineGrainedConflicts solverSettingFineGrainedConflicts @@ -2769,7 +2767,6 @@ extractElabBuildStyle _ = BuildAndInstall instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new - (IndependentGoals False) (Graph.fromDistinctList (Map.elems ready_map)) where pkgs = InstallPlan.toList plan @@ -3299,7 +3296,7 @@ pruneInstallPlanToTargets -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) + InstallPlan.new . Graph.fromDistinctList -- We have to do the pruning in two passes . pruneInstallPlanPass2 @@ -3761,7 +3758,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets) ) - $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) + $ fmap InstallPlan.new . checkBrokenDeps . Graph.fromDistinctList . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 81f2d69ff0a..889113847bc 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -1409,7 +1409,6 @@ data FetchFlags = FetchFlags , fetchCountConflicts :: Flag CountConflicts , fetchFineGrainedConflicts :: Flag FineGrainedConflicts , fetchMinimizeConflictSet :: Flag MinimizeConflictSet - , fetchIndependentGoals :: Flag IndependentGoals , fetchPreferOldest :: Flag PreferOldest , fetchShadowPkgs :: Flag ShadowPkgs , fetchStrongFlags :: Flag StrongFlags @@ -1432,7 +1431,6 @@ defaultFetchFlags = , fetchCountConflicts = Flag (CountConflicts True) , fetchFineGrainedConflicts = Flag (FineGrainedConflicts True) , fetchMinimizeConflictSet = Flag (MinimizeConflictSet False) - , fetchIndependentGoals = Flag (IndependentGoals False) , fetchPreferOldest = Flag (PreferOldest False) , fetchShadowPkgs = Flag (ShadowPkgs False) , fetchStrongFlags = Flag (StrongFlags False) @@ -1514,8 +1512,6 @@ fetchCommand = (\v flags -> flags{fetchFineGrainedConflicts = v}) fetchMinimizeConflictSet (\v flags -> flags{fetchMinimizeConflictSet = v}) - fetchIndependentGoals - (\v flags -> flags{fetchIndependentGoals = v}) fetchPreferOldest (\v flags -> flags{fetchPreferOldest = v}) fetchShadowPkgs @@ -1544,7 +1540,6 @@ data FreezeFlags = FreezeFlags , freezeCountConflicts :: Flag CountConflicts , freezeFineGrainedConflicts :: Flag FineGrainedConflicts , freezeMinimizeConflictSet :: Flag MinimizeConflictSet - , freezeIndependentGoals :: Flag IndependentGoals , freezePreferOldest :: Flag PreferOldest , freezeShadowPkgs :: Flag ShadowPkgs , freezeStrongFlags :: Flag StrongFlags @@ -1565,7 +1560,6 @@ defaultFreezeFlags = , freezeCountConflicts = Flag (CountConflicts True) , freezeFineGrainedConflicts = Flag (FineGrainedConflicts True) , freezeMinimizeConflictSet = Flag (MinimizeConflictSet False) - , freezeIndependentGoals = Flag (IndependentGoals False) , freezePreferOldest = Flag (PreferOldest False) , freezeShadowPkgs = Flag (ShadowPkgs False) , freezeStrongFlags = Flag (StrongFlags False) @@ -1636,8 +1630,6 @@ freezeCommand = (\v flags -> flags{freezeFineGrainedConflicts = v}) freezeMinimizeConflictSet (\v flags -> flags{freezeMinimizeConflictSet = v}) - freezeIndependentGoals - (\v flags -> flags{freezeIndependentGoals = v}) freezePreferOldest (\v flags -> flags{freezePreferOldest = v}) freezeShadowPkgs @@ -2240,7 +2232,6 @@ data InstallFlags = InstallFlags , installCountConflicts :: Flag CountConflicts , installFineGrainedConflicts :: Flag FineGrainedConflicts , installMinimizeConflictSet :: Flag MinimizeConflictSet - , installIndependentGoals :: Flag IndependentGoals , installPreferOldest :: Flag PreferOldest , installShadowPkgs :: Flag ShadowPkgs , installStrongFlags :: Flag StrongFlags @@ -2285,7 +2276,6 @@ defaultInstallFlags = , installCountConflicts = Flag (CountConflicts True) , installFineGrainedConflicts = Flag (FineGrainedConflicts True) , installMinimizeConflictSet = Flag (MinimizeConflictSet False) - , installIndependentGoals = Flag (IndependentGoals False) , installPreferOldest = Flag (PreferOldest False) , installShadowPkgs = Flag (ShadowPkgs False) , installStrongFlags = Flag (StrongFlags False) @@ -2644,8 +2634,6 @@ installOptions showOrParseArgs = (\v flags -> flags{installFineGrainedConflicts = v}) installMinimizeConflictSet (\v flags -> flags{installMinimizeConflictSet = v}) - installIndependentGoals - (\v flags -> flags{installIndependentGoals = v}) installPreferOldest (\v flags -> flags{installPreferOldest = v}) installShadowPkgs @@ -3597,8 +3585,6 @@ optionSolverFlags -> (Flag FineGrainedConflicts -> flags -> flags) -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) - -> (flags -> Flag IndependentGoals) - -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag PreferOldest) -> (Flag PreferOldest -> flags -> flags) -> (flags -> Flag ShadowPkgs) @@ -3622,8 +3608,6 @@ optionSolverFlags setfgc getmc setmc - getig - setig getpo setpo getsip @@ -3676,13 +3660,6 @@ optionSolverFlags (fmap asBool . getmc) (setmc . fmap MinimizeConflictSet) (yesNoOpt showOrParseArgs) - , option - [] - ["independent-goals"] - "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." - (fmap asBool . getig) - (setig . fmap IndependentGoals) - (yesNoOpt showOrParseArgs) , option [] ["prefer-oldest"] diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 17dcf6d9398..28e415f57af 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -73,7 +73,6 @@ import Distribution.Version ) import Distribution.Solver.Types.ResolverPackage -import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage @@ -90,7 +89,6 @@ type SolverPlanIndex = Graph SolverPlanPackage data SolverInstallPlan = SolverInstallPlan { planIndex :: !SolverPlanIndex - , planIndepGoals :: !IndependentGoals } deriving (Generic) @@ -142,12 +140,11 @@ showPlanPackage (Configured spkg) = -- | Build an installation plan from a valid set of resolved packages. new - :: IndependentGoals - -> SolverPlanIndex + :: SolverPlanIndex -> Either [SolverPlanProblem] SolverInstallPlan -new indepGoals index = - case problems indepGoals index of - [] -> Right (SolverInstallPlan index indepGoals) +new index = + case problems index of + [] -> Right (SolverInstallPlan index) probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage] @@ -167,8 +164,7 @@ remove -> Either [SolverPlanProblem] (SolverInstallPlan) -remove shouldRemove plan = - new (planIndepGoals plan) newIndex +remove shouldRemove plan = new newIndex where newIndex = Graph.fromDistinctList $ @@ -185,12 +181,8 @@ remove shouldRemove plan = -- plan has to have a valid configuration (see 'configuredPackageValid'). -- -- * if the result is @False@ use 'problems' to get a detailed list. -valid - :: IndependentGoals - -> SolverPlanIndex - -> Bool -valid indepGoals index = - null $ problems indepGoals index +valid :: SolverPlanIndex -> Bool +valid = null . problems data SolverPlanProblem = PackageMissingDeps @@ -239,10 +231,9 @@ showPlanProblem (PackageStateInvalid pkg pkg') = -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. problems - :: IndependentGoals - -> SolverPlanIndex + :: SolverPlanIndex -> [SolverPlanProblem] -problems indepGoals index = +problems index = [ PackageMissingDeps pkg ( mapMaybe @@ -256,7 +247,7 @@ problems indepGoals index = ] ++ [ PackageInconsistency name inconsistencies | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index + dependencyInconsistencies index ] ++ [ PackageStateInvalid pkg pkg' | pkg <- Foldable.toList index @@ -275,10 +266,9 @@ problems indepGoals index = -- cycle. Such cycles may or may not be an issue; either way, we don't check -- for them here. dependencyInconsistencies - :: IndependentGoals - -> SolverPlanIndex + :: SolverPlanIndex -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = +dependencyInconsistencies index = concatMap dependencyInconsistencies' subplans where subplans :: [SolverPlanIndex] @@ -286,7 +276,7 @@ dependencyInconsistencies indepGoals index = -- Not Graph.closure!! map (nonSetupClosure index) - (rootSets indepGoals index) + (rootSets index) -- NB: When we check for inconsistencies, packages from the setup -- scripts don't count as part of the closure (this way, we @@ -317,16 +307,9 @@ nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 -- | Compute the root sets of a plan -- -- A root set is a set of packages whose dependency closure must be consistent. --- This is the set of all top-level library roots (taken together normally, or --- as singletons sets if we are considering them as independent goals), along --- with all setup dependencies of all packages. -rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]] -rootSets (IndependentGoals indepGoals) index = - if indepGoals - then map (: []) libRoots - else - [libRoots] - ++ setupRoots index +-- This is the set of all top-level library roots taken together. +rootSets :: SolverPlanIndex -> [[SolverId]] +rootSets index = [libRoots] ++ setupRoots index where libRoots :: [SolverId] libRoots = libraryRoots index @@ -434,7 +417,7 @@ closed = null . Graph.broken -- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to -- find out which packages are. consistent :: SolverPlanIndex -> Bool -consistent = null . dependencyInconsistencies (IndependentGoals False) +consistent = null . dependencyInconsistencies -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index 9db7109fbc6..920aa0ce1aa 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -15,7 +15,6 @@ import qualified Distribution.Compat.Graph as Graph import Distribution.Package import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.PackageFixedDeps -import Distribution.Solver.Types.Settings import Distribution.Version import Control.Concurrent (threadDelay) @@ -266,7 +265,7 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do ( map InstallPlan.PreExisting ipkgs ++ map InstallPlan.Configured srcpkgs ) - return $ InstallPlan.new (IndependentGoals False) index + return $ InstallPlan.new index -- | Generate a random directed acyclic graph, based on the algorithm presented -- here diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index caee779671b..ebf6b87eb71 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -635,7 +635,6 @@ instance Arbitrary ProjectConfigShared where projectConfigAllowBootLibInstalls <- arbitrary projectConfigOnlyConstrained <- arbitrary projectConfigPerComponent <- arbitrary - projectConfigIndependentGoals <- arbitrary projectConfigPreferOldest <- arbitrary projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken projectConfigMultiRepl <- arbitrary @@ -682,7 +681,6 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigAllowBootLibInstalls <*> shrinker projectConfigOnlyConstrained <*> shrinker projectConfigPerComponent - <*> shrinker projectConfigIndependentGoals <*> shrinker projectConfigPreferOldest <*> shrinker projectConfigProgPathExtra <*> shrinker projectConfigMultiRepl @@ -1043,9 +1041,6 @@ instance Arbitrary FineGrainedConflicts where instance Arbitrary MinimizeConflictSet where arbitrary = MinimizeConflictSet <$> arbitrary -instance Arbitrary IndependentGoals where - arbitrary = IndependentGoals <$> arbitrary - instance Arbitrary PreferOldest where arbitrary = PreferOldest <$> arbitrary diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index ef4f9fb7c9f..3ee56e04b9a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -45,7 +45,6 @@ instance ToExpr ProjectConfigPath instance ToExpr ConstraintSource instance ToExpr CountConflicts instance ToExpr FineGrainedConflicts -instance ToExpr IndependentGoals instance ToExpr InstallMethod instance ToExpr InstallOutcome instance ToExpr LocalRepo diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index d1d70f59348..f01c4c3e92d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -270,7 +270,6 @@ data ExampleVar data ExampleQualifier = QualNone - | QualIndep ExamplePkgName | QualSetup ExamplePkgName | -- The two package names are the build target and the package containing the -- setup script. @@ -789,7 +788,6 @@ exResolve -> CountConflicts -> FineGrainedConflicts -> MinimizeConflictSet - -> IndependentGoals -> PreferOldest -> ReorderGoals -> AllowBootLibInstalls @@ -812,7 +810,6 @@ exResolve countConflicts fineGrainedConflicts minimizeConflictSet - indepGoals prefOldest reorder allowBootLibInstalls @@ -857,17 +854,16 @@ exResolve setCountConflicts countConflicts $ setFineGrainedConflicts fineGrainedConflicts $ setMinimizeConflictSet minimizeConflictSet $ - setIndependentGoals indepGoals $ - (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ - setReorderGoals reorder $ - setMaxBackjumps mbj $ - setAllowBootLibInstalls allowBootLibInstalls $ - setOnlyConstrained onlyConstrained $ - setEnableBackjumping enableBj $ - setSolveExecutables solveExes $ - setGoalOrder goalOrder $ - setSolverVerbosity verbosity $ - standardInstallPolicy instIdx avaiIdx targets' + (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ + setReorderGoals reorder $ + setMaxBackjumps mbj $ + setAllowBootLibInstalls allowBootLibInstalls $ + setOnlyConstrained onlyConstrained $ + setEnableBackjumping enableBj $ + setSolveExecutables solveExes $ + setGoalOrder goalOrder $ + setSolverVerbosity verbosity $ + standardInstallPolicy instIdx avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown toConstraint (ExVersionConstraint scope v) = diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index afd1419d30c..e4753de25b9 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -7,7 +7,6 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils , maxBackjumps , disableFineGrainedConflicts , minimizeConflictSet - , independentGoals , preferOldest , allowBootLibInstalls , onlyConstrained @@ -64,11 +63,6 @@ minimizeConflictSet :: SolverTest -> SolverTest minimizeConflictSet test = test{testMinimizeConflictSet = MinimizeConflictSet True} --- | Combinator to turn on --independent-goals behavior, i.e. solve --- for the goals as if we were solving for each goal independently. -independentGoals :: SolverTest -> SolverTest -independentGoals test = test{testIndepGoals = IndependentGoals True} - -- | Combinator to turn on --prefer-oldest preferOldest :: SolverTest -> SolverTest preferOldest test = test{testPreferOldest = PreferOldest True} @@ -117,7 +111,6 @@ data SolverTest = SolverTest , testMaxBackjumps :: Maybe Int , testFineGrainedConflicts :: FineGrainedConflicts , testMinimizeConflictSet :: MinimizeConflictSet - , testIndepGoals :: IndependentGoals , testPreferOldest :: PreferOldest , testAllowBootLibInstalls :: AllowBootLibInstalls , testOnlyConstrained :: OnlyConstrained @@ -220,7 +213,6 @@ mkTestExtLangPC exts langs mPkgConfigDb db label targets result = , testMaxBackjumps = Nothing , testFineGrainedConflicts = FineGrainedConflicts True , testMinimizeConflictSet = MinimizeConflictSet False - , testIndepGoals = IndependentGoals False , testPreferOldest = PreferOldest False , testAllowBootLibInstalls = AllowBootLibInstalls False , testOnlyConstrained = OnlyConstrainedNone @@ -251,7 +243,6 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> (CountConflicts True) testFineGrainedConflicts testMinimizeConflictSet - testIndepGoals testPreferOldest (ReorderGoals False) testAllowBootLibInstalls @@ -307,20 +298,10 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> toQPN q pn = P.Q pp (C.mkPackageName pn) where pp = case q of - QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel - QualIndep p -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - P.QualToplevel + QualNone -> P.PackagePath P.QualToplevel QualSetup s -> - P.PackagePath - P.DefaultNamespace - (P.QualSetup (C.mkPackageName s)) - QualIndepSetup p s -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - (P.QualSetup (C.mkPackageName s)) + P.PackagePath (P.QualSetup (C.mkPackageName s)) + QualIndepSetup _ s -> + P.PackagePath (P.QualSetup (C.mkPackageName s)) QualExe p1 p2 -> - P.PackagePath - P.DefaultNamespace - (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) + P.PackagePath (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 9994acee2e9..844681ae5dc 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -52,14 +52,13 @@ import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils tests :: [TestTree] tests = [ testPropertyWithSeed "solver does not throw exceptions" $ - \test goalOrder reorderGoals indepGoals prefOldest -> + \test goalOrder reorderGoals prefOldest -> let r = solve (EnableBackjumping True) (FineGrainedConflicts True) reorderGoals (CountConflicts True) - indepGoals prefOldest (getBlind <$> goalOrder) test @@ -69,7 +68,7 @@ tests = -- parameters on the second run. The test also applies parameters that -- can affect the existence of a solution to both runs. testPropertyWithSeed "target and goal order do not affect solvability" $ - \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> + \test targetOrder mGoalOrder1 mGoalOrder2 -> let r1 = solve' mGoalOrder1 test r2 = solve' mGoalOrder2 test{testTargets = targets2} solve' goalOrder = @@ -78,7 +77,6 @@ tests = (FineGrainedConflicts True) (ReorderGoals False) (CountConflicts True) - indepGoals (PreferOldest False) (getBlind <$> goalOrder) targets = testTargets test @@ -88,25 +86,8 @@ tests = in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) - , testPropertyWithSeed - "solvable without --independent-goals => solvable with --independent-goals" - $ \test reorderGoals -> - let r1 = solve' (IndependentGoals False) test - r2 = solve' (IndependentGoals True) test - solve' indep = - solve - (EnableBackjumping True) - (FineGrainedConflicts True) - reorderGoals - (CountConflicts True) - indep - (PreferOldest False) - Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> - isRight (resultPlan r1) `implies` isRight (resultPlan r2) , testPropertyWithSeed "backjumping does not affect solvability" $ - \test reorderGoals indepGoals -> + \test reorderGoals -> let r1 = solve' (EnableBackjumping True) test r2 = solve' (EnableBackjumping False) test solve' enableBj = @@ -115,14 +96,13 @@ tests = (FineGrainedConflicts False) reorderGoals (CountConflicts True) - indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $ - \test reorderGoals indepGoals -> + \test reorderGoals -> let r1 = solve' (FineGrainedConflicts True) test r2 = solve' (FineGrainedConflicts False) test solve' fineGrainedConflicts = @@ -131,14 +111,13 @@ tests = fineGrainedConflicts reorderGoals (CountConflicts True) - indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) , testPropertyWithSeed "prefer oldest does not affect solvability" $ - \test reorderGoals indepGoals -> + \test reorderGoals -> let r1 = solve' (PreferOldest True) test r2 = solve' (PreferOldest False) test solve' prefOldest = @@ -147,7 +126,6 @@ tests = (FineGrainedConflicts True) reorderGoals (CountConflicts True) - indepGoals prefOldest Nothing in counterexample (showResults r1 r2) $ @@ -163,7 +141,7 @@ tests = testPropertyWithSeed "backjumping does not affect the result (with static goal order)" - $ \test reorderGoals indepGoals -> + $ \test reorderGoals -> let r1 = solve' (EnableBackjumping True) test r2 = solve' (EnableBackjumping False) test solve' enableBj = @@ -172,7 +150,6 @@ tests = (FineGrainedConflicts False) reorderGoals (CountConflicts False) - indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ @@ -180,7 +157,7 @@ tests = resultPlan r1 === resultPlan r2 , testPropertyWithSeed "fine-grained conflicts does not affect the result (with static goal order)" - $ \test reorderGoals indepGoals -> + $ \test reorderGoals -> let r1 = solve' (FineGrainedConflicts True) test r2 = solve' (FineGrainedConflicts False) test solve' fineGrainedConflicts = @@ -189,7 +166,6 @@ tests = fineGrainedConflicts reorderGoals (CountConflicts False) - indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ @@ -211,9 +187,6 @@ tests = ++ resultLog result ++ ["result: " ++ show (resultPlan result)] - implies :: Bool -> Bool -> Bool - implies x y = not x || y - isRight :: Either a b -> Bool isRight (Right _) = True isRight _ = False @@ -230,12 +203,11 @@ solve -> FineGrainedConflicts -> ReorderGoals -> CountConflicts - -> IndependentGoals -> PreferOldest -> Maybe VarOrdering -> SolverTest -> Result -solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goalOrder test = +solve enableBj fineGrainedConflicts reorder countConflicts prefOldest goalOrder test = let (lg, result) = runProgress $ exResolve @@ -250,7 +222,6 @@ solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goal countConflicts fineGrainedConflicts (MinimizeConflictSet False) - indep prefOldest reorder (AllowBootLibInstalls False) @@ -526,11 +497,6 @@ instance Arbitrary ReorderGoals where shrink (ReorderGoals reorder) = [ReorderGoals False | reorder] -instance Arbitrary IndependentGoals where - arbitrary = IndependentGoals <$> arbitrary - - shrink (IndependentGoals indep) = [IndependentGoals False | indep] - instance Arbitrary PreferOldest where arbitrary = PreferOldest <$> arbitrary @@ -624,7 +590,6 @@ instance ArbitraryOrd pn => ArbitraryOrd (Variable pn) instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a) instance ArbitraryOrd P.PackagePath instance ArbitraryOrd P.Qualifier -instance ArbitraryOrd P.Namespace instance ArbitraryOrd OptionalStanza instance ArbitraryOrd FlagName instance ArbitraryOrd PackageName @@ -636,7 +601,6 @@ instance ArbitraryOrd ShortText where 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] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index a1f5eed3c62..e0a568724de 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -42,25 +42,14 @@ tests = , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)]) - , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)]) , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)]) - , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure - , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C")) - , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B")) , runTest $ mkTest [] "unknown target" ["A"] (solverFailure (isInfixOf "unknown package: A")) ] , testGroup "Flagged dependencies" [ runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)]) - , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) ] , testGroup "Lifting dependencies out of conditionals" @@ -166,9 +155,7 @@ tests = , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)]) , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure - , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) , runTest $ testTestSuiteWithFlag "test suite with flag" ] , testGroup @@ -181,7 +168,6 @@ tests = , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)]) , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)]) - , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) , runTest $ setupStanzaTest1 , runTest $ setupStanzaTest2 ] @@ -353,19 +339,6 @@ tests = , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D", 1)]) ] - , testGroup - "Independent goals" - [ runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) - , runTest $ testIndepGoals2 "indepGoals2" - , runTest $ testIndepGoals3 "indepGoals3" - , runTest $ testIndepGoals4 "indepGoals4" - , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder - , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder - , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder - , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder - , expectFailBecause "#9466" $ runTest $ testIndepGoals7 "indepGoals7" - , runTest $ testIndepGoals8 "indepGoals8" - ] , -- Tests designed for the backjumping blog post testGroup "Backjumping" @@ -378,7 +351,6 @@ tests = , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)]) , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)]) , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) ] , testGroup "main library dependencies" @@ -968,13 +940,10 @@ tests = ] ] where - indep = independentGoals mkvrThis = V.thisVersion . makeV mkvrOrEarlier = V.orEarlierVersion . makeV makeV v = V.mkVersion [v, 0, 0] -data GoalOrder = FixedGoalOrder | DefaultGoalOrder - {------------------------------------------------------------------------------- Specific example database for the tests -------------------------------------------------------------------------------} @@ -993,18 +962,6 @@ db1 = , Right $ exAv "Z" 1 [] ] --- In this example, we _can_ install C and D as independent goals, but we have --- to pick two different versions for B (arbitrarily) -db2 :: ExampleDb -db2 = - [ Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1] - , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2] - ] - db3 :: ExampleDb db3 = [ Right $ exAv "A" 1 [] @@ -1014,49 +971,6 @@ db3 = , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] ] --- | Like db3, but the flag picks a different package rather than a --- different package version --- --- In db3 we cannot install C and D as independent goals because: --- --- * The multiple instance restriction says C and D _must_ share B --- * Since C relies on A-1, C needs B to be compiled with flagB on --- * Since D relies on A-2, D needs B to be compiled with flagB off --- * Hence C and D have incompatible requirements on B's flags. --- --- However, _even_ if we don't check explicitly that we pick the same flag --- assignment for 0.B and 1.B, we will still detect the problem because --- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to --- 1.A and therefore we cannot link 0.B to 1.B. --- --- In db4 the situation however is trickier. We again cannot install --- packages C and D as independent goals because: --- --- * As above, the multiple instance restriction says that C and D _must_ share B --- * Since C relies on Ax-2, it requires B to be compiled with flagB off --- * Since D relies on Ay-2, it requires B to be compiled with flagB on --- * Hence C and D have incompatible requirements on B's flags. --- --- But now this requirement is more indirect. If we only check dependencies --- we don't see the problem: --- --- * We link 0.B to 1.B --- * 0.B relies on Ay-1 --- * 1.B relies on Ax-1 --- --- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since --- we only ever assign to one of these, these constraints are never broken. -db4 :: ExampleDb -db4 = - [ Right $ exAv "Ax" 1 [] - , Right $ exAv "Ax" 2 [] - , Right $ exAv "Ay" 1 [] - , Right $ exAv "Ay" 2 [] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] - , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] - ] - -- | Simple database containing one package with a manual flag. dbManualFlags :: ExampleDb dbManualFlags = @@ -1279,24 +1193,6 @@ db10 = , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] ] --- | This database tests that a package's setup dependencies are correctly --- linked when the package is linked. See pull request #3268. --- --- When A and B are installed as independent goals, their dependencies on C must --- be linked, due to the single instance restriction. Since C depends on D, 0.D --- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D --- and 1.C-setup.D must be linked. However, D's two link groups must remain --- independent. The solver should be able to choose D-1 for C's library and D-2 --- for C's setup script. -dbSetupDeps :: ExampleDb -dbSetupDeps = - [ Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - -- | Tests for dealing with base shims db11 :: ExampleDb db11 = @@ -1578,46 +1474,6 @@ testCyclicDependencyErrorMessages name = goals :: [ExampleVar] goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A' .. 'E']] --- | Check that the solver can backtrack after encountering the SIR (issue #2843) --- --- When A and B are installed as independent goals, the single instance --- restriction prevents B from depending on C. This database tests that the --- solver can backtrack after encountering the single instance restriction and --- choose the only valid flag assignment (-flagA +flagB): --- --- > flagA flagB B depends on --- > On _ C-* --- > Off On E-* <-- only valid flag assignment --- > Off Off D-2.0, C-* --- --- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D, --- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have --- C in the transitive closure of B's dependencies, because that would mean we --- would need two instances of C: one built against D-1.0 and one built against --- D-2.0. -db16 :: ExampleDb -db16 = - [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ - exAv - "B" - 1 - [ ExFix "D" 2 - , exFlagged - "flagA" - [ExAny "C"] - [ exFlagged - "flagB" - [ExAny "E"] - [ExAny "C"] - ] - ] - , Right $ exAv "C" 1 [ExAny "D"] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - , Right $ exAv "E" 1 [] - ] - -- Try to get the solver to backtrack while satisfying -- reject-unconstrained-dependencies: both the first and last versions of A -- require packages outside the closed set, so it will have to try the @@ -1631,84 +1487,6 @@ db17 = , Right $ exAv "C" 1 [ExAny "B"] ] --- | This test checks that when the solver discovers a constraint on a --- package's version after choosing to link that package, it can backtrack to --- try alternative versions for the linked-to package. See pull request #3327. --- --- When A and B are installed as independent goals, their dependencies on C --- must be linked. Since C depends on D, A and B's dependencies on D must also --- be linked. This test fixes the goal order so that the solver chooses D-2 for --- both 0.D and 1.D before it encounters the test suites' constraints. The --- solver must backtrack to try D-1 for both 0.D and 1.D. -testIndepGoals2 :: String -> SolverTest -testIndepGoals2 name = - goalOrder goals $ - independentGoals $ - enableAllTests $ - mkTest db name ["A", "B"] $ - solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)] - where - db :: ExampleDb - db = - [ Right $ exAv "A" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1] - , Right $ exAv "B" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1] - , Right $ exAv "C" 1 [ExAny "D"] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - - goals :: [ExampleVar] - goals = - [ P (QualIndep "A") "A" - , P (QualIndep "A") "C" - , P (QualIndep "A") "D" - , P (QualIndep "B") "B" - , P (QualIndep "B") "C" - , P (QualIndep "B") "D" - , S (QualIndep "B") "B" TestStanzas - , S (QualIndep "A") "A" TestStanzas - ] - --- | Issue #2834 --- When both A and B are installed as independent goals, their dependencies on --- C must be linked. The only combination of C's flags that is consistent with --- A and B's dependencies on D is -flagA +flagB. This database tests that the --- solver can backtrack to find the right combination of flags (requiring F, but --- not E or G) and apply it to both 0.C and 1.C. --- --- > flagA flagB C depends on --- > On _ D-1, E-* --- > Off On F-* <-- Only valid choice --- > Off Off D-2, G-* --- --- The single instance restriction means we cannot have one instance of C --- built against D-1 and one instance built against D-2; since A depends on --- D-1, and B depends on C-2, it is therefore important that C cannot depend --- on any version of D. -db18 :: ExampleDb -db18 = - [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2] - , Right $ - exAv - "C" - 1 - [ exFlagged - "flagA" - [ExFix "D" 1, ExAny "E"] - [ exFlagged - "flagB" - [ExAny "F"] - [ExFix "D" 2, ExAny "G"] - ] - ] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - , Right $ exAv "E" 1 [] - , Right $ exAv "F" 1 [] - , Right $ exAv "G" 1 [] - ] - -- | When both values for flagA introduce package B, the solver should be able -- to choose B before choosing a value for flagA. It should try to choose a -- version for B that is in the union of the version ranges required by +flagA @@ -1792,215 +1570,6 @@ testBackjumpingWithCommonDependency name = , Right $ exAv "B" 1 [] ] --- | Tricky test case with independent goals (issue #2842) --- --- Suppose we are installing D, E, and F as independent goals: --- --- * D depends on A-* and C-1, requiring A-1 to be built against C-1 --- * E depends on B-* and C-2, requiring B-1 to be built against C-2 --- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built --- against the same version of C, violating the single instance restriction. --- --- We can visualize this DB as: --- --- > C-1 C-2 --- > /|\ /|\ --- > / | \ / | \ --- > / | X | \ --- > | | / \ | | --- > | |/ \| | --- > | + + | --- > | | | | --- > | A B | --- > \ |\ /| / --- > \ | \ / | / --- > \| V |/ --- > D F E -testIndepGoals3 :: String -> SolverTest -testIndepGoals3 name = - goalOrder goals $ - independentGoals $ - mkTest db name ["D", "E", "F"] anySolverFailure - where - db :: ExampleDb - db = - [ Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1] - , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2] - , Right $ exAv "F" 1 [ExAny "A", ExAny "B"] - ] - - goals :: [ExampleVar] - goals = - [ P (QualIndep "D") "D" - , P (QualIndep "D") "C" - , P (QualIndep "D") "A" - , P (QualIndep "E") "E" - , P (QualIndep "E") "C" - , P (QualIndep "E") "B" - , P (QualIndep "F") "F" - , P (QualIndep "F") "B" - , P (QualIndep "F") "C" - , P (QualIndep "F") "A" - ] - --- | This test checks that the solver correctly backjumps when dependencies --- of linked packages are not linked. It is an example where the conflict set --- from enforcing the single instance restriction is not sufficient. See pull --- request #3327. --- --- When A, B, and C are installed as independent goals with the specified goal --- order, the first choice that the solver makes for E is 0.E-2. Then, when it --- chooses dependencies for B and C, it links both 1.E and 2.E to 0.E. Finally, --- the solver discovers C's test's constraint on E. It must backtrack to try --- 1.E-1 and then link 2.E to 1.E. Backjumping all the way to 0.E does not lead --- to a solution, because 0.E's version is constrained by A and cannot be --- changed. -testIndepGoals4 :: String -> SolverTest -testIndepGoals4 name = - goalOrder goals $ - independentGoals $ - enableAllTests $ - mkTest db name ["A", "B", "C"] $ - solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("E", 1), ("E", 2)] - where - db :: ExampleDb - db = - [ Right $ exAv "A" 1 [ExFix "E" 2] - , Right $ exAv "B" 1 [ExAny "D"] - , Right $ exAv "C" 1 [ExAny "D"] `withTest` exTest "test" [ExFix "E" 1] - , Right $ exAv "D" 1 [ExAny "E"] - , Right $ exAv "E" 1 [] - , Right $ exAv "E" 2 [] - ] - - goals :: [ExampleVar] - goals = - [ P (QualIndep "A") "A" - , P (QualIndep "A") "E" - , P (QualIndep "B") "B" - , P (QualIndep "B") "D" - , P (QualIndep "B") "E" - , P (QualIndep "C") "C" - , P (QualIndep "C") "D" - , P (QualIndep "C") "E" - , S (QualIndep "C") "C" TestStanzas - ] - --- | Test the trace messages that we get when a package refers to an unknown pkg --- --- TODO: Currently we don't actually test the trace messages, and this particular --- test still succeeds. The trace can only be verified by hand. -db21 :: ExampleDb -db21 = - [ Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown - , Right $ exAv "B" 1 [] - ] - --- | A variant of 'db21', which actually fails. -db22 :: ExampleDb -db22 = - [ Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "C"] - ] - --- | Another test for the unknown package message. This database tests that --- filtering out redundant conflict set messages in the solver log doesn't --- interfere with generating a message about a missing package (part of issue --- #3617). The conflict set for the missing package is {A, B}. That conflict set --- is propagated up the tree to the level of A. Since the conflict set is the --- same at both levels, the solver only keeps one of the backjumping messages. -db23 :: ExampleDb -db23 = - [ Right $ exAv "A" 1 [ExAny "B"] - ] - --- | Database for (unsuccessfully) trying to expose a bug in the handling --- of implied linking constraints. The question is whether an implied linking --- constraint should only have the introducing package in its conflict set, --- or also its link target. --- --- It turns out that as long as the Single Instance Restriction is in place, --- it does not matter, because there will always be an option that is failing --- due to the SIR, which contains the link target in its conflict set. --- --- Even if the SIR is not in place, if there is a solution, one will always --- be found, because without the SIR, linking is always optional, but never --- necessary. -testIndepGoals5 :: String -> GoalOrder -> SolverTest -testIndepGoals5 name fixGoalOrder = - case fixGoalOrder of - FixedGoalOrder -> goalOrder goals test - DefaultGoalOrder -> test - where - test :: SolverTest - test = - independentGoals $ - mkTest db name ["X", "Y"] $ - solverSuccess - [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)] - - db :: ExampleDb - db = - [ Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"] - , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2] - , Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - ] - - goals :: [ExampleVar] - goals = - [ P (QualIndep "X") "X" - , P (QualIndep "X") "A" - , P (QualIndep "X") "B" - , P (QualIndep "X") "C" - , P (QualIndep "Y") "Y" - , P (QualIndep "Y") "A" - , P (QualIndep "Y") "B" - , P (QualIndep "Y") "C" - ] - --- | A simplified version of 'testIndepGoals5'. -testIndepGoals6 :: String -> GoalOrder -> SolverTest -testIndepGoals6 name fixGoalOrder = - case fixGoalOrder of - FixedGoalOrder -> goalOrder goals test - DefaultGoalOrder -> test - where - test :: SolverTest - test = - independentGoals $ - mkTest db name ["X", "Y"] $ - solverSuccess - [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)] - - db :: ExampleDb - db = - [ Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"] - , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2] - , Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "B" 1 [] - , Right $ exAv "B" 2 [] - ] - - goals :: [ExampleVar] - goals = - [ P (QualIndep "X") "X" - , P (QualIndep "X") "A" - , P (QualIndep "X") "B" - , P (QualIndep "Y") "Y" - , P (QualIndep "Y") "A" - , P (QualIndep "Y") "B" - ] - dbExts1 :: ExampleDb dbExts1 = [ Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)] @@ -2017,33 +1586,6 @@ dbLangs1 = , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"] ] --- This test checks how the scope of a constraint interacts with qualified goals. --- If you specify `A == 2`, that top-level should /not/ apply to an independent goal! -testIndepGoals7 :: String -> SolverTest -testIndepGoals7 name = - constraints [ExVersionConstraint (scopeToplevel "A") (V.thisVersion (V.mkVersion [2, 0, 0]))] $ - independentGoals $ - mkTest dbIndepGoals78 name ["A"] $ - -- The more recent version should be picked by the solver. As said - -- above, the top-level A==2 should not apply to an independent goal. - solverSuccess [("A", 3)] - -dbIndepGoals78 :: ExampleDb -dbIndepGoals78 = - [ Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "A" 3 [] - ] - --- This test checks how the scope of a constraint interacts with qualified goals. --- If you specify `any.A == 2`, then that should apply inside an independent goal. -testIndepGoals8 :: String -> SolverTest -testIndepGoals8 name = - constraints [ExVersionConstraint (ScopeAnyQualifier "A") (V.thisVersion (V.mkVersion [2, 0, 0]))] $ - independentGoals $ - mkTest dbIndepGoals78 name ["A"] $ - solverSuccess [("A", 2)] - -- | cabal must set enable-exe to false in order to avoid the unavailable -- dependency. Flags are true by default. The flag choice causes "pkg" to -- depend on "false-dep". @@ -2321,14 +1863,6 @@ dbBJ7 = , Right $ exAv "C" 2 [] ] --- | Conflict sets for SIR (C shared subgoal of independent goals A, B) -dbBJ8 :: ExampleDb -dbBJ8 = - [ Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - ] - {------------------------------------------------------------------------------- Databases for build-tool-depends -------------------------------------------------------------------------------} From c4fedf78a0ca9dccca6055bb9036f5f33bd746d3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 009/122] refactor(cabal-install): remove base-on-base trick --- .../Distribution/Client/SolverInstallPlan.hs | 17 +---------------- 1 file changed, 1 insertion(+), 16 deletions(-) diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 28e415f57af..b35cc344bdc 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -350,7 +350,7 @@ dependencyInconsistencies' index = [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids]) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) + , length uses > 1 ] where -- For each package name (of a dependency, somewhere) @@ -370,21 +370,6 @@ dependencyInconsistencies' index = Just dep <- [Graph.lookup sid index] ] - -- If, in a single install plan, we depend on more than one version of a - -- package, then this is ONLY okay in the (rather special) case that we - -- depend on precisely two versions of that package, and one of them - -- depends on the other. This is necessary for example for the base where - -- we have base-3 depending on base-4. - reallyIsInconsistent :: [SolverPlanPackage] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - let pid1 = nodeKey p1 - pid2 = nodeKey p2 - in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) - && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) - reallyIsInconsistent _ = True - -- | The graph of packages (nodes) and dependencies (edges) must be acyclic. -- -- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out From cba2d8cb5c1ac843b96da5e7a45d29ea4905484f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 9 Apr 2025 10:58:09 +0800 Subject: [PATCH 010/122] refactor(cabal-install): remove storePackageDBStack It is not very useful. --- cabal-install/src/Distribution/Client/CmdInstall.hs | 4 +++- .../src/Distribution/Client/DistDirLayout.hs | 9 --------- .../Client/ProjectBuilding/UnpackedPackage.hs | 12 ++++-------- .../src/Distribution/Client/ProjectPlanning.hs | 4 ++-- 4 files changed, 9 insertions(+), 20 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 780047ef729..0315dd635ab 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -138,6 +138,7 @@ import Distribution.Simple.Compiler ) import Distribution.Simple.Configure ( configCompilerEx + , interpretPackageDbFlags ) import Distribution.Simple.Flag ( flagElim @@ -1346,7 +1347,8 @@ getPackageDbStack compiler storeDirFlag logsDirFlag packageDbs = do let mlogsDir = flagToMaybe logsDirFlag cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir - pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler packageDbs + let storePackageDBStack = interpretPackageDbFlags False packageDbs ++ [storePackageDB (cabalStoreDirLayout cabalLayout) compiler] + pure storePackageDBStack -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 64140152453..c5701ac513d 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -44,10 +44,8 @@ import Distribution.Simple.Compiler ( Compiler (..) , OptimisationLevel (..) , PackageDBCWD - , PackageDBStackCWD , PackageDBX (..) ) -import Distribution.Simple.Configure (interpretPackageDbFlags) import Distribution.System import Distribution.Types.ComponentName import Distribution.Types.LibraryName @@ -123,7 +121,6 @@ data StoreDirLayout = StoreDirLayout , storePackageDirectory :: Compiler -> UnitId -> FilePath , storePackageDBPath :: Compiler -> FilePath , storePackageDB :: Compiler -> PackageDBCWD - , storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD , storeIncomingDirectory :: Compiler -> FilePath , storeIncomingLock :: Compiler -> UnitId -> FilePath } @@ -190,7 +187,6 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distDirectory = distProjectRootDirectory fromMaybe "dist-newstyle" mdistDirectory - -- TODO: switch to just dist at some point, or some other new name distBuildRootDirectory :: FilePath distBuildRootDirectory = distDirectory "build" @@ -287,11 +283,6 @@ defaultStoreDirLayout storeRoot = storePackageDB compiler = SpecificPackageDB (storePackageDBPath compiler) - storePackageDBStack :: Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD - storePackageDBStack compiler extraPackageDB = - (interpretPackageDbFlags False extraPackageDB) - ++ [storePackageDB compiler] - storeIncomingDirectory :: Compiler -> FilePath storeIncomingDirectory compiler = storeDirectory compiler "incoming" diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index e19c52157c0..3f52d94bae7 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -116,6 +116,7 @@ import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.Simple.Configure (interpretPackageDbFlags) -- | Each unpacked package is processed in the following phases: -- @@ -648,9 +649,7 @@ buildAndInstallUnpackedPackage buildAndInstallUnpackedPackage verbosity distDirLayout - storeDirLayout@StoreDirLayout - { storePackageDBStack - } + storeDirLayout maybe_semaphore buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock @@ -710,11 +709,8 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - assert - ( elabRegisterPackageDBStack pkg - == storePackageDBStack compiler (elabPackageDbs pkg) - ) - (return ()) + let packageDbStack = interpretPackageDbFlags False (elabPackageDbs pkg) ++ [storePackageDB storeDirLayout compiler] + assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister (elabRegisterPackageDBStack pkg) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 149254ecde4..3421f1bca40 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1633,7 +1633,7 @@ elaborateInstallPlan compilerprogdb pkgConfigDB distDirLayout@DistDirLayout{..} - storeDirLayout@StoreDirLayout{storePackageDBStack} + storeDirLayout solverPlan localPackages sourcePackageHashes @@ -2440,7 +2440,7 @@ elaborateInstallPlan corePackageDbs ++ [distPackageDB (compilerId compiler)] - corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig) + corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs sharedPackageConfig) ++ [storePackageDB storeDirLayout compiler] -- For this local build policy, every package that lives in a local source -- dir (as opposed to a tarball), or depends on such a package, will be From 03e053ebb13fc8f28f2df3183c3baf8540899aee Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 8 Apr 2025 16:04:17 +0800 Subject: [PATCH 011/122] refactor(cabal-install): resolve package dbs during planning --- .../src/Distribution/Client/PackageHash.hs | 2 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 3 +- .../Distribution/Client/ProjectPlanning.hs | 2 +- .../Client/ProjectPlanning/Types.hs | 29 +++++++++---------- 4 files changed, 17 insertions(+), 19 deletions(-) diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index e8975b0fc57..c19827461ae 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -219,7 +219,7 @@ data PackageHashConfigInputs = PackageHashConfigInputs , pkgHashExtraIncludeDirs :: [FilePath] , pkgHashProgPrefix :: Maybe PathTemplate , pkgHashProgSuffix :: Maybe PathTemplate - , pkgHashPackageDbs :: [Maybe PackageDBCWD] + , pkgHashPackageDbs :: [PackageDBCWD] , -- Haddock options pkgHashDocumentation :: Bool , pkgHashHaddockHoogle :: Bool diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 3f52d94bae7..4bbc11c90ed 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -116,7 +116,6 @@ import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) import Distribution.Client.ProjectBuilding.PackageFileMonitor -import Distribution.Simple.Configure (interpretPackageDbFlags) -- | Each unpacked package is processed in the following phases: -- @@ -709,7 +708,7 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - let packageDbStack = interpretPackageDbFlags False (elabPackageDbs pkg) ++ [storePackageDB storeDirLayout compiler] + let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout compiler] assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 3421f1bca40..a01f9aab7d8 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2271,7 +2271,7 @@ elaborateInstallPlan if shouldBuildInplaceOnly pkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = projectConfigPackageDBs sharedPackageConfig + elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs sharedPackageConfig) elabBuildPackageDBStack = buildAndRegisterDbs elabRegisterPackageDBStack = buildAndRegisterDbs diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 6aa1065d20e..8102b6b5f17 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -247,21 +247,20 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage -- to disable. This tells us which ones we build by default, and -- helps with error messages when the user asks to build something -- they explicitly disabled. - -- - -- TODO: The 'Bool' here should be refined into an ADT with three - -- cases: NotRequested, ExplicitlyRequested and - -- ImplicitlyRequested. A stanza is explicitly requested if - -- the user asked, for this *specific* package, that the stanza - -- be enabled; it's implicitly requested if the user asked for - -- all global packages to have this stanza enabled. The - -- difference between an explicit and implicit request is - -- error reporting behavior: if a user asks for tests to be - -- enabled for a specific package that doesn't have any tests, - -- we should warn them about it, but we shouldn't complain - -- that a user enabled tests globally, and some local packages - -- just happen not to have any tests. (But perhaps we should - -- warn if ALL local packages don't have any tests.) - , elabPackageDbs :: [Maybe PackageDBCWD] + , -- TODO: The 'Bool' here should be refined into an ADT with three + -- cases: NotRequested, ExplicitlyRequested and + -- ImplicitlyRequested. A stanza is explicitly requested if + -- the user asked, for this *specific* package, that the stanza + -- be enabled; it's implicitly requested if the user asked for + -- all global packages to have this stanza enabled. The + -- difference between an explicit and implicit request is + -- error reporting behavior: if a user asks for tests to be + -- enabled for a specific package that doesn't have any tests, + -- we should warn them about it, but we shouldn't complain + -- that a user enabled tests globally, and some local packages + -- just happen not to have any tests. (But perhaps we should + -- warn if ALL local packages don't have any tests.) + elabPackageDbs :: [PackageDBCWD] , elabSetupPackageDBStack :: PackageDBStackCWD , elabBuildPackageDBStack :: PackageDBStackCWD , elabRegisterPackageDBStack :: PackageDBStackCWD From 5f86ec8bb7aea3f4e915c8db7288c1c06013f036 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 5 May 2025 16:31:02 +0800 Subject: [PATCH 012/122] refactor(cabal-install): remove workaround for build tools listed as build dependencies --- cabal-install/src/Distribution/Client/ProjectPlanning.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index a01f9aab7d8..ef21a5f2ae1 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1977,15 +1977,10 @@ elaborateInstallPlan external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - - -- Combine library and build-tool dependencies, for backwards - -- compatibility (See issue #5412 and the documentation for - -- InstallPlan.fromSolverInstallPlan), but prefer the versions - -- specified as build-tools. external_exe_dep_pkgs = concatMap mapDep $ ordNubBy (pkgName . packageId) $ - external_exe_dep_sids ++ external_lib_dep_sids + external_exe_dep_sids external_exe_map = Map.fromList $ From ac5fd6f141cd6f2d77693514589a9d45c8e04d36 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 5 May 2025 16:31:02 +0800 Subject: [PATCH 013/122] refactor(cabal-install): move elabInstantiatedWith and elabLinkedInstantiatedWith from ElaboratedConfiguredPackage to ElaboratedComponent Instantiation only makes sense for components. --- .../Client/ProjectOrchestration.hs | 10 ++++---- .../Distribution/Client/ProjectPlanning.hs | 25 ++++++++----------- .../Client/ProjectPlanning/Types.hs | 4 +-- 3 files changed, 18 insertions(+), 21 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index d0dfb10601e..8f6f84da5e3 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1142,17 +1142,17 @@ printPlan , case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) ElabComponent comp -> - "(" ++ showComp elab comp ++ ")" + "(" ++ showComp comp ++ ")" , showFlagAssignment (nonDefaultFlags elab) , showConfigureFlags elab , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in "(" ++ showBuildStatus buildStatus ++ ")" ] - showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String - showComp elab comp = + showComp :: ElaboratedComponent -> String + showComp comp = maybe "custom" prettyShow (compComponentName comp) - ++ if Map.null (elabInstantiatedWith elab) + ++ if Map.null (compInstantiatedWith comp) then "" else " with " @@ -1160,7 +1160,7 @@ printPlan ", " -- TODO: Abbreviate the UnitIds [ prettyShow k ++ "=" ++ prettyShow v - | (k, v) <- Map.toList (elabInstantiatedWith elab) + | (k, v) <- Map.toList (compInstantiatedWith comp) ] nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ef21a5f2ae1..00280b30598 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1797,7 +1797,6 @@ elaborateInstallPlan { elabModuleShape = emptyModuleShape , elabUnitId = notImpl "elabUnitId" , elabComponentId = notImpl "elabComponentId" - , elabLinkedInstantiatedWith = Map.empty , elabInstallDirs = notImpl "elabInstallDirs" , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) } @@ -1816,14 +1815,11 @@ elaborateInstallPlan compOrderLibDependencies = notImpl "compOrderLibDependencies" -- Not supported: - compExeDependencies :: [a] compExeDependencies = [] - - compExeDependencyPaths :: [a] compExeDependencyPaths = [] - - compPkgConfigDependencies :: [a] compPkgConfigDependencies = [] + compInstantiatedWith = mempty + compLinkedInstantiatedWith = Map.empty notImpl f = error $ @@ -1880,6 +1876,8 @@ elaborateInstallPlan , Just paths <- [Map.lookup (ann_id aid') exe_map1] , path <- paths ] + compInstantiatedWith = Map.empty + compLinkedInstantiatedWith = Map.empty elab_comp = ElaboratedComponent{..} -- 3. Construct a preliminary ElaboratedConfiguredPackage, @@ -1933,7 +1931,6 @@ elaborateInstallPlan { elabModuleShape = lc_shape lc , elabUnitId = abstractUnitId (lc_uid lc) , elabComponentId = lc_cid lc - , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc) , elabPkgOrComp = ElabComponent $ elab_comp @@ -1944,6 +1941,7 @@ elaborateInstallPlan (abstractUnitId . ci_id) (lc_includes lc ++ lc_sig_includes lc) ) + , compLinkedInstantiatedWith = Map.fromList (lc_insts lc) } } elab = @@ -2096,7 +2094,6 @@ elaborateInstallPlan elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabLinkedInstantiatedWith = Map.empty , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} , elabModuleShape = modShape } @@ -2191,8 +2188,6 @@ elaborateInstallPlan -- These get filled in later elabUnitId = error "elaborateSolverToCommon: elabUnitId" elabComponentId = error "elaborateSolverToCommon: elabComponentId" - elabInstantiatedWith = Map.empty - elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith" elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" @@ -2812,7 +2807,6 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = elab0 { elabUnitId = uid , elabComponentId = cid - , elabInstantiatedWith = fmap fst insts , elabIsCanonical = Map.null (fmap fst insts) , elabPkgOrComp = ElabComponent @@ -2824,6 +2818,7 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = unDefUnitId (deps ++ concatMap (getDep . fst) (Map.elems insts)) ) + , compInstantiatedWith = fmap fst insts } } elab = @@ -2934,8 +2929,8 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = work = for_ pkgs $ \pkg -> case pkg of - InstallPlan.Configured elab - | not (Map.null (elabLinkedInstantiatedWith elab)) -> + InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) + | not (Map.null (compLinkedInstantiatedWith comp)) -> indefiniteUnitId (elabComponentId elab) >> return () _ -> @@ -4016,7 +4011,9 @@ setupHsConfigureFlags configProfExe = mempty configProf = toFlag $ LBC.withProfExe elabBuildOptions - configInstantiateWith = Map.toList elabInstantiatedWith + configInstantiateWith = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent comp -> Map.toList (compInstantiatedWith comp) configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese configIPID = case elabPkgOrComp of diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 8102b6b5f17..de08254fea5 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -203,8 +203,6 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage { elabUnitId :: UnitId -- ^ The 'UnitId' which uniquely identifies this item in a build plan , elabComponentId :: ComponentId - , elabInstantiatedWith :: Map ModuleName Module - , elabLinkedInstantiatedWith :: Map ModuleName OpenModule , elabIsCanonical :: Bool -- ^ This is true if this is an indefinite package, or this is a -- package with no signatures. (Notably, it's not true for instantiated @@ -683,6 +681,8 @@ data ElaboratedComponent = ElaboratedComponent -- instantiation phase. It's more precise than -- 'compLibDependencies', and also stores information about internal -- dependencies. + , compInstantiatedWith :: Map ModuleName Module + , compLinkedInstantiatedWith :: Map ModuleName OpenModule , compExeDependencies :: [ConfiguredId] -- ^ The executable dependencies of this component (including -- internal executables). From 5cf82bd408ec99ecfc22cf199c4a44b58dd45ebd Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Mar 2025 18:23:24 +0800 Subject: [PATCH 014/122] feat(cabal-install-solver): introduce Stage and Toolchain add stages list --- .../cabal-install-solver.cabal | 2 + .../src/Distribution/Solver/Types/Stage.hs | 113 ++++++++++++++++++ .../Distribution/Solver/Types/Toolchain.hs | 39 ++++++ .../Distribution/Client/ArbitraryInstances.hs | 5 + .../Distribution/Client/TreeDiffInstances.hs | 2 + .../Distribution/Solver/Modular/QuickCheck.hs | 8 ++ 6 files changed, 169 insertions(+) create mode 100644 cabal-install-solver/src/Distribution/Solver/Types/Stage.hs create mode 100644 cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal index a222410efa0..3d807077ee6 100644 --- a/cabal-install-solver/cabal-install-solver.cabal +++ b/cabal-install-solver/cabal-install-solver.cabal @@ -95,7 +95,9 @@ library Distribution.Solver.Types.SolverId Distribution.Solver.Types.SolverPackage Distribution.Solver.Types.SourcePackage + Distribution.Solver.Types.Stage Distribution.Solver.Types.SummarizedMessage + Distribution.Solver.Types.Toolchain Distribution.Solver.Types.Variable build-depends: diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs new file mode 100644 index 00000000000..7ca70f701cc --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Stage.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveTraversable #-} + +module Distribution.Solver.Types.Stage + ( Stage (..) + , showStage + , stages + , prevStage + , nextStage + , Staged (..) + , tabulate + , foldMapWithKey + , always + ) where + +import Prelude (Enum (..)) +import Distribution.Compat.Prelude +import qualified Distribution.Compat.CharParsing as P + +import Data.Maybe (fromJust) +import GHC.Stack + +import Distribution.Parsec (Parsec (..)) +import Distribution.Pretty (Pretty (..)) +import Distribution.Utils.Structured (Structured (..)) +import qualified Text.PrettyPrint as Disp + + +data Stage + = -- | -- The system where the build is running + Build + | -- | -- The system where the built artifacts will run + Host + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +instance Binary Stage +instance Structured Stage + +instance Pretty Stage where + pretty = Disp.text . showStage + +showStage :: Stage -> String +showStage Build = "build" +showStage Host = "host" + +instance Parsec Stage where + parsec = P.choice [ + Build <$ P.string "build", + Host <$ P.string "host" + ] + +stages :: [Stage] +stages = [minBound .. maxBound] + +prevStage :: Stage -> Stage +prevStage s | s == minBound = s + | otherwise = Prelude.pred s +nextStage :: Stage -> Stage +nextStage s | s == maxBound = s + | otherwise = Prelude.succ s + +-- TOOD: I think there is similar code for stanzas, compare. + +newtype Staged a = Staged + { getStage :: Stage -> a + } + deriving (Functor, Generic) + deriving Applicative via ((->) Stage) + +instance Eq a => Eq (Staged a) where + lhs == rhs = + all + (\stage -> getStage lhs stage == getStage rhs stage) + [minBound .. maxBound] + +instance Show a => Show (Staged a) where + showsPrec _ staged = + showList + [ (stage, getStage staged stage) + | stage <- [minBound .. maxBound] + ] + +instance Foldable Staged where + foldMap f (Staged gs) = foldMap (f . gs) [minBound..maxBound] + +instance Traversable Staged where + traverse f = fmap index . traverse (traverse f) . tabulate + +instance Binary a => Binary (Staged a) where + put staged = put (tabulate staged) + -- TODO this could be done better I think + get = index <$> get + +-- TODO: I have no idea if this is right +instance (Typeable a, Structured a) => Structured (Staged a) where + structure _ = structure (Proxy :: Proxy [(Stage, a)]) + +tabulate :: Staged a -> [(Stage, a)] +tabulate staged = + [ (stage, getStage staged stage) + | stage <- [minBound .. maxBound] + ] + +index :: HasCallStack => [(Stage, a)] -> Staged a +index t = Staged (\s -> fromJust (lookup s t)) + +foldMapWithKey :: Monoid m => (Stage -> a -> m) -> Staged a -> m +foldMapWithKey f = foldMap (uncurry f) . tabulate + +always :: a -> Staged a +always = Staged . const diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs new file mode 100644 index 00000000000..a69963f3a56 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Solver.Types.Toolchain + ( Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Simple.Compiler +import Distribution.Simple.Program.Db +import Distribution.Solver.Types.Stage (getStage, Stage (..), Staged (..)) +import Distribution.System + +--------------------------- +-- Toolchain +-- + +data Toolchain = Toolchain + { toolchainPlatform :: Platform + , toolchainCompiler :: Compiler + , toolchainProgramDb :: ProgramDb + } + deriving (Show, Generic) + +-- TODO: review this +instance Eq Toolchain where + lhs == rhs = + (((==) `on` toolchainPlatform) lhs rhs) + && (((==) `on` toolchainCompiler) lhs rhs) + && ((((==)) `on` (configuredPrograms . toolchainProgramDb)) lhs rhs) + +instance Binary Toolchain +instance Structured Toolchain + +type Toolchains = Staged Toolchain diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index c8843761e69..8af811cfeb9 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -44,6 +44,7 @@ import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalSt import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) import Data.Coerce (Coercible, coerce) +import Distribution.Solver.Types.Stage (Stage) import Network.URI (URI (..), URIAuth (..), isUnreserved) import Test.QuickCheck ( Arbitrary (..) @@ -324,6 +325,10 @@ instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where TestStanzas -> x1 BenchStanzas -> x2 +instance Arbitrary Stage where + arbitrary = genericArbitrary + shrink = genericShrink + ------------------------------------------------------------------------------- -- BuildReport ------------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index 3ee56e04b9a..2a8566cc344 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -9,6 +9,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ProjectConfigPath import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Stage import Distribution.Client.BuildReports.Types import Distribution.Client.CmdInstall.ClientInstallFlags @@ -73,6 +74,7 @@ instance ToExpr ReorderGoals instance ToExpr RepoIndexState instance ToExpr RepoName instance ToExpr ReportLevel +instance ToExpr Stage instance ToExpr StrongFlags instance ToExpr Timestamp instance ToExpr TotalIndexState diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 844681ae5dc..92f3a559fec 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -43,6 +43,7 @@ import Distribution.Solver.Types.Variable import Distribution.Verbosity import Distribution.Version +import Distribution.Solver.Types.Stage (Stage) import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( ArbitraryOrd (..) @@ -586,6 +587,12 @@ instance Arbitrary OptionalStanza where shrink BenchStanzas = [TestStanzas] shrink TestStanzas = [] +instance Arbitrary Stage where + arbitrary = elements [minBound .. maxBound] + + shrink stage = + [stage' | stage' <- [minBound .. maxBound], stage' /= stage] + instance ArbitraryOrd pn => ArbitraryOrd (Variable pn) instance ArbitraryOrd a => ArbitraryOrd (P.Qualified a) instance ArbitraryOrd P.PackagePath @@ -597,6 +604,7 @@ instance ArbitraryOrd ShortText where arbitraryCompare = do strc <- arbitraryCompare pure $ \l r -> strc (fromShortText l) (fromShortText r) +instance ArbitraryOrd Stage deriving instance Generic (Variable pn) deriving instance Generic (P.Qualified a) From a4a7497442d9600bf45da3da661d9011f129f917 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 2 Apr 2025 14:43:52 +0800 Subject: [PATCH 015/122] feat(cabal-install): introduce ProjectConfigToolchain --- .../Distribution/Solver/Types/Toolchain.hs | 3 + cabal-install/cabal-install.cabal | 1 + .../parser-tests/Tests/ParserTests.hs | 7 +- .../src/Distribution/Client/CmdInstall.hs | 14 ++-- .../src/Distribution/Client/CmdPath.hs | 11 +-- .../src/Distribution/Client/ProjectConfig.hs | 1 + .../Client/ProjectConfig/FieldGrammar.hs | 22 ++++-- .../Client/ProjectConfig/Legacy.hs | 17 +++-- .../Distribution/Client/ProjectConfig/Lens.hs | 29 +++++--- .../Client/ProjectConfig/Parsec.hs | 2 +- .../Client/ProjectConfig/Types.hs | 23 ++++-- .../Distribution/Client/ProjectPlanning.hs | 72 ++++++++++--------- .../src/Distribution/Client/ScriptUtils.hs | 10 ++- .../src/Distribution/Client/Toolchain.hs | 65 +++++++++++++++++ cabal-install/tests/IntegrationTests2.hs | 3 +- .../Distribution/Client/ProjectConfig.hs | 26 ++++--- .../Distribution/Client/TreeDiffInstances.hs | 1 + 17 files changed, 225 insertions(+), 82 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/Toolchain.hs diff --git a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs index a69963f3a56..6ee663795f4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs @@ -23,6 +23,9 @@ data Toolchain = Toolchain { toolchainPlatform :: Platform , toolchainCompiler :: Compiler , toolchainProgramDb :: ProgramDb + -- NOTE: actually the solver does not care about package dbs, perhaps it's better + -- to have a separate Toolchain type for project planning. + , toolchainPackageDBs :: PackageDBStackCWD } deriving (Show, Generic) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 41ef502755a..e40c6273034 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -215,6 +215,7 @@ library Distribution.Client.TargetProblem Distribution.Client.TargetSelector Distribution.Client.Targets + Distribution.Client.Toolchain Distribution.Client.Types Distribution.Client.Types.AllowNewer Distribution.Client.Types.BuildResults diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index f625cb0cfff..ff26080adf6 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -179,6 +179,7 @@ testProjectConfigShared = do assertConfigEquals expected config legacy (projectConfigShared . condTreeData) where expected = ProjectConfigShared{..} + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigDistDir = toFlag "something" projectConfigConfigFile = mempty -- cli only projectConfigProjectFileParser = mempty -- cli only @@ -188,9 +189,13 @@ testProjectConfigShared = do projectConfigHcFlavor = toFlag GHCJS projectConfigHcPath = toFlag "/some/path/to/compiler" projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] + projectConfigBuildHcFlavor = toFlag GHCJS + projectConfigBuildHcPath = toFlag "/some/path/to/compiler" + projectConfigBuildHcPkg = toFlag "/some/path/to/ghc-pkg" + projectConfigBuildPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index" projectConfigInstallDirs = mempty -- tested below in testInstallDirs - projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")] projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride]) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 0315dd635ab..08662af5285 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -68,7 +68,8 @@ import Distribution.Client.NixStyleOptions , nixStyleOptions ) import Distribution.Client.ProjectConfig - ( ProjectPackageLocation (..) + ( ProjectConfigToolchain (..) + , ProjectPackageLocation (..) , fetchAndReadSourcePackages , projectConfigWithBuilderRepoContext , resolveBuildTimeSettings @@ -413,12 +414,15 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project } , projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + } , projectConfigStoreDir , projectConfigProgPathExtra - , projectConfigPackageDBs } , projectConfigLocalPackages = PackageConfig diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index bec228a771e..99e1a7de5a5 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -46,6 +46,9 @@ import Distribution.Client.ScriptUtils import Distribution.Client.Setup ( yesNoOpt ) +import Distribution.Client.Toolchain + ( Toolchain (..) + ) import Distribution.Client.Utils.Json ( (.=) ) @@ -244,10 +247,10 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF if not $ fromFlagOrDefault False (pathCompiler pathFlags) then pure Nothing else do - (compiler, _, progDb) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) - compilerProg <- requireCompilerProg verbosity compiler - (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb - pure $ Just $ mkCompilerInfo configuredCompilerProg compiler + toolchain <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) + compilerProg <- requireCompilerProg verbosity (toolchainCompiler toolchain) + (configuredCompilerProg, _) <- requireProgram verbosity compilerProg (toolchainProgramDb toolchain) + pure $ Just $ mkCompilerInfo configuredCompilerProg (toolchainCompiler toolchain) paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation baseCtx p diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index efb9b810bfd..d2a6046da41 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -14,6 +14,7 @@ module Distribution.Client.ProjectConfig , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) , ProjectConfigSkeleton + , ProjectConfigToolchain (..) , ProjectConfigProvenance (..) , PackageConfig (..) , MapLast (..) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index b1832cfbbd4..82357d81787 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -12,7 +12,14 @@ import qualified Data.Set as Set import Distribution.CabalSpecVersion (CabalSpecVersion (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (clientInstallFlagsGrammar) import qualified Distribution.Client.ProjectConfig.Lens as L -import Distribution.Client.ProjectConfig.Types (PackageConfig (..), ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance (..), ProjectConfigShared (..)) +import Distribution.Client.ProjectConfig.Types + ( PackageConfig (..) + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigProvenance (..) + , ProjectConfigShared (..) + , ProjectConfigToolchain (..) + ) import Distribution.Client.Utils.Parsec import Distribution.Compat.Prelude import Distribution.FieldGrammar @@ -76,12 +83,9 @@ projectConfigSharedFieldGrammar source = <*> optionalFieldDefAla "project-file" (alaFlag FilePathNT) L.projectConfigProjectFile mempty <*> pure mempty -- You can't set the parser type in the project file. <*> optionalFieldDef "ignore-project" L.projectConfigIgnoreProject mempty - <*> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty - <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty - <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> blurFieldGrammar L.projectConfigToolchain projectConfigToolchainFieldGrammar <*> optionalFieldDef "doc-index-file" L.projectConfigHaddockIndex mempty <*> blurFieldGrammar L.projectConfigInstallDirs installDirsGrammar - <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs <*> pure mempty -- repository stanza for projectConfigRemoteRepos <*> pure mempty -- repository stanza for projectConfigLocalNoIndexRepos <*> monoidalField "active-repositories" L.projectConfigActiveRepos @@ -108,6 +112,14 @@ projectConfigSharedFieldGrammar source = <*> monoidalFieldAla "extra-prog-path-shared-only" (alaNubList' FSep FilePathNT) L.projectConfigProgPathExtra <*> optionalFieldDef "multi-repl" L.projectConfigMultiRepl mempty +projectConfigToolchainFieldGrammar :: ParsecFieldGrammar' ProjectConfigToolchain +projectConfigToolchainFieldGrammar = + ProjectConfigToolchain + <$> optionalFieldDef "compiler" L.projectConfigHcFlavor mempty + <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty + <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty + <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs + packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig packageConfigFieldGrammar knownPrograms = mkPackageConfig diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index e1dad0195ed..a5d6eb6fe18 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -385,7 +385,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigToolchain $ projectConfigShared pc) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ProjectParseResult ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode d (listToMaybe -> c) comps) @@ -716,6 +716,7 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , globalStoreDir = projectConfigStoreDir } = globalFlags + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ ConfigFlags @@ -723,10 +724,8 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , configHcFlavor = projectConfigHcFlavor , configHcPath = projectConfigHcPath , configHcPkg = projectConfigHcPkg - , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME - configInstallDirs = projectConfigInstallDirs - , -- configUserInstall = projectConfigUserInstall, - configPackageDBs = projectConfigPackageDBs_ + , configInstallDirs = projectConfigInstallDirs + , configPackageDBs = projectConfigPackageDBs_ } = configFlags CommonSetupFlags @@ -965,10 +964,7 @@ convertToLegacySharedConfig ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly{..} , projectConfigShared = ProjectConfigShared{..} - , projectConfigAllPackages = - PackageConfig - { packageConfigDocumentation - } + , projectConfigAllPackages = PackageConfig{..} } = LegacySharedConfig { legacyGlobalFlags = globalFlags @@ -980,6 +976,7 @@ convertToLegacySharedConfig , legacyMultiRepl = projectConfigMultiRepl } where + ProjectConfigToolchain{..} = projectConfigToolchain globalFlags = GlobalFlags { globalVersion = mempty @@ -1085,6 +1082,8 @@ convertToLegacyAllPackageConfig , legacyBenchmarkFlags = mempty } where + ProjectConfigToolchain{..} = projectConfigToolchain + commonFlags = mempty diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index 29a2c0125bb..fdd90a7048e 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -7,7 +7,16 @@ import Distribution.Client.IndexUtils.ActiveRepos ( ActiveRepos ) import Distribution.Client.IndexUtils.IndexState (TotalIndexState) -import Distribution.Client.ProjectConfig.Types (MapLast, MapMappend, PackageConfig, ProjectConfig (..), ProjectConfigBuildOnly (..), ProjectConfigProvenance, ProjectConfigShared) +import Distribution.Client.ProjectConfig.Types + ( MapLast + , MapMappend + , PackageConfig + , ProjectConfig (..) + , ProjectConfigBuildOnly (..) + , ProjectConfigProvenance + , ProjectConfigShared + , ProjectConfigToolchain (..) + ) import qualified Distribution.Client.ProjectConfig.Types as T import Distribution.Client.Targets (UserConstraint) import Distribution.Client.Types.AllowNewer (AllowNewer, AllowOlder) @@ -187,18 +196,26 @@ projectConfigIgnoreProject :: Lens' ProjectConfigShared (Flag Bool) projectConfigIgnoreProject f s = fmap (\x -> s{T.projectConfigIgnoreProject = x}) (f (T.projectConfigIgnoreProject s)) {-# INLINEABLE projectConfigIgnoreProject #-} -projectConfigHcFlavor :: Lens' ProjectConfigShared (Flag CompilerFlavor) +projectConfigToolchain :: Lens' ProjectConfigShared ProjectConfigToolchain +projectConfigToolchain f s = fmap (\x -> s{T.projectConfigToolchain = x}) (f (T.projectConfigToolchain s)) +{-# INLINEABLE projectConfigToolchain #-} + +projectConfigHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor) projectConfigHcFlavor f s = fmap (\x -> s{T.projectConfigHcFlavor = x}) (f (T.projectConfigHcFlavor s)) {-# INLINEABLE projectConfigHcFlavor #-} -projectConfigHcPath :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPath :: Lens' ProjectConfigToolchain (Flag FilePath) projectConfigHcPath f s = fmap (\x -> s{T.projectConfigHcPath = x}) (f (T.projectConfigHcPath s)) {-# INLINEABLE projectConfigHcPath #-} -projectConfigHcPkg :: Lens' ProjectConfigShared (Flag FilePath) +projectConfigHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath) projectConfigHcPkg f s = fmap (\x -> s{T.projectConfigHcPkg = x}) (f (T.projectConfigHcPkg s)) {-# INLINEABLE projectConfigHcPkg #-} +projectConfigPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] +projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) +{-# INLINEABLE projectConfigPackageDBs #-} + projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) {-# INLINEABLE projectConfigHaddockIndex #-} @@ -207,10 +224,6 @@ projectConfigInstallDirs :: Lens' ProjectConfigShared (InstallDirs (Flag PathTem projectConfigInstallDirs f s = fmap (\x -> s{T.projectConfigInstallDirs = x}) (f (T.projectConfigInstallDirs s)) {-# INLINEABLE projectConfigInstallDirs #-} -projectConfigPackageDBs :: Lens' ProjectConfigShared [Maybe PackageDBCWD] -projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) -{-# INLINEABLE projectConfigPackageDBs #-} - projectConfigLocalNoIndexRepos :: Lens' ProjectConfigShared (NubList LocalRepo) projectConfigLocalNoIndexRepos f s = fmap (\x -> s{T.projectConfigLocalNoIndexRepos = x}) (f (T.projectConfigLocalNoIndexRepos s)) {-# INLINEABLE projectConfigLocalNoIndexRepos #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index f4d638c0d6b..40643b9dd0d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -209,7 +209,7 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg where - isSet f = f (projectConfigShared pc) /= NoFlag + isSet f = f (projectConfigToolchain (projectConfigShared pc)) /= NoFlag sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectFileSource ProjectConfigSkeleton sanityWalkPCS underConditional t@(CondNode d _c comps) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 8a32ca31815..21cbbaadf2e 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -9,6 +9,7 @@ module Distribution.Client.ProjectConfig.Types , ProjectConfigToParse (..) , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) + , ProjectConfigToolchain (..) , ProjectConfigProvenance (..) , PackageConfig (..) , ProjectFileParser (..) @@ -193,16 +194,13 @@ data ProjectConfigShared = ProjectConfigShared , projectConfigProjectFile :: Flag FilePath , projectConfigProjectFileParser :: Flag ProjectFileParser , projectConfigIgnoreProject :: Flag Bool - , projectConfigHcFlavor :: Flag CompilerFlavor - , projectConfigHcPath :: Flag FilePath - , projectConfigHcPkg :: Flag FilePath + , projectConfigToolchain :: ProjectConfigToolchain , projectConfigHaddockIndex :: Flag PathTemplate , -- Only makes sense for manual mode, not --local mode -- too much control! -- projectConfigUserInstall :: Flag Bool, projectConfigInstallDirs :: InstallDirs (Flag PathTemplate) - , projectConfigPackageDBs :: [Maybe PackageDBCWD] , -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. @@ -241,6 +239,14 @@ data ProjectConfigShared = ProjectConfigShared } deriving (Eq, Show, Generic) +data ProjectConfigToolchain = ProjectConfigToolchain + { projectConfigHcFlavor :: Flag CompilerFlavor + , projectConfigHcPath :: Flag FilePath + , projectConfigHcPkg :: Flag FilePath + , projectConfigPackageDBs :: [Maybe PackageDBCWD] + } + deriving (Eq, Show, Generic) + data ProjectFileParser = LegacyParser | ParsecParser @@ -342,6 +348,7 @@ data PackageConfig = PackageConfig instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly +instance Binary ProjectConfigToolchain instance Binary ProjectConfigShared instance Binary ProjectConfigProvenance instance Binary PackageConfig @@ -349,6 +356,7 @@ instance Binary ProjectFileParser instance Structured ProjectConfig instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigToolchain instance Structured ProjectConfigShared instance Structured ProjectConfigProvenance instance Structured PackageConfig @@ -400,6 +408,13 @@ instance Monoid ProjectConfigBuildOnly where instance Semigroup ProjectConfigBuildOnly where (<>) = gmappend +instance Monoid ProjectConfigToolchain where + mempty = gmempty + mappend = (<>) + +instance Semigroup ProjectConfigToolchain where + (<>) = gmappend + instance Monoid ProjectConfigShared where mempty = gmempty mappend = (<>) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 00280b30598..e9319daf0fc 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -136,6 +136,7 @@ import Distribution.Client.Setup hiding (cabalVersion, packageName) import Distribution.Client.SetupWrapper import Distribution.Client.Store import Distribution.Client.Targets (userToPackageConstraint) +import Distribution.Client.Toolchain import Distribution.Client.Types import Distribution.Client.Utils (concatMapM, incVersion) @@ -376,8 +377,8 @@ rebuildProjectConfig return ( configPath , distProjectFile "" - , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg) , projectConfigProjectFileParser + , projectConfigToolchain , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -396,8 +397,9 @@ rebuildProjectConfig let fetchCompiler = do -- have to create the cache directory before configuring the compiler liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, compiler) + Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} <- + configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + pure (os, arch, toolchainCompiler) (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ @@ -410,7 +412,7 @@ rebuildProjectConfig return (projectConfig <> cliConfig, localPackages) where - ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile} = + ProjectConfigShared{projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile, projectConfigToolchain} = projectConfigShared cliConfig PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} = @@ -500,7 +502,7 @@ configureCompiler :: Verbosity -> DistDirLayout -> ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) + -> Rebuild Toolchain configureCompiler verbosity DistDirLayout @@ -509,9 +511,7 @@ configureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain , projectConfigProgPathExtra } , projectConfigLocalPackages = @@ -524,7 +524,7 @@ configureCompiler progsearchpath <- liftIO $ getSystemSearchPath - (hc, plat, hcProgDb) <- + (toolchainCompiler, toolchainPlatform, tempProgDb) <- rerunIfChanged verbosity fileMonitorCompiler @@ -564,12 +564,13 @@ configureCompiler -- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...). -- -- See Note [Caching the result of configuring the compiler] - finalProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hc hcProgDb hcPkg - return (hc, plat, finalProgDb) + toolchainProgramDb <- liftIO $ Cabal.configCompilerProgDb verbosity toolchainCompiler tempProgDb hcPkg + let toolchainPackageDBs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigToolchain) + return Toolchain{..} where - hcFlavor = flagToMaybe projectConfigHcFlavor - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg + hcFlavor = flagToMaybe (projectConfigHcFlavor projectConfigToolchain) + hcPath = flagToMaybe (projectConfigHcPath projectConfigToolchain) + hcPkg = flagToMaybe (projectConfigHcPkg projectConfigToolchain) {- Note [Caching the result of configuring the compiler] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -674,12 +675,12 @@ rebuildInstallPlan , progsearchpath ) $ do - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc + toolchain <- phaseConfigureCompiler projectConfig + _ <- phaseConfigurePrograms projectConfig toolchain (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- phaseRunSolver projectConfig - compilerEtc + toolchain localPackages (fromMaybe mempty mbInstalledPackages) ( elaboratedPlan @@ -687,7 +688,7 @@ rebuildInstallPlan ) <- phaseElaboratePlan projectConfig - compilerEtc + toolchain pkgConfigDB solverPlan localPackages @@ -717,7 +718,7 @@ rebuildInstallPlan -- phaseConfigureCompiler :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) + -> Rebuild Toolchain phaseConfigureCompiler = configureCompiler verbosity distDirLayout -- Configuring other programs. @@ -734,16 +735,16 @@ rebuildInstallPlan -- phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchain -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do + phaseConfigurePrograms projectConfig toolchain = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. liftIO $ checkBadPerPackageCompilerPaths - (configuredPrograms compilerprogdb) + (configuredPrograms (toolchainProgramDb toolchain)) (getMapMappend (projectConfigSpecificPackage projectConfig)) -- TODO: [required eventually] find/configure other programs that the @@ -757,7 +758,7 @@ rebuildInstallPlan -- phaseRunSolver :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchain -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) @@ -766,7 +767,12 @@ rebuildInstallPlan { projectConfigShared , projectConfigBuildOnly } - (compiler, platform, progdb) + Toolchain + { toolchainCompiler = compiler + , toolchainPlatform = platform + , toolchainProgramDb = progdb + } + -- \^ The compiler and platform to use for the solver. localPackages installedPackages = rerunIfChanged @@ -822,7 +828,7 @@ rebuildInstallPlan where corePackageDbs :: PackageDBStackCWD corePackageDbs = - Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared) + Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain projectConfigShared)) withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -871,7 +877,7 @@ rebuildInstallPlan -- phaseElaboratePlan :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchain -> Maybe PkgConfigDb -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] @@ -887,7 +893,7 @@ rebuildInstallPlan , projectConfigSpecificPackage , projectConfigBuildOnly } - (compiler, platform, progdb) + Toolchain{..} pkgConfigDB solverPlan localPackages = do @@ -900,15 +906,15 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + defaultInstallDirs <- liftIO $ userInstallDirTemplates toolchainCompiler let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) (elaboratedPlan, elaboratedShared) <- liftIO . runLogProgress verbosity $ elaborateInstallPlan verbosity - platform - compiler - progdb + toolchainPlatform + toolchainCompiler + toolchainProgramDb pkgConfigDB distDirLayout cabalStoreDirLayout @@ -2261,7 +2267,7 @@ elaborateInstallPlan if shouldBuildInplaceOnly pkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs sharedPackageConfig) + elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) elabBuildPackageDBStack = buildAndRegisterDbs elabRegisterPackageDBStack = buildAndRegisterDbs @@ -2430,7 +2436,7 @@ elaborateInstallPlan corePackageDbs ++ [distPackageDB (compilerId compiler)] - corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs sharedPackageConfig) ++ [storePackageDB storeDirLayout compiler] + corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout compiler] -- For this local build policy, every package that lives in a local source -- dir (as opposed to a tarball), or depends on such a package, will be diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 1c78d537c19..c5bca638133 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -82,6 +82,9 @@ import Distribution.Client.TargetSelector ( TargetSelectorProblem (..) , TargetString (..) ) +import Distribution.Client.Toolchain + ( Toolchain (..) + ) import Distribution.Client.Types ( PackageLocation (..) , PackageSpecifier (..) @@ -374,13 +377,14 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} <- + runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) - (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton + (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton let ctx' = ctx & lProjectConfig %~ (<> projectCfg) - build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' compiler platform + build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform exePath = build_dir "bin" scriptExeFileName script exePathRel = makeRelative (normalise projectRoot) exePath diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs new file mode 100644 index 00000000000..f3c44e76fc8 --- /dev/null +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Client.Toolchain + ( Stage (..) + , Staged (..) + , Toolchain (..) + , mkProgramDb + , configToolchain + , module Distribution.Solver.Types.Stage + , module Distribution.Solver.Types.Toolchain + ) +where + +import Distribution.Simple.Compiler (interpretPackageDBStack) +import Distribution.Simple.Configure +import Distribution.Simple.Program (ProgArg) +import Distribution.Simple.Program.Db +import Distribution.Simple.Setup +import Distribution.Solver.Types.Stage +import Distribution.Solver.Types.Toolchain +import Distribution.Utils.NubList +import Distribution.Verbosity (Verbosity) + +mkProgramDb + :: Verbosity + -> [FilePath] + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> IO ProgramDb +mkProgramDb verbosity extraSearchPath extraPaths extraArgs = do + progdb <- prependProgramSearchPath verbosity extraSearchPath [] defaultProgramDb + -- ProgramDb with directly user specified paths + return $ + userSpecifyPaths extraPaths $ + userSpecifyArgss extraArgs progdb + +-- | Configure the toolchain +configToolchain :: ConfigFlags -> IO Toolchain +configToolchain configFlags@ConfigFlags{..} = do + programDb <- + mkProgramDb + verbosity + (fromNubList configProgramPathExtra) + configProgramPaths + configProgramArgs + + (toolchainCompiler, toolchainPlatform, progdb) <- + configCompilerEx + (flagToMaybe configHcFlavor) + (flagToMaybe configHcPath) + (flagToMaybe configHcPkg) + programDb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the + -- future. + toolchainProgramDb <- configureAllKnownPrograms verbosity progdb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + + return Toolchain{..} + where + -- FIXME + verbosity = fromFlag (configVerbosity configFlags) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 1ae69ddbe07..558fd2fa8f7 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -2309,7 +2309,8 @@ mkProjectConfig (GhcPath ghcPath) = mempty { projectConfigShared = mempty - { projectConfigHcPath = maybeToFlag ghcPath + { projectConfigToolchain = + mempty{projectConfigHcPath = maybeToFlag ghcPath} } , projectConfigBuildOnly = mempty diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index ebf6b87eb71..5450b28e2f4 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -600,6 +600,22 @@ instance Arbitrary ProjectConfigBuildOnly where preShrink_NumJobs = fmap (fmap Positive) postShrink_NumJobs = fmap (fmap getPositive) +instance Arbitrary ProjectConfigToolchain where + arbitrary = do + projectConfigHcFlavor <- arbitrary + projectConfigHcPath <- arbitraryFlag arbitraryShortToken + projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigPackageDBs <- shortListOf 2 arbitrary + return ProjectConfigToolchain{..} + + shrink ProjectConfigToolchain{..} = + runShrinker $ + pure ProjectConfigToolchain + <*> shrinker projectConfigHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigPackageDBs + instance Arbitrary ProjectConfigShared where arbitrary = do projectConfigDistDir <- arbitraryFlag arbitraryShortToken @@ -608,12 +624,9 @@ instance Arbitrary ProjectConfigShared where projectConfigProjectFile <- arbitraryFlag arbitraryShortToken projectConfigProjectFileParser <- arbitraryFlag arbitrary projectConfigIgnoreProject <- arbitrary - projectConfigHcFlavor <- arbitrary - projectConfigHcPath <- arbitraryFlag arbitraryShortToken - projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigToolchain <- arbitrary projectConfigHaddockIndex <- arbitrary projectConfigInstallDirs <- fixInstallDirs <$> arbitrary - projectConfigPackageDBs <- shortListOf 2 arbitrary projectConfigRemoteRepos <- arbitrary projectConfigLocalNoIndexRepos <- arbitrary projectConfigActiveRepos <- arbitrary @@ -654,12 +667,9 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigProjectFile <*> shrinker projectConfigProjectFileParser <*> shrinker projectConfigIgnoreProject - <*> shrinker projectConfigHcFlavor - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath - <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigToolchain <*> shrinker projectConfigHaddockIndex <*> shrinker projectConfigInstallDirs - <*> shrinker projectConfigPackageDBs <*> shrinker projectConfigRemoteRepos <*> shrinker projectConfigLocalNoIndexRepos <*> shrinker projectConfigActiveRepos diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index 2a8566cc344..8322b642c19 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -63,6 +63,7 @@ instance ToExpr ProjectConfig instance ToExpr ProjectConfigBuildOnly instance ToExpr ProjectConfigProvenance instance ToExpr ProjectConfigShared +instance ToExpr ProjectConfigToolchain instance ToExpr ProjectFileParser instance ToExpr RelaxDepMod instance ToExpr RelaxDeps From d2030046a455c2b421dc196a3f61991b4f58b78e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 21 Mar 2025 18:11:01 +0800 Subject: [PATCH 016/122] feat(cabal-install-solver): all of it, second part --- .../src/Distribution/Solver/Modular.hs | 29 +++--- .../Distribution/Solver/Modular/Builder.hs | 74 +++++++-------- .../Solver/Modular/ConfiguredConversion.hs | 32 +++---- .../Distribution/Solver/Modular/Dependency.hs | 36 ++++---- .../Distribution/Solver/Modular/Explore.hs | 2 +- .../Solver/Modular/IndexConversion.hs | 90 ++++++++++++------- .../Distribution/Solver/Modular/Message.hs | 6 +- .../Distribution/Solver/Modular/Package.hs | 16 ++-- .../Distribution/Solver/Modular/Preference.hs | 16 ++-- .../src/Distribution/Solver/Modular/Solver.hs | 15 ++-- .../Distribution/Solver/Modular/Validate.hs | 71 ++++++++++----- .../Solver/Types/ConstraintSource.hs | 5 ++ .../Solver/Types/DependencyResolver.hs | 12 +-- .../Solver/Types/InstSolverPackage.hs | 4 + .../Solver/Types/PackageConstraint.hs | 6 +- .../Distribution/Solver/Types/PackagePath.hs | 50 ++++++++--- .../Solver/Types/SolverPackage.hs | 4 + .../src/Distribution/Client/Configure.hs | 9 +- .../src/Distribution/Client/Dependency.hs | 88 ++++++++---------- .../src/Distribution/Client/Fetch.hs | 11 +-- .../src/Distribution/Client/Freeze.hs | 9 +- cabal-install/src/Distribution/Client/Get.hs | 3 +- .../src/Distribution/Client/Install.hs | 8 +- .../Distribution/Client/ProjectPlanning.hs | 16 ++-- .../Distribution/Solver/Modular/DSL.hs | 9 +- .../Solver/Modular/DSL/TestCaseUtils.hs | 9 +- .../Distribution/Solver/Modular/QuickCheck.hs | 3 - 27 files changed, 365 insertions(+), 268 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index a4baebf496c..1b23cd80d44 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -39,6 +39,8 @@ import Distribution.Solver.Modular.IndexConversion ( convPIs ) import Distribution.Solver.Modular.Log ( SolverFailure(..), displayLogMessages ) +import Distribution.Solver.Modular.Message + ( renderSummarizedMessage ) import Distribution.Solver.Modular.Package ( PN ) import Distribution.Solver.Modular.RetryLog @@ -65,25 +67,26 @@ import Distribution.Solver.Types.Progress ( Progress(..), foldProgress ) import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage(StringMsg) ) -import Distribution.Solver.Types.Variable ( Variable(..) ) -import Distribution.System - ( Platform(..) ) +import Distribution.Solver.Types.Variable + ( Variable(..) ) +import Distribution.Solver.Types.Toolchain + import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) import Distribution.Verbosity ( normal, verbose ) -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 - where +modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do + uncurry postprocess <$> solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + where + cinfo = fst <$> toolchains + -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + idx = convPIs toolchains 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 @@ -133,21 +136,21 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns -- complete, i.e., it shows the whole chain of dependencies from the user -- targets to the conflicting packages. solve' :: SolverConfig - -> CompilerInfo + -> Staged CompilerInfo + -> Staged (Maybe PkgConfigDb) -> Index - -> Maybe PkgConfigDb -> (PN -> PackagePreferences) -> Map PN [LabeledPackageConstraint] -> Set PN -> Progress SummarizedMessage String (Assignment, RevDepMap) -solve' sc cinfo idx pkgConfigDB pprefs gcs pns = +solve' sc cinfo pkgConfigDb idx pprefs gcs pns = toProgress $ retry (runSolver printFullLog sc) createErrorMsg where runSolver :: Bool -> SolverConfig -> RetryLog SummarizedMessage SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = displayLogMessages keepLog $ - solve sc' cinfo idx pkgConfigDB pprefs gcs pns + solve sc' cinfo pkgConfigDb idx pprefs gcs pns createErrorMsg :: SolverFailure -> RetryLog SummarizedMessage String (Assignment, RevDepMap) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index b56dd7965ca..7f0568f97a6 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} module Distribution.Solver.Modular.Builder ( buildTree , splits -- for testing @@ -35,6 +36,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath +import qualified Distribution.Solver.Types.Stage as Stage -- | All state needed to build and link the search tree. It has a type variable -- because the linking phase doesn't need to know about the state used to build @@ -138,40 +140,42 @@ addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) -- If we have already picked a goal, then the choice depends on the kind -- of goal. --- --- For a package, we look up the instances available in the global info, --- and then handle each instance in turn. -addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = - case M.lookup pn idx of - Nothing -> FailF - (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) - UnknownPackage - Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> - ([], POption i Nothing, bs { next = Instance qpn info })) - (M.toList pis))) - -- TODO: data structure conversion is rather ugly here - --- For a flag, we create only two subtrees, and we create them in the order --- that is indicated by the flag default. -addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = - FChoiceF qfn rdm gr weak m b (W.fromList - [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), - ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) - where - trivial = L.null t && L.null f - weak = WeakOrTrivial $ unWeakOrTrivial w || trivial - --- For a stanza, we also create only two subtrees. The order is initially --- False, True. This can be changed later by constraints (force enabling --- the stanza by replacing the False branch with failure) or preferences --- (try enabling the stanza if possible by moving the True branch first). - -addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = - SChoiceF qsn rdm gr trivial (W.fromList - [([0], False, bs { next = Goals }), - ([1], True, (extendOpen qpn t bs) { next = Goals })]) - where - trivial = WeakOrTrivial (L.null t) +addChildren bs@(BS { rdeps, index, next = OneGoal goal }) = + case goal of + PkgGoal qpn@(Q (PackagePath s _) pn) gr -> + -- For a package goal, we look up the instances available in the global + -- info, and then handle each instance in turn. + case M.lookup pn index of + Nothing -> FailF + (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) + UnknownPackage + Just pis -> PChoiceF qpn rdeps gr $ W.fromList + [ ([], POption i Nothing, bs { next = Instance qpn info }) + | (i@(I s' _ver _loc), info) <- M.toList pis + -- Only instances belonging to the same stage are allowed. + , s == s' + ] + -- For a flag, we create only two subtrees, and we create them in the order + -- that is indicated by the flag default. + FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr -> + FChoiceF qfn rdeps gr weak m b $ W.fromList + [ ([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }) + , ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals }) + ] + where + trivial = L.null t && L.null f + weak = WeakOrTrivial $ unWeakOrTrivial w || trivial + -- For a stanza, we also create only two subtrees. The order is initially + -- False, True. This can be changed later by constraints (force enabling + -- the stanza by replacing the False branch with failure) or preferences + -- (try enabling the stanza if possible by moving the True branch first). + StanzaGoal qsn@(SN qpn _) t gr -> + SChoiceF qsn rdeps gr trivial $ W.fromList + [ ([0], False, bs { next = Goals }) + , ([1], True, (extendOpen qpn t bs) { next = Goals }) + ] + where + trivial = WeakOrTrivial (L.null t) -- For a particular instance, we change the state: we update the scope, -- and furthermore we update the set of goals. @@ -259,7 +263,7 @@ buildTree idx igs = where topLevelGoal qpn = PkgGoal qpn UserGoal - qpns = L.map (Q (PackagePath QualToplevel)) igs + qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs {------------------------------------------------------------------------------- Goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 06938efd762..72eedf3ceaa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -6,8 +6,6 @@ import Data.Maybe import Prelude hiding (pi) import Data.Either (partitionEithers) -import Distribution.Package (UnitId, packageId) - import qualified Distribution.Simple.PackageIndex as SI import Distribution.Solver.Modular.Configured @@ -21,41 +19,45 @@ import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage (Staged (..)) -- | Converts from the solver specific result @CP QPN@ into -- a 'ResolverPackage', which can then be converted into -- the install plan. -convCP :: SI.InstalledPackageIndex -> +convCP :: Staged SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = - case convPI qpi of - Left pi -> PreExisting $ + case qpi of + -- Installed + (PI qpn (I s _ (Inst pi))) -> + PreExisting $ InstSolverPackage { - instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, + instSolverStage = s, + instSolverQPN = qpn, + instSolverPkgIPI = fromMaybe (error "convCP: lookupUnitId failed") $ SI.lookupUnitId (getStage iidx s) pi, instSolverPkgLibDeps = fmap fst ds', instSolverPkgExeDeps = fmap snd ds' } - Right pi -> Configured $ + -- "In repo" i.e. a source package + (PI qpn@(Q _path pn) (I s v (InRepo _pn))) -> + let pi = PackageIdentifier pn v in + Configured $ SolverPackage { - solverPkgSource = srcpkg, + solverPkgStage = s, + solverPkgQPN = qpn, + solverPkgSource = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi, solverPkgFlags = fa, solverPkgStanzas = es, solverPkgLibDeps = fmap fst ds', solverPkgExeDeps = fmap snd ds' } - where - srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds -convPI :: PI QPN -> Either UnitId PackageId -convPI (PI _ (I _ (Inst pi))) = Left pi -convPI pi = Right (packageId (either id id (convConfId pi))) - convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath q) pn) (I v loc)) = +convConfId (PI (Q (PackagePath _stage q) pn) (I _stage' v loc)) = case loc of Inst pi -> Left (PreExistingId sourceId pi) _otherwise diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 5ca70df8b76..6a91197823e 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -62,6 +62,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName +import Distribution.Solver.Types.Stage {------------------------------------------------------------------------------- Constrained instances @@ -97,6 +98,7 @@ data FlaggedDep qpn Stanza (SN qpn) (TrueFlaggedDeps qpn) | -- | Dependencies which are always enabled, for the component 'comp'. Simple (LDep qpn) Component + deriving Show -- | Conservatively flatten out flagged dependencies -- @@ -119,6 +121,7 @@ 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 Show -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as @@ -132,7 +135,7 @@ data Dep qpn Lang Language | -- | dependency on a pkg-config package Pkg PkgconfigName PkgconfigVersionRange - deriving (Functor) + deriving (Functor, Show) -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. @@ -166,7 +169,7 @@ showDependencyReason (DependencyReason qpn flags stanzas) = -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. qualifyDeps :: QPN -> FlaggedDeps PN -> FlaggedDeps QPN -qualifyDeps (Q pp@(PackagePath q) pn) = go +qualifyDeps (Q pp@(PackagePath s q) pn) = go where go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 @@ -191,24 +194,17 @@ qualifyDeps (Q pp@(PackagePath q) pn) = go goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = - Dep (Q (PackagePath (QualExe pn qpn)) <$> dep) ci - goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) comp - | comp == ComponentSetup = Dep (Q (PackagePath (QualSetup pn)) <$> dep) ci - | otherwise = Dep (Q (PackagePath inheritedQ) <$> dep) ci - - -- If P has a setup dependency on Q, and Q has a regular dependency on R, then - -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup - -- dependency on R. We do not do this for the base qualifier however. - -- - -- The inherited qualifier is only used for regular dependencies; for setup - -- and base dependencies we override the existing qualifier. See #3160 for - -- a detailed discussion. - inheritedQ :: Qualifier - inheritedQ = case q of - QualSetup _ -> q - QualExe _ _ -> q - QualToplevel -> q + + -- In case of executable and setup dependencies, we need to qualify the dependency + -- with the previsous stage (e.g. Host -> Build). + goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _component = + Dep (Q (PackagePath (prevStage s) (QualExe pn qpn)) <$> dep) ci + + goD (Dep dep@(PkgComponent _qpn (ExposedLib _)) ci) ComponentSetup = + Dep (Q (PackagePath (prevStage s) (QualSetup pn)) <$> dep) ci + + goD (Dep dep@(PkgComponent _qpn _) ci) _component = + Dep (Q (PackagePath s q) <$> dep) ci -- | Remove qualifiers from set of dependencies -- diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs index d047ecda38e..8dfa9c88bf3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -268,7 +268,7 @@ exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx -- Skipping it is an optimization. If false, it returns a new conflict set -- to be merged with the previous one. couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet - couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = + couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I _stage v _) _) conflicts = let (PInfo deps _ _ _) = idx M.! pn M.! i qdeps = qualifyDeps currentQPN deps diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index 72d0b8193e3..c1dc4a5417d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -34,6 +34,7 @@ import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage (Stage(..), Staged(..), stages) import Distribution.Solver.Modular.Dependency as D import Distribution.Solver.Modular.Flag as F @@ -53,24 +54,31 @@ import Distribution.Solver.Modular.Version -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> ShadowPkgs -> StrongFlags -> SolveExecutables - -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) - -> Index -convPIs os arch comp constraints sip strfl solveExes iidx sidx = +convPIs + :: Staged (CompilerInfo, Platform) + -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs + -> StrongFlags + -> SolveExecutables + -> Staged SI.InstalledPackageIndex + -> CI.PackageIndex (SourcePackage loc) + -> Index +convPIs toolchains' constraints sip strfl solveExes iidx sidx = mkIndex $ - convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx + convIPI' sip iidx ++ convSPI' toolchains' constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. -convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] -convIPI' (ShadowPkgs sip) idx = +convIPI' :: ShadowPkgs -> Staged SI.InstalledPackageIndex -> [(PN, I, PInfo)] +convIPI' (ShadowPkgs sip) sipi = -- apply shadowing whenever there are multiple installed packages with -- the same version - [ maybeShadow (convIP idx pkg) + [ maybeShadow (convIP stage idx pkg) -- IMPORTANT to get internal libraries. See -- Note [Index conversion with internal libraries] - | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx + | stage <- stages + , let idx = getStage sipi stage + , (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] where @@ -80,16 +88,16 @@ convIPI' (ShadowPkgs sip) idx = shadow x = x -- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. -convId :: IPI.InstalledPackageInfo -> (PN, I) -convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) +convId :: Stage -> IPI.InstalledPackageInfo -> (PN, I) +convId stage ipi = (pn, I stage ver $ Inst $ IPI.installedUnitId ipi) where MungedPackageId mpn ver = mungedId ipi -- HACK. See Note [Index conversion with internal libraries] pn = encodeCompatPackageName mpn -- | Convert a single installed package into the solver-specific format. -convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) -convIP idx ipi = - case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of +convIP :: Stage -> SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) +convIP stage idx ipi = + case traverse (convIPId stage (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) Right fds -> (pn, i, PInfo fds components M.empty Nothing) where @@ -101,7 +109,7 @@ convIP idx ipi = , compIsBuildable = IsBuildable True } - (pn, i) = convId ipi + (pn, i) = convId stage ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways @@ -141,41 +149,54 @@ convIP idx ipi = -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. -convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) -convIPId dr comp idx ipid = +convIPId :: Stage -> DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) +convIPId stage dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Left ipid - Just ipi -> let (pn, i) = convId ipi - name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. + Just ipi -> let (pn, i) = convId stage ipi + name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] - -> StrongFlags -> SolveExecutables - -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo constraints strfl solveExes = - L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages +-- NOTE: The package description of source package can depent on the platform +-- and compiler version. Here we decide to convert a single source package +-- into multiple index entries, one for each stage, where the conditionals are +-- resolved. This choice might incour in high memory consumption and it might +-- be worth looking for a different approach. +convSPI' + :: Staged (CompilerInfo, Platform) + -> Map PN [LabeledPackageConstraint] + -> StrongFlags + -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) + -> [(PN, I, PInfo)] +convSPI' toolchains constraints strfl solveExes sidx = + concat $ + [ map (convSP stage os arch cinfo constraints strfl solveExes) (CI.allPackages sidx) + | stage <- stages + , let (cinfo, Platform arch os) = getStage toolchains stage + ] -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] +convSP :: Stage -> OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = - let i = I pv InRepo +convSP stage os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = + let i = I stage pv (InRepo pn) pkgConstraints = fromMaybe [] $ M.lookup pn constraints - in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) + in (pn, i, convGPD stage os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] +convGPD :: Stage -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo constraints strfl solveExes pn +convGPD stage os arch cinfo constraints strfl solveExes pn (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -233,7 +254,7 @@ convGPD os arch cinfo constraints strfl solveExes pn , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False } - testCondition = testConditionForComponent os arch cinfo constraints + testCondition = testConditionForComponent stage os arch cinfo constraints isPrivate LibraryVisibilityPrivate = True isPrivate LibraryVisibilityPublic = False @@ -246,14 +267,15 @@ convGPD os arch cinfo constraints strfl solveExes pn -- before dependency solving. Additionally, this function only considers flags -- that are set by unqualified flag constraints, and it doesn't check the -- intra-package dependencies of a component. -testConditionForComponent :: OS +testConditionForComponent :: Stage + -> OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> (a -> Bool) -> CondTree ConfVar [Dependency] a -> Maybe Bool -testConditionForComponent os arch cinfo constraints p tree = +testConditionForComponent _stage os arch cinfo constraints p tree = case go $ extractCondition p tree of Lit True -> Just True Lit False -> Just False diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index d6ffadf0abf..d4ce663e6be 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -34,7 +34,7 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.MessageUtils ( showUnsupportedExtension, showUnsupportedLanguage ) import Distribution.Solver.Modular.Package - ( PI(PI), showI, showPI ) + ( showI ) import Distribution.Solver.Modular.Tree ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version @@ -262,8 +262,8 @@ data MergedPackageConflict = MergedPackageConflict { showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of - Nothing -> showPI (PI qpn i) -- Consistent with prior to POption - Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + Nothing -> showQPN qpn ++ " == " ++ showI i + Just pp' -> showQPN qpn ++ " ~> " ++ showQPN (Q pp' pn) -- | Shows a mixed list of instances and versions in a human-friendly way, -- abbreviated. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs index ea3352f5c7c..01a6224b40a 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -25,6 +25,7 @@ import Distribution.Pretty (prettyShow) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath +import Distribution.Solver.Types.Stage (Stage, showStage) -- | A package name. type PN = PackageName @@ -47,22 +48,17 @@ type PId = UnitId -- package instance via its 'PId'. -- -- TODO: More information is needed about the repo. -data Loc = Inst PId | InRepo +data Loc = Inst PId | InRepo PackageName deriving (Eq, Ord, Show) -- | Instance. A version number and a location. -data I = I Ver Loc +data I = I Stage Ver Loc deriving (Eq, Ord, Show) -- | String representation of an instance. showI :: I -> String -showI (I v InRepo) = showVer v -showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid - where - extractPackageAbiHash xs = - case first reverse $ break (=='-') $ reverse (prettyShow xs) of - (ys, []) -> ys - (ys, _) -> '-' : ys +showI (I s v (InRepo pn)) = intercalate ":" [showStage s, "source", prettyShow (PackageIdentifier pn v)] +showI (I s _v (Inst uid)) = intercalate ":" [showStage s, "installed", prettyShow uid] -- | Package instance. A package name and an instance. data PI qpn = PI qpn I @@ -73,7 +69,7 @@ showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i instI :: I -> Bool -instI (I _ (Inst _)) = True +instI (I _ _ (Inst _)) = True instI _ = False -- | Is the package in the primary group of packages. This is used to diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs index 39600474965..989d31e9047 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs @@ -72,7 +72,7 @@ addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c addWeight f = addWeights [f] version :: POption -> Ver -version (POption (I v _) _) = v +version (POption (I _ v _) _) = v -- | Prefer to link packages whenever possible. preferLinked :: EndoTreeTrav d c @@ -139,7 +139,7 @@ preferPackagePreferences pcs = -- Prefer installed packages over non-installed packages. installed :: POption -> Weight - installed (POption (I _ (Inst _)) _) = 0 + installed (POption (I _ _ (Inst _)) _) = 0 installed _ = 1 -- | Traversal that tries to establish package stanza enable\/disable @@ -184,7 +184,7 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s else r where go :: I -> PackageProperty -> Tree d c - go (I v _) (PackagePropertyVersion vr) + go (I _ v _) (PackagePropertyVersion vr) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) go _ PackagePropertyInstalled @@ -338,10 +338,10 @@ avoidReinstalls p = go | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = - let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] + let installed = [ v | (_, POption (I _ v (Inst _)) _, _) <- W.toList cs ] in W.mapWithKey (notReinstall installed) cs - notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = + notReinstall vs (POption (I _ v (InRepo _pn)) _) _ | v `elem` vs = Fail (varToConflictSet (P qpn)) CannotReinstall notReinstall _ _ x = x @@ -420,9 +420,9 @@ deferSetupExeChoices = go go x = x noSetupOrExe :: Goal QPN -> Bool - noSetupOrExe (Goal (P (Q (PackagePath (QualSetup _)) _)) _) = False - noSetupOrExe (Goal (P (Q (PackagePath (QualExe _ _)) _)) _) = False - noSetupOrExe _ = True + noSetupOrExe (Goal (P (Q (PackagePath _ (QualSetup _)) _)) _) = False + noSetupOrExe (Goal (P (Q (PackagePath _ (QualExe _ _)) _)) _) = False + noSetupOrExe _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs index 24f8c40dd81..cff2264d063 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -44,11 +44,12 @@ import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.PSQ as PSQ import Distribution.Simple.Setup (BooleanFlag(..)) +import Distribution.Solver.Types.Stage (Staged, Stage(..)) #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W -import qualified Distribution.Deprecated.Text as T +import Distribution.Solver.Modular.Version (showVer) import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple @@ -88,14 +89,14 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool -- before exploration. -- solve :: SolverConfig -- ^ solver parameters - -> CompilerInfo + -> Staged CompilerInfo + -> Staged (Maybe PkgConfigDb) -> Index -- ^ all available packages as an index - -> Maybe PkgConfigDb -- ^ available pkg-config pkgs -> (PN -> PackagePreferences) -- ^ preferences -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints -> S.Set PN -- ^ global goals -> RetryLog Message SolverFailure (Assignment, RevDepMap) -solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = +solve sc cinfo pkgConfigDB idx userPrefs userConstraints userGoals = explorePhase . traceTree "cycles.json" id . detectCycles . @@ -136,7 +137,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = P.enforceManualFlags userConstraints validationCata = P.enforceSingleInstanceRestriction . validateLinking idx . - validateTree cinfo idx pkgConfigDB + validateTree cinfo pkgConfigDB idx prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) . (case onlyConstrained sc of OnlyConstrainedAll -> @@ -203,7 +204,7 @@ instance GSimpleTree (Tree d c) where -- Show package choice goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) + goP _ (POption (I _stage ver _loc) Nothing) subtree = (showVer ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice @@ -250,5 +251,5 @@ _removeGR = trav go dummy = DependencyGoal $ DependencyReason - (Q (PackagePath QualToplevel) (mkPackageName "$")) + (Q (PackagePath Host QualToplevel) (mkPackageName "$")) M.empty S.empty diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index d6de20cc1de..251af0a32bc 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs @@ -35,6 +35,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange +import Distribution.Solver.Types.Stage (Staged (..), Stage (..)) -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints @@ -88,9 +89,9 @@ import Distribution.Types.PkgconfigVersionRange -- | The state needed during validation. data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool), + supportedExt :: Stage -> Extension -> Bool, + supportedLang :: Stage -> Language -> Bool, + presentPkgs :: Stage -> Maybe (PkgconfigName -> PkgconfigVersionRange -> Bool), index :: Index, -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, @@ -189,7 +190,7 @@ validate = go -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) - goP qpn@(Q _pp pn) (POption i _) r = do + goP qpn@(Q (PackagePath _stage _) pn) (POption i _mpp) r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -199,6 +200,7 @@ validate = go aComps <- asks availableComponents rComps <- asks requiredComponents -- obtain dependencies and index-dictated exclusions introduced by the choice + let I stage _vr _loc = i let (PInfo deps comps _ mfr) = idx ! pn ! i -- qualify the deps in the current scope let qdeps = qualifyDeps qpn deps @@ -206,8 +208,8 @@ validate = go -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. - let mnppa = extend extSupported langSupported pkgPresent newactives - =<< extendWithPackageChoice (PI qpn i) ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives + =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of @@ -232,7 +234,7 @@ validate = go -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goF qfn@(FN qpn _f) b r = do + goF qfn@(FN qpn@(Q (PackagePath stage _) _) _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -254,7 +256,7 @@ validate = go let newactives = extractNewDeps (F qfn) b npfa psa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> @@ -262,7 +264,7 @@ validate = go -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) - goS qsn@(SN qpn _f) b r = do + goS qsn@(SN qpn@(Q (PackagePath stage _) _) _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages @@ -284,7 +286,7 @@ validate = go let newactives = extractNewDeps (S qsn) b pfa npsa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. - let mnppa = extend extSupported langSupported pkgPresent newactives ppa + let mnppa = extend (extSupported stage) (langSupported stage) (pkgPresent stage) newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> @@ -328,7 +330,14 @@ checkComponentsInNewPackage required qpn providedComps = -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired. -extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractAllDeps + :: FAssignment + -- ^ current flag assignments + -> SAssignment + -- ^ current stanza assignments + -> FlaggedDeps QPN + -- ^ conditional dependencies + -> [LDep QPN] extractAllDeps fa sa deps = do d <- deps case d of @@ -345,7 +354,19 @@ extractAllDeps fa sa deps = do -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractAllDeps' for everything underneath. -extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] +extractNewDeps + :: Var QPN + -- ^ the variable (package, flag or stanza) + -> Bool + -- ^ the variable value + -> FAssignment + -- ^ current flag assignments + -> SAssignment + -- ^ current stanza assignments + -> FlaggedDeps QPN + -- ^ conditional dependencies + -> [LDep QPN] + -- ^ dependencies with a reason extractNewDeps v b fa sa = go where go :: FlaggedDeps QPN -> [LDep QPN] @@ -449,14 +470,14 @@ merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) +merge (MergedDepFixed comp1 vs1 i@(I _ v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I _ v _))) = go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep @@ -560,18 +581,22 @@ extendRequiredComponents eqpn available = foldM extendSingle -- | Interface. -validateTree :: CompilerInfo -> Index -> Maybe PkgConfigDb -> Tree d c -> Tree d c -validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in \ x -> S.member x s) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent <$> pkgConfigDb +validateTree :: Staged CompilerInfo -> Staged (Maybe PkgConfigDb) -> Index -> Tree d c -> Tree d c +validateTree cinfo pkgConfigDb idx t = runValidate (validate t) VS + { -- if compiler has no list of extensions, we assume everything is supported + supportedExt = maybe (const True) (flip S.member) . getStage extSet + , -- if compiler has no list of extensions, we assume everything is supported + supportedLang = maybe (const True) (flip S.member) . getStage langSet + , presentPkgs = fmap pkgConfigPkgIsPresent . getStage pkgConfigDb , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty , availableComponents = M.empty , requiredComponents = M.empty } + where + extSet :: Staged (Maybe (S.Set Extension)) + extSet = fmap (fmap S.fromList . compilerInfoExtensions) cinfo + + langSet :: Staged (Maybe (S.Set Language)) + langSet = fmap (fmap S.fromList . compilerInfoLanguages) cinfo diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index 0deb786959b..061d6c692aa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -60,6 +60,9 @@ data ConstraintSource = -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion + + -- | TODO + | ConstraintHideInstalledPackagesSpecificBySourcePackageId deriving (Show, Eq, Generic) instance Binary ConstraintSource @@ -94,3 +97,5 @@ instance Pretty ConstraintSource where text "minimum version of Cabal used by Setup.hs" ConstraintSetupCabalMaxVersion -> text "maximum version of Cabal used by Setup.hs" + ConstraintHideInstalledPackagesSpecificBySourcePackageId -> + text "HideInstalledPackagesSpecificBySourcePackageId" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs index 956a4e14849..d58dfe49af3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/DependencyResolver.hs @@ -15,7 +15,10 @@ import Distribution.Solver.Types.Progress ( Progress ) import Distribution.Solver.Types.ResolverPackage ( ResolverPackage ) -import Distribution.Solver.Types.SourcePackage ( SourcePackage ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage ) +import Distribution.Solver.Types.Stage + ( Staged ) import Distribution.Solver.Types.SummarizedMessage ( SummarizedMessage(..) ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) @@ -31,11 +34,10 @@ import Distribution.System ( Platform ) -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. -- -type DependencyResolver loc = Platform - -> CompilerInfo - -> InstalledPackageIndex +type DependencyResolver loc = Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> PackageIndex (SourcePackage loc) - -> Maybe PkgConfigDb -> (PackageName -> PackagePreferences) -> [LabeledPackageConstraint] -> Set PackageName diff --git a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs index 871a0dd15a9..b2358bca348 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -8,7 +8,9 @@ import Prelude () import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.PackagePath (QPN) import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.Stage (Stage) import Distribution.Types.MungedPackageId import Distribution.Types.PackageId import Distribution.Types.MungedPackageName @@ -17,6 +19,8 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) -- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { + instSolverStage :: Stage, + instSolverQPN :: QPN, instSolverPkgIPI :: InstalledPackageInfo, instSolverPkgLibDeps :: ComponentDeps [SolverId], instSolverPkgExeDeps :: ComponentDeps [SolverId] diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 7887ba21840..20a8399b1d3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -68,12 +68,12 @@ scopeToPackageName (ScopeAnySetupQualifier pn) = pn scopeToPackageName (ScopeAnyQualifier pn) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath q) pn') = +constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') = q == QualToplevel && pn == pn' -constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath q') pn') = +constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = - let setup (PackagePath (QualSetup _)) = True + let setup (PackagePath _ (QualSetup _)) = True setup _ = False in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 9eae0acf988..38cb0dd8d01 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Qualifier(..) @@ -11,11 +13,19 @@ module Distribution.Solver.Types.PackagePath import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageName) -import Distribution.Pretty (pretty, flatStyle) +import Distribution.Pretty (pretty, flatStyle, Pretty) import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Types.Stage (Stage) -data PackagePath = PackagePath Qualifier - deriving (Eq, Ord, Show) +data PackagePath = PackagePath Stage Qualifier + deriving (Eq, Ord, Show, Generic) + +instance Binary PackagePath +instance Structured PackagePath + +instance Pretty PackagePath where + pretty (PackagePath stage qualifier) = + pretty stage <<>> Disp.text ":" <<>> pretty qualifier -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = @@ -42,27 +52,45 @@ 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 Binary Qualifier +instance Structured Qualifier + +instance Pretty Qualifier where + pretty QualToplevel = Disp.text "toplevel" + pretty (QualSetup pn) = pretty pn <<>> Disp.text ":setup" + pretty (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> + pretty pn2 <<>> Disp.text ":exe" -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. dispQualifier :: Qualifier -> Disp.Doc -dispQualifier QualToplevel = Disp.empty -dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." -dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> - pretty pn2 <<>> Disp.text ":exe." +dispQualifier QualToplevel = mempty +dispQualifier (QualSetup pn) = pretty pn <> Disp.text ":setup." +dispQualifier (QualExe pn pn2) = + pretty pn + <> Disp.text ":" + <> pretty pn2 + <> Disp.text ":exe." -- | 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 (Binary a) => Binary (Qualified a) +instance (Structured a) => Structured (Qualified a) -- | Qualified package name. type QPN = Qualified PackageName +instance Pretty (Qualified PackageName) where + pretty (Q (PackagePath stage qual) pn) = + pretty stage <<>> Disp.colon <<>> dispQualifier qual <<>> pretty pn + -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc -dispQPN (Q (PackagePath qual) pn) = - dispQualifier qual <<>> pretty pn +dispQPN = pretty -- | String representation of a qualified package name. showQPN :: QPN -> String diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs index 186f140aefe..f170542ac19 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverPackage.hs @@ -12,6 +12,8 @@ import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Stage ( Stage ) +import Distribution.Solver.Types.PackagePath ( QPN ) -- | A 'SolverPackage' is a package specified by the dependency solver. -- It will get elaborated into a 'ConfiguredPackage' or even an @@ -21,6 +23,8 @@ import Distribution.Solver.Types.SourcePackage -- but for symmetry we have the parameter. (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage { + solverPkgStage :: Stage, + solverPkgQPN :: QPN, solverPkgSource :: SourcePackage loc, solverPkgFlags :: FlagAssignment, solverPkgStanzas :: OptionalStanzaSet, diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index cc00d0b826a..38230a83152 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -67,6 +67,7 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags) import Distribution.Package @@ -464,14 +465,18 @@ planLocalPackage . setSolveExecutables (SolveExecutables False) . setSolverVerbosity verbosity $ standardInstallPolicy - installedPkgIndex -- NB: We pass in an *empty* source package database, -- because cabal configure assumes that all dependencies -- have already been installed (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies platform (compilerInfo comp) pkgConfigDb resolverParams) + return $ + resolveDependencies + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) + resolverParams -- | 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 1990b54d1ac..bd430bc41de 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -160,6 +160,7 @@ import Distribution.Solver.Types.SolverPackage ( SolverPackage (SolverPackage) ) import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.Toolchain import Distribution.Solver.Types.Variable import Control.Exception @@ -185,7 +186,7 @@ data DepResolverParams = DepResolverParams , depResolverConstraints :: [LabeledPackageConstraint] , depResolverPreferences :: [PackagePreference] , depResolverPreferenceDefault :: PackagesPreferenceDefault - , depResolverInstalledPkgIndex :: InstalledPackageIndex + , depResolverInstalledPkgIndex :: InstalledPackageIndex -> InstalledPackageIndex , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage , depResolverReorderGoals :: ReorderGoals , depResolverCountConflicts :: CountConflicts @@ -278,16 +279,15 @@ showPackagePreference (PackageStanzasPreference pn st) = prettyShow pn ++ " " ++ show st basicDepResolverParams - :: InstalledPackageIndex - -> PackageIndex.PackageIndex UnresolvedSourcePackage + :: PackageIndex.PackageIndex UnresolvedSourcePackage -> DepResolverParams -basicDepResolverParams installedPkgIndex sourcePkgIndex = +basicDepResolverParams sourcePkgIndex = DepResolverParams { depResolverTargets = Set.empty , depResolverConstraints = [] , depResolverPreferences = [] , depResolverPreferenceDefault = PreferLatestForSelected - , depResolverInstalledPkgIndex = installedPkgIndex + , depResolverInstalledPkgIndex = id , depResolverSourcePkgIndex = sourcePkgIndex , depResolverReorderGoals = ReorderGoals False , depResolverCountConflicts = CountConflicts True @@ -493,10 +493,8 @@ hideInstalledPackagesSpecificBySourcePackageId pkgids params = -- TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' - (flip InstalledPackageIndex.deleteSourcePackageId) - (depResolverInstalledPkgIndex params) - pkgids + (\idx -> foldl' (flip InstalledPackageIndex.deleteSourcePackageId) idx pkgids) + . depResolverInstalledPkgIndex params } hideInstalledPackagesAllVersions @@ -507,10 +505,8 @@ hideInstalledPackagesAllVersions pkgnames params = -- TODO: this should work using exclude constraints instead params { depResolverInstalledPkgIndex = - foldl' - (flip InstalledPackageIndex.deletePackageName) - (depResolverInstalledPkgIndex params) - pkgnames + (\idx -> foldl' (flip InstalledPackageIndex.deletePackageName) idx pkgnames) + . depResolverInstalledPkgIndex params } -- | Remove upper bounds in dependencies using the policy specified by the @@ -697,12 +693,10 @@ reinstallTargets params = -- | A basic solver policy on which all others are built. basicInstallPolicy - :: InstalledPackageIndex - -> SourcePackageDb + :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams basicInstallPolicy - installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) pkgSpecifiers = addPreferences @@ -718,7 +712,6 @@ basicInstallPolicy . addSourcePackages [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] $ basicDepResolverParams - installedPkgIndex sourcePkgIndex -- | The policy used by all the standard commands, install, fetch, freeze etc @@ -726,14 +719,12 @@ basicInstallPolicy -- -- It extends the 'basicInstallPolicy' with a policy on setup deps. standardInstallPolicy - :: InstalledPackageIndex - -> SourcePackageDb + :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams -standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers = +standardInstallPolicy sourcePkgDb pkgSpecifiers = addDefaultSetupDependencies mkDefaultSetupDeps $ basicInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers where @@ -779,14 +770,14 @@ runSolver = modularResolver -- 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 + :: Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> DepResolverParams -> Progress String String SolverInstallPlan -resolveDependencies platform comp pkgConfigDB params = +resolveDependencies toolchains pkgConfigDB installedPkgIndex params = Step (showDepResolverParams finalparams) $ - fmap (validateSolverResult platform comp) $ + fmap (validateSolverResult toolchains) $ formatProgress $ runSolver ( SolverConfig @@ -805,11 +796,10 @@ resolveDependencies platform comp pkgConfigDB params = verbosity (PruneAfterFirstSuccess False) ) - platform - comp - installedPkgIndex - sourcePkgIndex + toolchains pkgConfigDB + (fmap installedPkgIndexM installedPkgIndex) + sourcePkgIndex preferences constraints targets @@ -819,7 +809,7 @@ resolveDependencies platform comp pkgConfigDB params = constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex reordGoals cntConflicts @@ -908,12 +898,11 @@ interpretPackagesPreference selected defaultPref prefs = -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. validateSolverResult - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] -> SolverInstallPlan -validateSolverResult platform comp pkgs = - case planPackagesProblems platform comp pkgs of +validateSolverResult toolchains pkgs = + case planPackagesProblems toolchains pkgs of [] -> case SolverInstallPlan.new graph of Right plan -> plan Left problems -> error (formatPlanProblems problems) @@ -958,14 +947,13 @@ showPlanPackageProblem (DuplicatePackageSolverId pid dups) = ++ " duplicate instances." planPackagesProblems - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] -> [PlanPackageProblem] -planPackagesProblems platform cinfo pkgs = +planPackagesProblems toolchains pkgs = [ InvalidConfiguredPackage pkg packageProblems | Configured pkg <- pkgs - , let packageProblems = configuredPackageProblems platform cinfo pkg + , let packageProblems = configuredPackageProblems toolchains pkg , not (null packageProblems) ] ++ [ DuplicatePackageSolverId (Graph.nodeKey aDup) dups @@ -1014,14 +1002,12 @@ showPackageProblem (InvalidDep dep pkgid) = -- in the configuration given by the flag assignment, all the package -- dependencies are satisfied by the specified packages. configuredPackageProblems - :: Platform - -> CompilerInfo + :: Staged (CompilerInfo, Platform) -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems - platform - cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = + toolchains + (SolverPackage stage _qpn pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') = [ DuplicateFlag flag | flag <- PD.findDuplicateFlagAssignments specifiedFlags ] @@ -1094,8 +1080,8 @@ configuredPackageProblems specifiedFlags compSpec (const Satisfied) - platform - cinfo + (snd (getStage toolchains stage)) + (fst (getStage toolchains stage)) [] (srcpkgDescription pkg) of Right (resolvedPkg, _) -> @@ -1134,6 +1120,7 @@ configuredPackageProblems -- It simply means preferences for installed packages will be ignored. resolveWithoutDependencies :: DepResolverParams + -> InstalledPackageIndex -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies ( DepResolverParams @@ -1141,7 +1128,7 @@ resolveWithoutDependencies constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex _reorderGoals _countConflicts @@ -1157,7 +1144,8 @@ resolveWithoutDependencies _onlyConstrained _order _verbosity - ) = + ) + installedPkgIndex = collectEithers $ map selectPackage (Set.toList targets) where selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage @@ -1182,6 +1170,7 @@ resolveWithoutDependencies bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering bestByPrefs = comparing $ \pkg -> (installPref pkg, versionPref pkg, packageVersion pkg) + installPref :: UnresolvedSourcePackage -> Bool installPref = case preferInstalled of Preference.PreferLatest -> const False @@ -1190,8 +1179,9 @@ resolveWithoutDependencies not . null . InstalledPackageIndex.lookupSourcePackageId - installedPkgIndex + (installedPkgIndexM installedPkgIndex) . packageId + versionPref :: Package a => a -> Int versionPref pkg = length . filter (packageVersion pkg `withinRange`) $ diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 4842705123a..f31448fd0f6 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -38,6 +38,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors import Distribution.Package @@ -174,9 +175,9 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . PlanPackages . show) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams -- The packages we want to fetch are those packages the 'InstallPlan' @@ -188,7 +189,7 @@ planPackages ] | otherwise = either (dieWithException verbosity . PlanPackages . unlines . map show) return $ - resolveWithoutDependencies resolverParams + resolveWithoutDependencies resolverParams installedPkgIndex where resolverParams :: DepResolverParams resolverParams = @@ -219,7 +220,7 @@ planPackages -- already installed. Since we want to get the source packages of -- things we might have installed (but not have the sources for). . reinstallTargets - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers includeDependencies = fromFlag (fetchDeps fetchFlags) logMsg message rest = debug verbosity message >> rest diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index b5002021fc3..42f2a89b386 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -52,6 +52,7 @@ import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors import Distribution.Package @@ -212,9 +213,9 @@ planPackages installPlan <- foldProgress logMsg (dieWithException verbosity . FreezeException) return $ resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams return $ pruneInstallPlan installPlan pkgSpecifiers @@ -244,7 +245,7 @@ planPackages in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers logMsg message rest = debug verbosity message >> rest diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs index 328e93e9c9e..ea9793bb0ee 100644 --- a/cabal-install/src/Distribution/Client/Get.hs +++ b/cabal-install/src/Distribution/Client/Get.hs @@ -127,6 +127,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do either (dieWithException verbosity . PkgSpecifierException . map show) return $ resolveWithoutDependencies (resolverParams sourcePkgDb pkgSpecifiers) + mempty unless (null prefix) $ createDirectoryIfMissing True prefix @@ -146,7 +147,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams resolverParams sourcePkgDb pkgSpecifiers = -- TODO: add command-line constraint and preference args for unpack - standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + standardInstallPolicy sourcePkgDb pkgSpecifiers onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags) diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 84acdd12d79..f0c9c1e4837 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -142,6 +142,7 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage as SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.ProjectConfig import Distribution.Client.Utils @@ -586,9 +587,9 @@ planPackages pkgConfigDb pkgSpecifiers = resolveDependencies - platform - (compilerInfo comp) - pkgConfigDb + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDb) + (Stage.always installedPkgIndex) resolverParams >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return where @@ -650,7 +651,6 @@ planPackages -- doesn't understand how to install them . setSolveExecutables (SolveExecutables False) $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index e9319daf0fc..ae9d305615d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -164,6 +164,7 @@ import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.ModuleName import Distribution.Package @@ -712,7 +713,7 @@ rebuildInstallPlan newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile -- Configure the compiler we're using. - -- + -- This is moderately expensive and doesn't change that often so we cache -- it independently. -- @@ -1313,9 +1314,9 @@ planPackages localPackages pkgStanzasEnable = resolveDependencies - platform - (compilerInfo comp) - pkgConfigDB + (Stage.always (compilerInfo comp, platform)) + (Stage.always pkgConfigDB) + (Stage.always installedPkgIndex) resolverParams where -- TODO: [nice to have] disable multiple instances restriction in @@ -1434,7 +1435,6 @@ planPackages -- Note: we don't use the standardInstallPolicy here, since that uses -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy - installedPkgIndex sourcePkgDb localPackages @@ -1700,7 +1700,7 @@ elaborateInstallPlan :: (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) = + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ _ _ deps0 exe_deps0) = case mkComponentsGraph (elabEnabledSpec elab0) pd of Right g -> do let src_comps = componentsGraphToList g @@ -2080,6 +2080,8 @@ elaborateInstallPlan elaborateSolverToPackage pkgWhyNotPerComponent pkg@( SolverPackage + _stage + _qpn (SourcePackage pkgid _gpd _srcloc _descOverride) _flags _stanzas @@ -2181,6 +2183,8 @@ elaborateInstallPlan -> ElaboratedConfiguredPackage elaborateSolverToCommon pkg@( SolverPackage + _stage + _qpn (SourcePackage pkgid gdesc srcloc descOverride) flags stanzas diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index f01c4c3e92d..2b19a47a37e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -95,6 +95,7 @@ import qualified Distribution.Solver.Types.PkgConfigDb as PC import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Solver.Types.Variable {------------------------------------------------------------------------------- @@ -821,7 +822,11 @@ exResolve prefs verbosity enableAllTests = - resolveDependencies C.buildPlatform compiler pkgConfigDb params + resolveDependencies + (Stage.always (compiler, C.buildPlatform)) + (Stage.always pkgConfigDb) + (Stage.always instIdx) + params where defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag compiler = @@ -863,7 +868,7 @@ exResolve setSolveExecutables solveExes $ setGoalOrder goalOrder $ setSolverVerbosity verbosity $ - standardInstallPolicy instIdx avaiIdx targets' + standardInstallPolicy avaiIdx targets' toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown toConstraint (ExVersionConstraint scope v) = diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs index e4753de25b9..3b670caf176 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -48,6 +48,7 @@ import Distribution.Client.Dependency (foldProgress) import qualified Distribution.Solver.Types.PackagePath as P import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList) import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.Stage import Distribution.Solver.Types.Variable import UnitTests.Distribution.Solver.Modular.DSL import UnitTests.Options @@ -298,10 +299,10 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> toQPN q pn = P.Q pp (C.mkPackageName pn) where pp = case q of - QualNone -> P.PackagePath P.QualToplevel + QualNone -> P.PackagePath Host P.QualToplevel QualSetup s -> - P.PackagePath (P.QualSetup (C.mkPackageName s)) + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) QualIndepSetup _ s -> - P.PackagePath (P.QualSetup (C.mkPackageName s)) + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) QualExe p1 p2 -> - P.PackagePath (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) + P.PackagePath Host (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 92f3a559fec..ed51de157c2 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -607,9 +607,6 @@ instance ArbitraryOrd ShortText where instance ArbitraryOrd Stage deriving instance Generic (Variable pn) -deriving instance Generic (P.Qualified a) -deriving instance Generic P.PackagePath -deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs From c621fb653a64678e2e8c6bd7eaa16142aadd7478 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 24 Jul 2025 10:57:01 +0800 Subject: [PATCH 017/122] refactor(cabal-install): don't check for compiler support before using jsem This is a user problem. User should not enable jsem on a compiler that does not support it. This change also avoid us to pass the compiler all the way down. A better approach to restore this functionality would be to defer the application of the parallel strategy. --- .../src/Distribution/Client/CmdInstall.hs | 1 - .../src/Distribution/Client/JobControl.hs | 19 ++----------------- .../Distribution/Client/ProjectBuilding.hs | 2 +- .../src/Distribution/Client/ProjectConfig.hs | 7 +------ .../Distribution/Client/ProjectPlanning.hs | 9 +++------ 5 files changed, 7 insertions(+), 31 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 08662af5285..0ab5b5c83bc 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -475,7 +475,6 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project fetchAndReadSourcePackages verbosity distDirLayout - (Just compiler) (projectConfigShared config) (projectConfigBuildOnly config) [ProjectPackageRemoteTarball uri | uri <- uris] diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs index 280916fdf6c..d37397987d3 100644 --- a/cabal-install/src/Distribution/Client/JobControl.hs +++ b/cabal-install/src/Distribution/Client/JobControl.hs @@ -50,7 +50,6 @@ import Control.Monad (forever, replicateM_) import Distribution.Client.Compat.Semaphore import Distribution.Client.Utils (numberOfProcessors) import Distribution.Compat.Stack -import Distribution.Simple.Compiler import Distribution.Simple.Utils import Distribution.Types.ParStrat import System.Semaphore @@ -277,29 +276,15 @@ criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act newJobControlFromParStrat :: Verbosity - -> Maybe Compiler - -- ^ The compiler, used to determine whether Jsem is supported. - -- When Nothing, Jsem is assumed to be unsupported. -> ParStratInstall -- ^ The parallel strategy -> Maybe Int -- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy) -> IO (JobControl IO a) -newJobControlFromParStrat verbosity mcompiler parStrat numJobsCap = case parStrat of +newJobControlFromParStrat verbosity parStrat numJobsCap = case parStrat of Serial -> newSerialJobControl NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n)) - UseSem n -> - case mcompiler of - Just compiler - | jsemSupported compiler -> - newSemaphoreJobControl verbosity (capJobs n) - | otherwise -> - do - warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control." - newParallelJobControl (capJobs n) - Nothing -> - -- Don't warn in the Nothing case, as there isn't really a "selected" compiler. - newParallelJobControl (capJobs n) + UseSem n -> newSemaphoreJobControl verbosity (capJobs n) where capJobs n = min (fromMaybe maxBound numJobsCap) n diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 7bf6de869a5..bd1f3d4ebf4 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -369,7 +369,7 @@ rebuildTargets -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. - withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do + withJobControl (newJobControlFromParStrat verbosity buildSettingNumJobs Nothing) $ \jobControl -> do -- Before traversing the install plan, preemptively find all packages that -- will need to be downloaded and start downloading them. asyncDownloadPackages diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index d2a6046da41..3b2b7e886cd 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1398,7 +1398,6 @@ mplusMaybeT ma mb = do fetchAndReadSourcePackages :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> [ProjectPackageLocation] @@ -1406,7 +1405,6 @@ fetchAndReadSourcePackages fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations = do @@ -1443,7 +1441,6 @@ fetchAndReadSourcePackages syncAndReadSourcePackagesRemoteRepos verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) @@ -1562,7 +1559,6 @@ fetchAndReadSourcePackageRemoteTarball syncAndReadSourcePackagesRemoteRepos :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> Bool @@ -1571,7 +1567,6 @@ syncAndReadSourcePackagesRemoteRepos syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory} - compiler ProjectConfigShared { projectConfigProgPathExtra } @@ -1606,7 +1601,7 @@ syncAndReadSourcePackagesRemoteRepos concat <$> rerunConcurrentlyIfChanged verbosity - (newJobControlFromParStrat verbosity compiler parStrat (Just maxNumFetchJobs)) + (newJobControlFromParStrat verbosity parStrat (Just maxNumFetchJobs)) [ ( monitor , repoGroup' , do diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ae9d305615d..5abd26ccfe2 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -402,11 +402,11 @@ rebuildProjectConfig configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) pure (os, arch, toolchainCompiler) - (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton + (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ liftIO $ warn verbosity "The builddir option is not supported in project and config files. It will be ignored." - localPackages <- phaseReadLocalPackages compiler (projectConfig <> cliConfig) + localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) informAboutConfigFiles projectConfig @@ -434,11 +434,9 @@ rebuildProjectConfig -- NOTE: These are all packages mentioned in the project configuration. -- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`. phaseReadLocalPackages - :: Maybe Compiler - -> ProjectConfig + :: ProjectConfig -> Rebuild [PackageSpecifier UnresolvedSourcePackage] phaseReadLocalPackages - compiler projectConfig@ProjectConfig { projectConfigShared , projectConfigBuildOnly @@ -453,7 +451,6 @@ rebuildProjectConfig fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations From 5800c214fdcfffb9c25c7da2c99d9ff5f31a16c3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Mar 2025 15:21:45 +0800 Subject: [PATCH 018/122] feat(cabal-install): add build compiler option --- .../src/Distribution/Client/Config.hs | 4 ++++ .../Client/ProjectConfig/FieldGrammar.hs | 4 ++++ .../Client/ProjectConfig/Legacy.hs | 9 +++++++++ .../Distribution/Client/ProjectConfig/Lens.hs | 16 +++++++++++++++ .../Client/ProjectConfig/Types.hs | 4 ++++ .../src/Distribution/Client/Setup.hs | 20 ++++++++++++++++++- .../Distribution/Client/ProjectConfig.hs | 8 ++++++++ 7 files changed, 64 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index e213502fcf9..97acd7064de 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -575,6 +575,10 @@ instance Semigroup SavedConfig where combineMonoid savedConfigureExFlags configAllowOlder , configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = combine configBuildHcFlavor + , configBuildHcPath = combine configBuildHcPath + , configBuildHcPkg = combine configBuildHcPkg + , configBuildPackageDBs = lastNonEmpty configBuildPackageDBs } where combine = combine' savedConfigureExFlags diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 82357d81787..bbae09b7b9a 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs @@ -119,6 +119,10 @@ projectConfigToolchainFieldGrammar = <*> optionalFieldDefAla "with-compiler" (alaFlag FilePathNT) L.projectConfigHcPath mempty <*> optionalFieldDefAla "with-hc-pkg" (alaFlag FilePathNT) L.projectConfigHcPkg mempty <*> monoidalFieldAla "package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigPackageDBs + <*> optionalFieldDef "build-compiler" L.projectConfigBuildHcFlavor mempty + <*> optionalFieldDefAla "with-build-compiler" (alaFlag FilePathNT) L.projectConfigBuildHcPath mempty + <*> optionalFieldDefAla "with-build-hc-pkg" (alaFlag FilePathNT) L.projectConfigBuildHcPkg mempty + <*> monoidalFieldAla "build-package-dbs" (alaList' CommaFSep PackageDBNT) L.projectConfigBuildPackageDBs packageConfigFieldGrammar :: [String] -> ParsecFieldGrammar' PackageConfig packageConfigFieldGrammar knownPrograms = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index a5d6eb6fe18..18f8f6aed64 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -718,6 +718,7 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectConfigToolchain = ProjectConfigToolchain{..} projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ + projectConfigBuildPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigBuildPackageDBs_ ConfigFlags { configCommonFlags = commonFlags @@ -743,6 +744,10 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = projectConfigBuildPackageDBs_ } = configExFlags InstallFlags @@ -1021,6 +1026,10 @@ convertToLegacySharedConfig , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = fmap (fmap (fmap unsafeMakeSymbolicPath)) projectConfigBuildPackageDBs } installFlags = diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs index fdd90a7048e..9a3897f5432 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Lens.hs @@ -216,6 +216,22 @@ projectConfigPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] projectConfigPackageDBs f s = fmap (\x -> s{T.projectConfigPackageDBs = x}) (f (T.projectConfigPackageDBs s)) {-# INLINEABLE projectConfigPackageDBs #-} +projectConfigBuildHcFlavor :: Lens' ProjectConfigToolchain (Flag CompilerFlavor) +projectConfigBuildHcFlavor f s = fmap (\x -> s{T.projectConfigBuildHcFlavor = x}) (f (T.projectConfigBuildHcFlavor s)) +{-# INLINEABLE projectConfigBuildHcFlavor #-} + +projectConfigBuildHcPath :: Lens' ProjectConfigToolchain (Flag FilePath) +projectConfigBuildHcPath f s = fmap (\x -> s{T.projectConfigBuildHcPath = x}) (f (T.projectConfigBuildHcPath s)) +{-# INLINEABLE projectConfigBuildHcPath #-} + +projectConfigBuildHcPkg :: Lens' ProjectConfigToolchain (Flag FilePath) +projectConfigBuildHcPkg f s = fmap (\x -> s{T.projectConfigBuildHcPkg = x}) (f (T.projectConfigBuildHcPkg s)) +{-# INLINEABLE projectConfigBuildHcPkg #-} + +projectConfigBuildPackageDBs :: Lens' ProjectConfigToolchain [Maybe PackageDBCWD] +projectConfigBuildPackageDBs f s = fmap (\x -> s{T.projectConfigBuildPackageDBs = x}) (f (T.projectConfigBuildPackageDBs s)) +{-# INLINEABLE projectConfigBuildPackageDBs #-} + projectConfigHaddockIndex :: Lens' ProjectConfigShared (Flag PathTemplate) projectConfigHaddockIndex f s = fmap (\x -> s{T.projectConfigHaddockIndex = x}) (f (T.projectConfigHaddockIndex s)) {-# INLINEABLE projectConfigHaddockIndex #-} diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 21cbbaadf2e..0246680077b 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -244,6 +244,10 @@ data ProjectConfigToolchain = ProjectConfigToolchain , projectConfigHcPath :: Flag FilePath , projectConfigHcPkg :: Flag FilePath , projectConfigPackageDBs :: [Maybe PackageDBCWD] + , projectConfigBuildHcFlavor :: Flag CompilerFlavor + , projectConfigBuildHcPath :: Flag FilePath + , projectConfigBuildHcPkg :: Flag FilePath + , projectConfigBuildPackageDBs :: [Maybe PackageDBCWD] } deriving (Eq, Show, Generic) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 889113847bc..93de2bf1b45 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -163,7 +163,7 @@ import Distribution.ReadE ) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack) +import Distribution.Simple.Compiler (Compiler, CompilerFlavor (..), PackageDB, PackageDBStack) import Distribution.Simple.Configure ( computeEffectiveProfiling , configCompilerAuxEx @@ -923,6 +923,10 @@ data ConfigExFlags = ConfigExFlags , configAllowOlder :: Maybe AllowOlder , configWriteGhcEnvironmentFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor :: Flag CompilerFlavor + , configBuildHcPath :: Flag FilePath + , configBuildHcPkg :: Flag FilePath + , configBuildPackageDBs :: [Maybe PackageDB] } deriving (Eq, Show, Generic) @@ -1050,6 +1054,20 @@ configureExOptions _showOrParseArgs src = writeGhcEnvironmentFilesPolicyParser writeGhcEnvironmentFilesPolicyPrinter ) + , option + "W" + ["with-build-compiler", "with-build-hc"] + "give the path to the compiler for the build stage" + configBuildHcPath + (\v flags -> flags{configBuildHcPath = v}) + (reqArgFlag "PATH") + , option + "" + ["with-build-hc-pkg"] + "give the path to the package tool for the build stage" + configBuildHcPkg + (\v flags -> flags{configBuildHcPkg = v}) + (reqArgFlag "PATH") ] writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 5450b28e2f4..a177ef3e37e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -606,6 +606,10 @@ instance Arbitrary ProjectConfigToolchain where projectConfigHcPath <- arbitraryFlag arbitraryShortToken projectConfigHcPkg <- arbitraryFlag arbitraryShortToken projectConfigPackageDBs <- shortListOf 2 arbitrary + projectConfigBuildHcFlavor <- arbitrary + projectConfigBuildHcPath <- arbitraryFlag arbitraryShortToken + projectConfigBuildHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigBuildPackageDBs <- shortListOf 2 arbitrary return ProjectConfigToolchain{..} shrink ProjectConfigToolchain{..} = @@ -615,6 +619,10 @@ instance Arbitrary ProjectConfigToolchain where <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg <*> shrinker projectConfigPackageDBs + <*> shrinker projectConfigBuildHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigBuildHcPkg + <*> shrinker projectConfigBuildPackageDBs instance Arbitrary ProjectConfigShared where arbitrary = do From 33e995c13b750deba608f322419ccc4920bbdeb3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 21 Mar 2025 18:11:01 +0800 Subject: [PATCH 019/122] feat(cabal-install): all of it --- cabal-install/cabal-install.cabal | 1 + .../src/Distribution/Client/CmdExec.hs | 24 +- .../src/Distribution/Client/CmdGenBounds.hs | 1 - .../src/Distribution/Client/CmdHaddock.hs | 24 +- .../Distribution/Client/CmdHaddockProject.hs | 106 +-- .../src/Distribution/Client/CmdListBin.hs | 5 +- .../src/Distribution/Client/CmdPath.hs | 18 +- .../src/Distribution/Client/CmdRepl.hs | 20 +- .../src/Distribution/Client/InstallPlan.hs | 21 + .../Distribution/Client/ProjectBuilding.hs | 85 +-- .../Client/ProjectBuilding/UnpackedPackage.hs | 34 +- .../Client/ProjectOrchestration.hs | 137 ++-- .../Distribution/Client/ProjectPlanOutput.hs | 71 +- .../Distribution/Client/ProjectPlanning.hs | 604 ++++++++++-------- .../Client/ProjectPlanning/Stage.hs | 48 ++ .../Client/ProjectPlanning/Types.hs | 26 +- .../src/Distribution/Client/ScriptUtils.hs | 39 +- .../src/Distribution/Client/SetupWrapper.hs | 8 +- .../src/Distribution/Client/Toolchain.hs | 59 +- cabal-install/tests/IntegrationTests2.hs | 8 +- 20 files changed, 810 insertions(+), 529 deletions(-) create mode 100644 cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index e40c6273034..e21b063050f 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -193,6 +193,7 @@ library Distribution.Client.ProjectPlanOutput Distribution.Client.ProjectPlanning Distribution.Client.ProjectPlanning.SetupPolicy + Distribution.Client.ProjectPlanning.Stage Distribution.Client.ProjectPlanning.Types Distribution.Client.RebuildMonad Distribution.Client.Reconfigure diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index b649bbabde5..6d270fd7439 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -1,6 +1,9 @@ ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} -- | -- Module : Distribution.Client.Exec @@ -56,7 +59,8 @@ import Distribution.Client.ProjectPlanning ) import qualified Distribution.Client.ProjectPlanning as Planning import Distribution.Client.ProjectPlanning.Types - ( dataDirsEnvironmentForPlan + ( Toolchain (..) + , dataDirsEnvironmentForPlan ) import Distribution.Client.Setup ( GlobalFlags @@ -104,6 +108,7 @@ import Prelude () import qualified Data.Map as M import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.Stage execCommand :: CommandUI (NixStyleFlags ()) execCommand = @@ -152,6 +157,12 @@ execAction flags extraArgs globalFlags = do baseCtx (\plan -> return (plan, M.empty)) + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + -- We need the compiler and platform to set up the environment. + compilers = toolchainCompiler <$> toolchains + platforms = toolchainPlatform <$> toolchains + progdbs = toolchainProgramDb <$> toolchains + -- We use the build status below to decide what libraries to include in the -- compiler environment, but we don't want to actually build anything. So we -- pass mempty to indicate that nothing happened and we just want the current @@ -166,7 +177,9 @@ execAction flags extraArgs globalFlags = do -- Some dependencies may have executables. Let's put those on the PATH. let extraPaths = pathAdditions baseCtx buildCtx - pkgProgs = pkgConfigCompilerProgs (elaboratedShared buildCtx) + -- NOTE: only build-stage dependencies make sense here + pkgProgs = getStage progdbs Build + -- extraEnvVars = dataDirsEnvironmentForPlan (distDirLayout baseCtx) @@ -181,7 +194,8 @@ execAction flags extraArgs globalFlags = do -- point at the file. -- In case ghc is too old to support environment files, -- we pass the same info as arguments - let compiler = pkgConfigCompiler $ elaboratedShared buildCtx + -- FIXME + let compiler = getStage compilers Host envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler) case extraArgs of [] -> dieWithException verbosity SpecifyAnExecutable @@ -234,7 +248,9 @@ matchCompilerPath elaboratedShared program = programPath program `elem` (programPath <$> configuredCompilers) where - configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared + progdbs = toolchainProgramDb <$> pkgConfigToolchains elaboratedShared + -- FIXME + configuredCompilers = configuredPrograms (getStage progdbs Host) -- | Execute an action with a temporary .ghc.environment file reflecting the -- current environment. The action takes an environment containing the env diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 6e47fcd6a9c..b19161e3ac9 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -18,7 +18,6 @@ import Control.Monad (mapM_) import Distribution.Client.Errors import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets) -import Distribution.Client.ProjectPlanning.Types import Distribution.Client.Types.ConfiguredId (confInstId) import Distribution.Client.Utils hiding (pvpize) import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId) diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index f9be5763b3b..a3cc048e210 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -29,8 +30,12 @@ import Distribution.Client.ProjectConfig.Types , ProjectConfig (..) ) import Distribution.Client.ProjectOrchestration -import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types ( ElaboratedSharedConfig (..) + , Stage (..) + , Staged (..) + , Toolchain (..) + , getStage ) import Distribution.Client.Setup ( GlobalFlags @@ -160,6 +165,7 @@ haddockAction relFlags targetStrings globalFlags = do projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}} | otherwise = projCtx + absProjectConfig <- mkConfigAbsolute relProjectConfig let baseCtx = relBaseCtx{projectConfig = absProjectConfig} @@ -192,6 +198,9 @@ haddockAction relFlags targetStrings globalFlags = do printPlan verbosity baseCtx buildCtx + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + + -- TODO progs <- reconfigurePrograms verbosity @@ -200,14 +209,19 @@ haddockAction relFlags targetStrings globalFlags = do -- we need to insert 'haddockProgram' before we reconfigure it, -- otherwise 'set . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - . elaboratedShared - $ buildCtx + -- TODO + . toolchainProgramDb + $ getStage toolchains Host + + let toolchains' = Staged $ \case + Host -> (getStage toolchains' Host){toolchainProgramDb = progs} + Build -> getStage toolchains' Build + let buildCtx' = buildCtx { elaboratedShared = (elaboratedShared buildCtx) - { pkgConfigCompilerProgs = progs + { pkgConfigToolchains = toolchains' } } diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 9d1e589aa32..b864b73d7cf 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -39,7 +39,9 @@ import Distribution.Client.ProjectPlanning , TargetAction (..) ) import Distribution.Client.ProjectPlanning.Types - ( elabDistDirParams + ( Toolchain (..) + , elabDistDirParams + , getStage ) import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) @@ -71,18 +73,11 @@ import Distribution.Simple.Flag , pattern Flag , pattern NoFlag ) -import Distribution.Simple.Haddock (createHaddockIndex) + +-- import Distribution.Simple.Haddock (createHaddockIndex) import Distribution.Simple.InstallDirs ( toPathTemplate ) -import Distribution.Simple.Program.Builtin - ( haddockProgram - ) -import Distribution.Simple.Program.Db - ( addKnownProgram - , reconfigurePrograms - , requireProgramVersion - ) import Distribution.Simple.Setup ( HaddockFlags (..) , HaddockProjectFlags (..) @@ -103,8 +98,6 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnitId (unUnitId) -import Distribution.Types.Version (mkVersion) -import Distribution.Types.VersionRange (orLaterVersion) import Distribution.Verbosity as Verbosity ( normal ) @@ -170,24 +163,26 @@ haddockProjectAction flags _extraArgs globalFlags = do pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] pkgs = matchingPackages elaboratedPlan - progs <- - reconfigurePrograms - verbosity - (haddockProjectProgramPaths flags) - (haddockProjectProgramArgs flags) - -- we need to insert 'haddockProgram' before we reconfigure it, - -- otherwise 'set - . addKnownProgram haddockProgram - . pkgConfigCompilerProgs - $ sharedConfig - let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} - - _ <- - requireProgramVersion - verbosity - haddockProgram - (orLaterVersion (mkVersion [2, 26, 1])) - progs + -- TODO + -- progs <- + -- reconfigurePrograms + -- verbosity + -- (haddockProjectProgramPaths flags) + -- (haddockProjectProgramArgs flags) + -- -- we need to insert 'haddockProgram' before we reconfigure it, + -- -- otherwise 'set + -- . addKnownProgram haddockProgram + -- . pkgConfigCompilerProgs + -- $ sharedConfig + -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} + let sharedConfig' = sharedConfig + + -- _ <- + -- requireProgramVersion + -- verbosity + -- haddockProgram + -- (orLaterVersion (mkVersion [2, 26, 1])) + -- progs -- -- Build project; we need to build dependencies. @@ -302,10 +297,12 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> do let pkg_descr = elabPkgDescription package unitId = unUnitId (elabUnitId package) + compilers = toolchainCompiler <$> pkgConfigToolchains sharedConfig' + compiler = getStage compilers (elabStage package) packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - (pkgConfigCompiler sharedConfig') + compiler (elabUnitId package) -- TODO: use `InstallDirTemplates` docDir = packageDir "share" "doc" "html" @@ -325,7 +322,7 @@ haddockProjectAction flags _extraArgs globalFlags = do -- generate index, content, etc. -- - let (missingHaddocks, packageInfos') = partitionEithers packageInfos + let (missingHaddocks, _packageInfos') = partitionEithers packageInfos when (not (null missingHaddocks)) $ do warn verbosity "missing haddocks for some packages from the store" -- Show the package list if `-v1` is passed; it's usually a long list. @@ -334,28 +331,31 @@ haddockProjectAction flags _extraArgs globalFlags = do -- `documentation: True` in the global config). info verbosity (intercalate "\n" missingHaddocks) - let flags' = - flags - { haddockProjectDir = Flag outputDir - , haddockProjectInterfaces = - Flag - [ ( interfacePath - , Just url - , Just url - , visibility - ) - | (url, interfacePath, visibility) <- packageInfos' - ] - , haddockProjectUseUnicode = NoFlag - } - createHaddockIndex - verbosity - (pkgConfigCompilerProgs sharedConfig') - (pkgConfigCompiler sharedConfig') - (pkgConfigPlatform sharedConfig') - Nothing - flags' + warn verbosity "createHaddockIndex not implemented" where + -- let flags' = + -- flags + -- { haddockProjectDir = Flag outputDir + -- , haddockProjectInterfaces = + -- Flag + -- [ ( interfacePath + -- , Just url + -- , Just url + -- , visibility + -- ) + -- | (url, interfacePath, visibility) <- packageInfos' + -- ] + -- , haddockProjectUseUnicode = NoFlag + -- } + -- -- NOTE: this lives in Cabal + -- createHaddockIndex + -- verbosity + -- (toolchainProgramDb $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- (toolchainCompiler $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- (toolchainPlatform $ buildToolchain $ pkgConfigToolchains sharedConfig') + -- Nothing + -- flags' + -- build all packages with appropriate haddock flags commonFlags = haddockProjectCommonFlags flags diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 0dc78bcb4f3..8d358bc9802 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -48,7 +48,6 @@ import Distribution.Client.TargetProblem (TargetProblem (..)) import Distribution.Simple.BuildPaths (dllExtension, exeExtension) import Distribution.Simple.Command (CommandUI (..)) import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText) -import Distribution.System (Platform) import Distribution.Types.ComponentName (showComponentName) import Distribution.Types.UnitId (UnitId) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -204,8 +203,8 @@ listbinAction flags args globalFlags = do | s == selectedComponent -> [flib_file' s] _ -> [] - plat :: Platform - plat = pkgConfigPlatform elaboratedSharedConfig + Toolchain{toolchainPlatform = plat} = + getStage (pkgConfigToolchains elaboratedSharedConfig) (elabStage elab) -- here and in PlanOutput, -- use binDirectoryFor? diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index 99e1a7de5a5..b9bfa0a2451 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} -- | -- Module : Distribution.Client.CmdPath @@ -41,14 +42,12 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types (Toolchain (..)) import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.ScriptUtils import Distribution.Client.Setup ( yesNoOpt ) -import Distribution.Client.Toolchain - ( Toolchain (..) - ) import Distribution.Client.Utils.Json ( (.=) ) @@ -79,9 +78,11 @@ import Distribution.Simple.Program import Distribution.Simple.Utils ( die' , dieWithException + , warn , withOutputMarker , wrapText ) +import Distribution.Solver.Types.Stage import Distribution.Verbosity ( normal ) @@ -247,10 +248,13 @@ pathAction flags@NixStyleFlags{extraFlags = pathFlags'} cliTargetStrings globalF if not $ fromFlagOrDefault False (pathCompiler pathFlags) then pure Nothing else do - toolchain <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) - compilerProg <- requireCompilerProg verbosity (toolchainCompiler toolchain) - (configuredCompilerProg, _) <- requireProgram verbosity compilerProg (toolchainProgramDb toolchain) - pure $ Just $ mkCompilerInfo configuredCompilerProg (toolchainCompiler toolchain) + let projectRoot = distProjectRootDirectory (distDirLayout baseCtx) + toolchains <- runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (projectConfig baseCtx) + warn verbosity "WIP: Assuming host toolchain, result might be wrong" + let Toolchain{..} = getStage toolchains Host + compilerProg <- requireCompilerProg verbosity toolchainCompiler + (configuredCompilerProg, _) <- requireProgram verbosity compilerProg toolchainProgramDb + pure $ Just $ mkCompilerInfo configuredCompilerProg toolchainCompiler paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation baseCtx p diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 8e4b814d67e..8ebe1d44747 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -57,7 +57,8 @@ import Distribution.Client.ProjectPlanning , ElaboratedSharedConfig (..) ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies + ( Toolchain (..) + , elabOrderExeDependencies , showElaboratedInstallPlan ) import Distribution.Client.ScriptUtils @@ -184,6 +185,7 @@ import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag) import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Types +import Distribution.Solver.Types.Stage import System.Directory ( doesFileExist , getCurrentDirectory @@ -361,7 +363,9 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- especially in the no-project case. withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + -- TODO: This only makes sense for the build stage + let Toolchain{toolchainCompiler = compiler} = getStage (pkgConfigToolchains sharedConfig) Build + targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors let (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets @@ -380,12 +384,14 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- In addition, to avoid a *third* trip through the solver, we are -- replicating the second half of 'runProjectPreBuildPhase' by hand -- here. - (buildCtx, compiler, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ + (buildCtx, compiler, progdb, platform, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ \elaboratedPlan elaboratedShared' -> do let ProjectBaseContext{..} = baseCtx'' + -- TODO: This mightr not make sense + Toolchain{..} = getStage (pkgConfigToolchains elaboratedShared') Host -- Recalculate with updated project. - targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors + targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors let elaboratedPlan' = @@ -417,13 +423,11 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g , targetsMap = targets } - ElaboratedSharedConfig{pkgConfigCompiler = compiler, pkgConfigPlatform = platform} = elaboratedShared' - repl_flags = case originalComponent of Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci Nothing -> [] - return (buildCtx, compiler, platform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) + return (buildCtx, toolchainCompiler, toolchainProgramDb, toolchainPlatform, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) -- Multi Repl implementation see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for -- a high-level overview about how everything fits together. @@ -458,7 +462,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- HACK: Just combine together all env overrides, placing the most common things last -- ghc program with overridden PATH - (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} -- Find what the unit files are, and start a repl based on all the response diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index ee8cd15c709..f68d56c3d66 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -40,6 +40,7 @@ module Distribution.Client.InstallPlan , configureInstallPlan , remove , installed + , installedM , lookup , directDeps , revDirectDeps @@ -421,6 +422,26 @@ installed shouldBeInstalled installPlan = { planGraph = Graph.insert (Installed pkg) (planGraph plan) } +-- | Change a number of packages in the 'Configured' state to the 'Installed' +-- state. +-- +-- To preserve invariants, the package must have all of its dependencies +-- already installed too (that is 'PreExisting' or 'Installed'). +installedM + :: (IsUnit ipkg, IsUnit srcpkg, Monad m) + => (srcpkg -> m Bool) + -> GenericInstallPlan ipkg srcpkg + -> m (GenericInstallPlan ipkg srcpkg) +installedM shouldBeInstalled installPlan = do + s <- filterM shouldBeInstalled [pkg | Configured pkg <- reverseTopologicalOrder installPlan] + return $ foldl markInstalled installPlan s + where + markInstalled plan pkg = + assert (all isInstalled (directDeps plan (nodeKey pkg))) $ + plan + { planGraph = Graph.insert (Installed pkg) (planGraph plan) + } + -- | Lookup a package in the plan. lookup :: (IsUnit ipkg, IsUnit srcpkg) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index bd1f3d4ebf4..222edd55522 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -71,7 +72,6 @@ import Distribution.Client.Types hiding import Distribution.Package import Distribution.Simple.Compiler -import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import Distribution.Compat.Graph (IsNode (..)) @@ -342,10 +342,7 @@ rebuildTargets distDirLayout@DistDirLayout{..} storeDirLayout installPlan - sharedPackageConfig@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + sharedPackageConfig pkgsBuildStatus buildSettings@BuildTimeSettings { buildSettingNumJobs @@ -365,7 +362,7 @@ rebuildTargets createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory createDirectoryIfMissingVerbose verbosity True distTempDirectory - traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + createPackageDBsIfMissing -- Concurrency control: create the job controller and concurrency limits -- for downloading, building and installing. @@ -409,19 +406,52 @@ rebuildTargets projectConfigWithBuilderRepoContext verbosity buildSettings - packageDBsToUse = - -- all the package dbs we may need to create - (Set.toList . Set.fromList) - [ pkgdb - | InstallPlan.Configured elab <- InstallPlan.toList installPlan - , pkgdb <- - concat - [ elabBuildPackageDBStack elab - , elabRegisterPackageDBStack elab - , elabSetupPackageDBStack elab - ] - ] + createPackageDBsIfMissing :: IO () + createPackageDBsIfMissing = + for_ (InstallPlan.toList installPlan) $ \case + InstallPlan.Configured elab -> do + let pkgdbs = + (Set.toList . Set.fromList) $ + concat + [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab + ] + for_ pkgdbs $ \case + SpecificPackageDB dbPath -> do + exists <- Cabal.doesPackageDBExist dbPath + let Toolchain{toolchainCompiler, toolchainProgramDb} = + getStage (pkgConfigToolchains sharedPackageConfig) (elabStage elab) + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity toolchainCompiler toolchainProgramDb False dbPath + _ -> pure () + _ -> pure () + + -- createPackageDBIfMissing _ _ _ _ = return () + + -- -- all the package dbs we may need to create + -- (Set.toList . Set.fromList) + -- [ pkgdb + -- | InstallPlan.Configured elab <- InstallPlan.toList installPlan + -- , pkgdb <- + -- concat + -- [ elabBuildPackageDBStack elab + -- , elabRegisterPackageDBStack elab + -- , elabSetupPackageDBStack elab + -- ] + -- ] + -- createPackageDBIfMissing + -- verbosity + -- compiler + -- progdb + -- (SpecificPackageDB dbPath) = do + -- exists <- Cabal.doesPackageDBExist dbPath + -- unless exists $ do + -- createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + -- Cabal.createPackageDB verbosity compiler progdb False dbPath + -- createPackageDBIfMissing _ _ _ _ = return () offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where @@ -457,25 +487,6 @@ rebuildTargets isRemote (RemoteSourceRepoPackage _ _) = True isRemote _ = False --- | Create a package DB if it does not currently exist. Note that this action --- is /not/ safe to run concurrently. -createPackageDBIfMissing - :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBCWD - -> IO () -createPackageDBIfMissing - verbosity - compiler - progdb - (SpecificPackageDB dbPath) = do - exists <- Cabal.doesPackageDBExist dbPath - unless exists $ do - createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - Cabal.createPackageDB verbosity compiler progdb False dbPath -createPackageDBIfMissing _ _ _ _ = return () - -- | Given all the context and resources, (re)build an individual package. rebuildTarget :: Verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 4bbc11c90ed..3d9c1dfea60 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -88,11 +88,11 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.Setup as Cabal + import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Simple.Utils -import Distribution.System (Platform (..)) import Distribution.Utils.Path hiding ( (<.>) , () @@ -116,6 +116,7 @@ import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.System (Platform (..)) -- | Each unpacked package is processed in the following phases: -- @@ -176,10 +177,7 @@ buildAndRegisterUnpackedPackage buildTimeSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingKeepTempFiles} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir @@ -221,8 +219,8 @@ buildAndRegisterUnpackedPackage criticalSection registerLock $ Cabal.registerPackage verbosity - compiler - progdb + toolchainCompiler + toolchainProgramDb Nothing (coercePackageDBStack pkgDBStack) ipkg @@ -255,6 +253,9 @@ buildAndRegisterUnpackedPackage where uid = installedUnitId rpkg + Toolchain{toolchainCompiler, toolchainProgramDb} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + comp_par_strat = case maybe_semaphore of Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) _ -> Cabal.NoFlag @@ -450,7 +451,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} + pkgshared plan rpkg@(ReadyPackage pkg) buildStatus @@ -597,6 +598,9 @@ buildInplaceUnpackedPackage where dparams = elabDistDirParams pkgshared pkg + Toolchain{toolchainPlatform = Platform _ os} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams whenReConfigure action = case buildStatus of @@ -653,10 +657,7 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir @@ -708,7 +709,7 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout compiler] + let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout toolchainCompiler] assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister @@ -724,7 +725,7 @@ buildAndInstallUnpackedPackage newStoreEntry verbosity storeDirLayout - compiler + toolchainCompiler uid (copyPkgFiles verbosity pkgshared pkg runCopy) registerPkg @@ -762,6 +763,9 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg + Toolchain{toolchainCompiler, toolchainPlatform} = + getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component @@ -786,7 +790,7 @@ buildAndInstallUnpackedPackage mlogFile = case buildSettingLogFile of Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid) initLogFile :: IO () initLogFile = diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 8f6f84da5e3..4c3e65aa4ea 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -135,12 +135,9 @@ import Distribution.Client.TargetSelector , reportTargetSelectorProblems ) import Distribution.Client.Types - ( DocsResult (..) - , GenericReadyPackage (..) - , PackageLocation (..) + ( GenericReadyPackage (..) , PackageSpecifier (..) , SourcePackageDb (..) - , TestsResult (..) , UnresolvedSourcePackage , WriteGhcEnvironmentFilesPolicy (..) ) @@ -149,17 +146,8 @@ import Distribution.Solver.Types.PackageIndex ) import Distribution.Solver.Types.SourcePackage (SourcePackage (..)) -import Distribution.Client.BuildReports.Anonymous (cabalInstallID) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeLocal - ) - import Distribution.Client.HttpUtils import Distribution.Client.Setup hiding (packageName) -import Distribution.Compiler - ( CompilerFlavor (GHC) - ) import Distribution.Types.ComponentName ( componentNameString ) @@ -184,9 +172,6 @@ import Distribution.Package import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Compiler ( OptimisationLevel (..) - , compilerCompatVersion - , compilerId - , compilerInfo , showCompilerId ) import Distribution.Simple.Configure (computeEffectiveProfiling) @@ -209,9 +194,6 @@ import Distribution.Simple.Utils , ordNub , warn ) -import Distribution.System - ( Platform (Platform) - ) import Distribution.Types.Flag ( FlagAssignment , diffFlagAssignment @@ -222,9 +204,6 @@ import Distribution.Utils.NubList ) import Distribution.Utils.Path (makeSymbolicPath) import Distribution.Verbosity -import Distribution.Version - ( mkVersion - ) #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) @@ -488,7 +467,7 @@ runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ runProjectPostBuildPhase verbosity ProjectBaseContext{..} - bc@ProjectBuildContext{..} + ProjectBuildContext{..} buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: @@ -517,21 +496,19 @@ runProjectPostBuildPhase writeGhcEnvFilesPolicy of AlwaysWriteGhcEnvironmentFiles -> True NeverWriteGhcEnvironmentFiles -> False - WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> - let compiler = pkgConfigCompiler elaboratedShared - ghcCompatVersion = compilerCompatVersion GHC compiler - in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion - + -- FIXME: whatever + WriteGhcEnvironmentFilesOnlyForGhc844AndNewer -> True when shouldWriteGhcEnvironment $ void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout) + Host elaboratedPlanOriginal elaboratedShared postBuildStatus -- Write the build reports - writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes + -- writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes -- Finally if there were any build failures then report them and throw -- an exception to terminate the program @@ -1181,7 +1158,8 @@ printPlan showConfigureFlags :: ElaboratedConfiguredPackage -> String showConfigureFlags elab = - let commonFlags = + let Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains elaboratedShared) (elabStage elab) + commonFlags = setupHsCommonFlags verbosity Nothing -- omit working directory @@ -1220,7 +1198,7 @@ printPlan in -- Not necessary to "escape" it, it's just for user output unwords . ("" :) $ commandShowOptions - (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared)) + (Setup.configureCommand toolchainProgramDb) partialConfigureFlags showBuildStatus :: BuildStatus -> String @@ -1252,7 +1230,8 @@ printPlan showBuildProfile = "Build profile: " ++ unwords - [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared + [ "-w " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Host) + , "-W " ++ (showCompilerId . toolchainCompiler $ getStage (pkgConfigToolchains elaboratedShared) Build) , "-O" ++ ( case globalOptimization <> localOptimization of -- if local is not set, read global Setup.Flag NoOptimisation -> "0" @@ -1263,53 +1242,53 @@ printPlan ] ++ "\n" -writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () -writeBuildReports settings buildContext plan buildOutcomes = do - let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext - comp = pkgConfigCompiler . elaboratedShared $ buildContext - getRepo (RepoTarballPackage r _ _) = Just r - getRepo _ = Nothing - fromPlanPackage (InstallPlan.Configured pkg) (Just result) = - let installOutcome = case result of - Left bf -> case buildFailureReason bf of - GracefulFailure _ -> BuildReports.PlanningFailed - DependentFailed p -> BuildReports.DependencyFailed p - DownloadFailed _ -> BuildReports.DownloadFailed - UnpackFailed _ -> BuildReports.UnpackFailed - ConfigureFailed _ -> BuildReports.ConfigureFailed - BuildFailed _ -> BuildReports.BuildFailed - TestsFailed _ -> BuildReports.TestsFailed - InstallFailed _ -> BuildReports.InstallFailed - ReplFailed _ -> BuildReports.InstallOk - HaddocksFailed _ -> BuildReports.InstallOk - BenchFailed _ -> BuildReports.InstallOk - Right _br -> BuildReports.InstallOk - - docsOutcome = case result of - Left bf -> case buildFailureReason bf of - HaddocksFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultDocs br of - DocsNotTried -> BuildReports.NotTried - DocsFailed -> BuildReports.Failed - DocsOk -> BuildReports.Ok - - testsOutcome = case result of - Left bf -> case buildFailureReason bf of - TestsFailed _ -> BuildReports.Failed - _ -> BuildReports.NotTried - Right br -> case buildResultTests br of - TestsNotTried -> BuildReports.NotTried - TestsOk -> BuildReports.Ok - in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? - fromPlanPackage _ _ = Nothing - buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan - - BuildReports.storeLocal - (compilerInfo comp) - (buildSettingSummaryFile settings) - buildReports - plat +-- writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO () +-- writeBuildReports settings buildContext plan buildOutcomes = do +-- let plat@(Platform arch os) = pkgConfigPlatform . elaboratedShared $ buildContext +-- comp = pkgConfigCompiler . elaboratedShared $ buildContext +-- getRepo (RepoTarballPackage r _ _) = Just r +-- getRepo _ = Nothing +-- fromPlanPackage (InstallPlan.Configured pkg) (Just result) = +-- let installOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- GracefulFailure _ -> BuildReports.PlanningFailed +-- DependentFailed p -> BuildReports.DependencyFailed p +-- DownloadFailed _ -> BuildReports.DownloadFailed +-- UnpackFailed _ -> BuildReports.UnpackFailed +-- ConfigureFailed _ -> BuildReports.ConfigureFailed +-- BuildFailed _ -> BuildReports.BuildFailed +-- TestsFailed _ -> BuildReports.TestsFailed +-- InstallFailed _ -> BuildReports.InstallFailed +-- ReplFailed _ -> BuildReports.InstallOk +-- HaddocksFailed _ -> BuildReports.InstallOk +-- BenchFailed _ -> BuildReports.InstallOk +-- Right _br -> BuildReports.InstallOk + +-- docsOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- HaddocksFailed _ -> BuildReports.Failed +-- _ -> BuildReports.NotTried +-- Right br -> case buildResultDocs br of +-- DocsNotTried -> BuildReports.NotTried +-- DocsFailed -> BuildReports.Failed +-- DocsOk -> BuildReports.Ok + +-- testsOutcome = case result of +-- Left bf -> case buildFailureReason bf of +-- TestsFailed _ -> BuildReports.Failed +-- _ -> BuildReports.NotTried +-- Right br -> case buildResultTests br of +-- TestsNotTried -> BuildReports.NotTried +-- TestsOk -> BuildReports.Ok +-- in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? +-- fromPlanPackage _ _ = Nothing +-- buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan + +-- BuildReports.storeLocal +-- (compilerInfo comp) +-- (buildSettingSummaryFile settings) +-- buildReports +-- plat -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1 -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle. diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index a4ce230d984..c1ab2473d94 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -32,6 +32,7 @@ import qualified Distribution.Client.Utils.Json as J import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps +import qualified Distribution.Solver.Types.Stage as Stage import qualified Distribution.Compat.Binary as Binary import Distribution.Compat.Graph (Graph, Node) @@ -104,20 +105,26 @@ encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedCo encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- TODO: [nice to have] include all of the sharedPackageConfig and all of -- the parts of the elaboratedInstallPlan - J.object + J.object $ [ "cabal-version" J..= jdisplay cabalInstallVersion , "cabal-lib-version" J..= jdisplay cabalVersion - , "compiler-id" - J..= (J.String . showCompilerId . pkgConfigCompiler) - elaboratedSharedConfig - , "compiler-abi" J..= jdisplay (compilerAbiTag (pkgConfigCompiler elaboratedSharedConfig)) - , "os" J..= jdisplay os - , "arch" J..= jdisplay arch - , "install-plan" J..= installPlanToJ elaboratedInstallPlan ] + ++ toolchainJ Host + ++ toolchainJ Build + ++ ["install-plan" J..= installPlanToJ elaboratedInstallPlan] where - plat :: Platform - plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig + toolchains = pkgConfigToolchains elaboratedSharedConfig + + toolchainJ stage = + [ prefixed "compiler-id" J..= J.String (showCompilerId toolchainCompiler) + , prefixed "arch" J..= (jdisplay arch) + , prefixed "os" J..= (jdisplay os) + ] + where + Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} = Stage.getStage toolchains stage + prefixed s = case stage of + Stage.Build -> "build-" ++ s + Stage.Host -> s installPlanToJ :: ElaboratedInstallPlan -> [J.Value] installPlanToJ = map planPackageToJ . InstallPlan.toList @@ -158,6 +165,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = else "configured" ) , "id" J..= (jdisplay . installedUnitId) elab + , "stage" J..= jdisplay (elabStage elab) , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab , "flags" @@ -206,6 +214,9 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] ++ bin_file (compSolverName comp) where + Toolchain{toolchainPlatform = plat} = + Stage.getStage toolchains (elabStage elab) + -- \| Only add build-info file location if the Setup.hs CLI -- is recent enough to be able to generate build info files. -- Otherwise, write 'null'. @@ -804,11 +815,16 @@ createPackageEnvironmentAndArgs elaboratedPlan elaboratedShared buildStatus - | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC = + | buildCompiler /= hostCompiler = + do + warn verbosity "package environment configuration is not supported for cross-compilation; commands that need the current project's package database are likely to fail" + return ([], []) + | compilerFlavor hostCompiler == GHC = do envFileM <- writePlanGhcEnvironment path + Host elaboratedPlan elaboratedShared buildStatus @@ -821,43 +837,50 @@ createPackageEnvironmentAndArgs do warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail" return ([], []) + where + compilers = toolchainCompiler <$> pkgConfigToolchains elaboratedShared + buildCompiler = getStage compilers Build + hostCompiler = getStage compilers Host -- Writing .ghc.environment files -- writePlanGhcEnvironment :: FilePath + -> Stage -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> PostBuildProjectStatus -> IO (Maybe FilePath) writePlanGhcEnvironment path + stage elaboratedInstallPlan - ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } - postBuildStatus - | compilerFlavor compiler == GHC - , supportsPkgEnvFiles (getImplInfo compiler) = - -- TODO: check ghcjs compat + elaboratedSharedConfig + postBuildStatus = + if (compilerFlavor toolchainCompiler == GHC && supportsPkgEnvFiles (getImplInfo toolchainCompiler)) + then -- TODO: check ghcjs compat + fmap Just $ writeGhcEnvironmentFile path - platform - (compilerVersion compiler) + toolchainPlatform + (compilerVersion toolchainCompiler) ( renderGhcEnvironmentFile path - elaboratedInstallPlan + stagePlan postBuildStatus ) + else return Nothing + where + Toolchain{..} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage + -- TODO + stagePlan = InstallPlan.remove {- (\pkg -> undefined pkg /= Host) -} (const False) elaboratedInstallPlan + -- TODO: [required eventually] support for writing user-wide package -- environments, e.g. like a global project, but we would not put the -- env file in the home dir, rather it lives under ~/.ghc/ -writePlanGhcEnvironment _ _ _ _ = return Nothing - renderGhcEnvironmentFile :: FilePath -> ElaboratedInstallPlan diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 5abd26ccfe2..92e7ddf04af 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -42,6 +42,10 @@ module Distribution.Client.ProjectPlanning , ElaboratedReadyPackage , BuildStyle (..) , CabalFileText + , elabOrderLibDependencies + , elabOrderExeDependencies + , elabLibDependencies + , elabExeDependencies -- * Reading the project configuration -- $readingTheProjectConfiguration @@ -69,7 +73,7 @@ module Distribution.Client.ProjectPlanning -- * Utils required for building , pkgHasEphemeralBuildTargets , elabBuildTargetWholeComponents - , configureCompiler + , configureToolchains -- * Setup.hs CLI flags for building , setupHsScriptOptions @@ -126,7 +130,6 @@ import Distribution.Client.ProjectConfig.Types (defaultProjectFileParser) import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy ( NonSetupLibDepSolverPlanPackage (..) - , mkDefaultSetupDeps , packageSetupScriptSpecVersion , packageSetupScriptStyle ) @@ -138,7 +141,7 @@ import Distribution.Client.Store import Distribution.Client.Targets (userToPackageConstraint) import Distribution.Client.Toolchain import Distribution.Client.Types -import Distribution.Client.Utils (concatMapM, incVersion) +import Distribution.Client.Utils (concatMapM) import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.IndexUtils as IndexUtils @@ -164,7 +167,6 @@ import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage -import qualified Distribution.Solver.Types.Stage as Stage import Distribution.ModuleName import Distribution.Package @@ -398,9 +400,10 @@ rebuildProjectConfig let fetchCompiler = do -- have to create the cache directory before configuring the compiler liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} <- - configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - pure (os, arch, toolchainCompiler) + toolchains <- configureToolchains verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + -- The project configuration is always done with the host compiler + let Toolchain{toolchainCompiler = compiler, toolchainPlatform = Platform arch os} = getStage toolchains Host + return (os, arch, compiler) (projectConfig, _compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $ @@ -496,12 +499,12 @@ rebuildProjectConfig $ projectConfigProvenance projectConfig ] -configureCompiler +configureToolchains :: Verbosity -> DistDirLayout -> ProjectConfig - -> Rebuild Toolchain -configureCompiler + -> Rebuild Toolchains +configureToolchains verbosity DistDirLayout { distProjectCacheFile @@ -509,7 +512,17 @@ configureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared - { projectConfigToolchain + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + , projectConfigBuildHcFlavor + , projectConfigBuildHcPath + , projectConfigBuildHcPkg + , projectConfigBuildPackageDBs + } , projectConfigProgPathExtra } , projectConfigLocalPackages = @@ -518,17 +531,18 @@ configureCompiler , packageConfigProgramPathExtra } } = do - let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" + let fileMonitorBuildCompiler = newFileMonitor $ distProjectCacheFile "build-compiler" + fileMonitorHostCompiler = newFileMonitor $ distProjectCacheFile "host-compiler" progsearchpath <- liftIO $ getSystemSearchPath - (toolchainCompiler, toolchainPlatform, tempProgDb) <- + (buildHc, buildPlat, buildHcProgDb) <- rerunIfChanged verbosity - fileMonitorCompiler - ( hcFlavor - , hcPath - , hcPkg + fileMonitorBuildCompiler + ( buildHcFlavor + , buildHcPath + , buildHcPkg , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -545,8 +559,44 @@ configureCompiler result@(_, _, progdb') <- liftIO $ Cabal.configCompiler - hcFlavor - hcPath + buildHcFlavor + buildHcPath + progdb + verbosity + -- Note that we added the user-supplied program locations and args + -- for /all/ programs, not just those for the compiler prog and + -- compiler-related utils. In principle we don't know which programs + -- the compiler will configure (and it does vary between compilers). + -- We do know however that the compiler will only configure the + -- programs it cares about, and those are the ones we monitor here. + monitorFiles (programsMonitorFiles progdb') + return result + + (hostHc, hostPlat, hostHcProgDb) <- + rerunIfChanged + verbosity + fileMonitorHostCompiler + ( hostHcFlavor + , hostHcPath + , hostHcPkg + , progsearchpath + , packageConfigProgramPaths + , packageConfigProgramPathExtra + ) + $ do + liftIO $ info verbosity "Compiler settings changed, reconfiguring..." + progdb <- + liftIO $ + -- Add paths in the global config + prependProgramSearchPath verbosity (fromNubList projectConfigProgPathExtra) [] defaultProgramDb + -- Add paths in the local config + >>= prependProgramSearchPath verbosity (fromNubList packageConfigProgramPathExtra) [] + >>= pure . userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + result@(_, _, progdb') <- + liftIO $ + Cabal.configCompiler + hostHcFlavor + hostHcPath progdb verbosity -- Note that we added the user-supplied program locations and args @@ -562,13 +612,32 @@ configureCompiler -- auxiliary unconfigured programs to the ProgramDb (e.g. hc-pkg, haddock, ar, ld...). -- -- See Note [Caching the result of configuring the compiler] - toolchainProgramDb <- liftIO $ Cabal.configCompilerProgDb verbosity toolchainCompiler tempProgDb hcPkg - let toolchainPackageDBs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigToolchain) - return Toolchain{..} + finalBuildProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity buildHc buildHcProgDb buildHcPkg + finalHostProgDb <- liftIO $ Cabal.configCompilerProgDb verbosity hostHc hostHcProgDb hostHcPkg + + return $ Staged $ \case + Build -> + Toolchain + { toolchainCompiler = buildHc + , toolchainPlatform = buildPlat + , toolchainProgramDb = finalBuildProgDb + , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigBuildPackageDBs + } + Host -> + Toolchain + { toolchainCompiler = hostHc + , toolchainPlatform = hostPlat + , toolchainProgramDb = finalHostProgDb + , toolchainPackageDBs = Cabal.interpretPackageDbFlags False projectConfigPackageDBs + } where - hcFlavor = flagToMaybe (projectConfigHcFlavor projectConfigToolchain) - hcPath = flagToMaybe (projectConfigHcPath projectConfigToolchain) - hcPkg = flagToMaybe (projectConfigHcPkg projectConfigToolchain) + hostHcFlavor = flagToMaybe projectConfigHcFlavor + hostHcPath = flagToMaybe projectConfigHcPath + hostHcPkg = flagToMaybe projectConfigHcPkg + -- Use the host compiler if a separate build compiler is not specified + buildHcFlavor = flagToMaybe projectConfigBuildHcFlavor <|> flagToMaybe projectConfigHcFlavor + buildHcPath = flagToMaybe projectConfigBuildHcPath <|> flagToMaybe projectConfigHcPath + buildHcPkg = flagToMaybe projectConfigBuildHcPkg <|> flagToMaybe projectConfigHcPkg {- Note [Caching the result of configuring the compiler] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -673,27 +742,30 @@ rebuildInstallPlan , progsearchpath ) $ do - toolchain <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig toolchain - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + toolchains <- phaseConfigureToolchains projectConfig + phaseConfigurePrograms projectConfig toolchains + (solverPlan, _, pkgConfigDBs, totalIndexState, activeRepos) <- phaseRunSolver projectConfig - toolchain + toolchains localPackages (fromMaybe mempty mbInstalledPackages) - ( elaboratedPlan - , elaboratedShared - ) <- + + (elaboratedPlan, elaboratedShared) <- phaseElaboratePlan projectConfig - toolchain - pkgConfigDB + toolchains + pkgConfigDBs solverPlan localPackages phaseMaintainPlanOutputs elaboratedPlan elaboratedShared return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + -- \| Given the 'InstalledPackageIndex' for a nix-style package store, and an + -- 'ElaboratedInstallPlan', replace configured source packages by installed + -- packages from the store whenever they exist. + -- -- The improved plan changes each time we install something, whereas -- the underlying elaborated plan only changes when input config -- changes, so it's worth caching them separately. @@ -714,10 +786,16 @@ rebuildInstallPlan -- This is moderately expensive and doesn't change that often so we cache -- it independently. -- - phaseConfigureCompiler + phaseConfigureToolchains :: ProjectConfig - -> Rebuild Toolchain - phaseConfigureCompiler = configureCompiler verbosity distDirLayout + -> Rebuild Toolchains + phaseConfigureToolchains projectConfig = do + toolchains <- configureToolchains verbosity distDirLayout projectConfig + liftIO $ do + putStrLn "Toolchains:" + for_ stages $ \s -> + print $ Disp.hsep [Disp.text "-" <+> pretty s <+> Disp.text "compiler" <+> pretty (compilerId (toolchainCompiler (getStage toolchains s)))] + return toolchains -- Configuring other programs. -- @@ -733,17 +811,18 @@ rebuildInstallPlan -- phaseConfigurePrograms :: ProjectConfig - -> Toolchain + -> Toolchains -> Rebuild () - phaseConfigurePrograms projectConfig toolchain = do + phaseConfigurePrograms projectConfig toolchains = do -- Users are allowed to specify program locations independently for -- each package (e.g. to use a particular version of a pre-processor -- for some packages). However they cannot do this for the compiler -- itself as that's just not going to work. So we check for this. - liftIO $ - checkBadPerPackageCompilerPaths - (configuredPrograms (toolchainProgramDb toolchain)) - (getMapMappend (projectConfigSpecificPackage projectConfig)) + for_ toolchains $ \Toolchain{toolchainProgramDb} -> + liftIO $ + checkBadPerPackageCompilerPaths + (configuredPrograms toolchainProgramDb) + (getMapMappend (projectConfigSpecificPackage projectConfig)) -- TODO: [required eventually] find/configure other programs that the -- user specifies. @@ -756,48 +835,42 @@ rebuildInstallPlan -- phaseRunSolver :: ProjectConfig - -> Toolchain + -> Toolchains -> [PackageSpecifier UnresolvedSourcePackage] -> InstalledPackageIndex - -> Rebuild (SolverInstallPlan, Maybe PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) + -> Rebuild + ( SolverInstallPlan + , Staged InstalledPackageIndex + , Staged (Maybe PkgConfigDb) + , IndexUtils.TotalIndexState + , IndexUtils.ActiveRepos + ) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared , projectConfigBuildOnly } - Toolchain - { toolchainCompiler = compiler - , toolchainPlatform = platform - , toolchainProgramDb = progdb - } - -- \^ The compiler and platform to use for the solver. + toolchains localPackages - installedPackages = + _installedPackages = rerunIfChanged verbosity fileMonitorSolverPlan ( solverSettings , localPackages , localPackagesEnabledStanzas - , compiler - , platform - , programDbSignature progdb + , toolchains ) $ do - installedPkgIndex <- - getInstalledPackages - verbosity - compiler - progdb - platform - corePackageDbs (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx (solverSettingIndexState solverSettings) (solverSettingActiveRepos solverSettings) - pkgConfigDB <- getPkgConfigDb verbosity progdb + + ipis <- for toolchains (\t -> getInstalledPackages verbosity t corePackageDbs) + pkgConfigDbs <- for toolchains (getPkgConfigDb verbosity . toolchainProgramDb) -- TODO: [code cleanup] it'd be better if the Compiler contained the -- ConfiguredPrograms that it needs, rather than relying on the progdb @@ -810,20 +883,26 @@ rebuildInstallPlan foldProgress logMsg (pure . Left) (pure . Right) $ planPackages verbosity - compiler - platform solverSettings - (installedPackages <> installedPkgIndex) + compilerAndPlatform + pkgConfigDbs + ipis sourcePkgDb - pkgConfigDB localPackages localPackagesEnabledStanzas case planOrError of Left msg -> do - reportPlanningFailure projectConfig compiler platform localPackages + -- TODO + for_ toolchains $ \(Toolchain{toolchainCompiler, toolchainPlatform}) -> + reportPlanningFailure projectConfig toolchainCompiler toolchainPlatform localPackages dieWithException verbosity $ PhaseRunSolverErr msg - Right plan -> return (plan, pkgConfigDB, tis, ar) + Right plan -> return (plan, ipis, pkgConfigDbs, tis, ar) where + compilerAndPlatform = + fmap + (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform)) + toolchains + corePackageDbs :: PackageDBStackCWD corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain projectConfigShared)) @@ -875,8 +954,8 @@ rebuildInstallPlan -- phaseElaboratePlan :: ProjectConfig - -> Toolchain - -> Maybe PkgConfigDb + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Rebuild @@ -891,7 +970,7 @@ rebuildInstallPlan , projectConfigSpecificPackage , projectConfigBuildOnly } - Toolchain{..} + toolchains pkgConfigDB solverPlan localPackages = do @@ -904,15 +983,17 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - defaultInstallDirs <- liftIO $ userInstallDirTemplates toolchainCompiler - let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + installDirs <- + for toolchains $ \t -> do + defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t) + return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) + (elaboratedPlan, elaboratedShared) <- - liftIO . runLogProgress verbosity $ - elaborateInstallPlan + liftIO + . runLogProgress verbosity + $ elaborateInstallPlan verbosity - toolchainPlatform - toolchainCompiler - toolchainProgramDb + toolchains pkgConfigDB distDirLayout cabalStoreDirLayout @@ -971,11 +1052,7 @@ rebuildInstallPlan -> Rebuild ElaboratedInstallPlan phaseImprovePlan elaboratedPlan elaboratedShared = do liftIO $ debug verbosity "Improving the install plan..." - storePkgIdSet <- getStoreEntries cabalStoreDirLayout compiler - let improvedPlan = - improveInstallPlanWithInstalledPackages - storePkgIdSet - elaboratedPlan + improvedPlan <- liftIO $ InstallPlan.installedM canBeImproved elaboratedPlan liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) -- TODO: [nice to have] having checked which packages from the store -- we're using, it may be sensible to sanity check those packages @@ -983,7 +1060,9 @@ rebuildInstallPlan -- matches up as expected, e.g. no dangling deps, files deleted. return improvedPlan where - compiler = pkgConfigCompiler elaboratedShared + canBeImproved pkg = do + let Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains elaboratedShared) (elabStage pkg) + doesStoreEntryExist cabalStoreDirLayout toolchainCompiler (installedUnitId pkg) -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. @@ -1038,28 +1117,27 @@ programsMonitorFiles progdb = getInstalledPackages :: Verbosity - -> Compiler - -> ProgramDb - -> Platform + -> Toolchain -> PackageDBStackCWD -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory +getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} packagedbs = do + monitorFiles + . map monitorFileOrDirectory =<< liftIO ( IndexUtils.getInstalledPackagesMonitorFiles verbosity - compiler + toolchainCompiler Nothing -- use ambient working directory (coercePackageDBStack packagedbs) - progdb - platform + toolchainProgramDb + toolchainPlatform ) liftIO $ IndexUtils.getInstalledPackages verbosity - compiler + toolchainCompiler packagedbs - progdb + toolchainProgramDb {- --TODO: [nice to have] use this but for sanity / consistency checking @@ -1087,9 +1165,10 @@ getSourcePackages getSourcePackages verbosity withRepoCtx idxState activeRepos = do (sourcePkgDbWithTIS, repos) <- liftIO $ - withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos - return (sourcePkgDbWithTIS, repoContextRepos repoctx) + withRepoCtx $ + \repoctx -> do + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos + return (sourcePkgDbWithTIS, repoContextRepos repoctx) traverse_ needIfExists . IndexUtils.getSourcePackagesMonitorFiles @@ -1212,8 +1291,8 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- the hashes for the packages -- hashesFromRepoMetadata <- - Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions - fmap (Map.fromList . concat) $ + Sec.uncheckClientErrors $ + fmap (Map.fromList . concat) $ -- TODO: [code cleanup] wrap in our own exceptions sequence -- Reading the repo index is expensive so we group the packages by repo [ repoContextWithSecureRepo repoctx repo $ \secureRepo -> @@ -1291,30 +1370,24 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do planPackages :: Verbosity - -> Compiler - -> Platform -> SolverSettings - -> InstalledPackageIndex + -> Staged (CompilerInfo, Platform) + -> Staged (Maybe PkgConfigDb) + -> Staged InstalledPackageIndex -> SourcePackageDb - -> Maybe PkgConfigDb -> [PackageSpecifier UnresolvedSourcePackage] -> Map PackageName (Map OptionalStanza Bool) -> Progress String String SolverInstallPlan planPackages verbosity - comp - platform SolverSettings{..} - installedPkgIndex - sourcePkgDb - pkgConfigDB + toolchains + pkgConfigDbs + installedPkgs + sourcePkgs localPackages pkgStanzasEnable = - resolveDependencies - (Stage.always (compilerInfo comp, platform)) - (Stage.always pkgConfigDB) - (Stage.always installedPkgIndex) - resolverParams + resolveDependencies toolchains pkgConfigDbs installedPkgs resolverParams where -- TODO: [nice to have] disable multiple instances restriction in -- the solver, but then make sure we can cope with that in the @@ -1353,13 +1426,18 @@ planPackages . removeLowerBounds solverSettingAllowOlder . removeUpperBounds solverSettingAllowNewer - . addDefaultSetupDependencies - ( mkDefaultSetupDeps comp platform - . PD.packageDescription - . srcpkgDescription - ) - . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint - . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + -- + -- TODO: These need to be per compiler. We should be able to do that + -- when we can use the stage as a solver scope + -- + -- . addDefaultSetupDependencies + -- ( mkDefaultSetupDeps compiler platform + -- . PD.packageDescription + -- . srcpkgDescription + -- ) + -- . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint + -- . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint + -- . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver @@ -1383,7 +1461,9 @@ planPackages , not (null stanzas) ] . addConstraints - -- enable stanza constraints where the user asked to enable + -- Enable stanza constraints where the user asked to enable + -- Only applies to the host stage. + -- TODO: Disable test and bench for build stage packages. [ LabeledPackageConstraint ( PackageConstraint (scopeToplevel pkgname) @@ -1432,83 +1512,9 @@ planPackages -- Note: we don't use the standardInstallPolicy here, since that uses -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy - sourcePkgDb + sourcePkgs localPackages - -- While we can talk to older Cabal versions (we need to be able to - -- do so for custom Setup scripts that require older Cabal lib - -- versions), we have problems talking to some older versions that - -- don't support certain features. - -- - -- For example, Cabal-1.16 and older do not know about build targets. - -- Even worse, 1.18 and older only supported the --constraint flag - -- with source package ids, not --dependency with installed package - -- ids. That is bad because we cannot reliably select the right - -- dependencies in the presence of multiple instances (i.e. the - -- store). See issue #3932. So we require Cabal 1.20 as a minimum. - -- - -- Moreover, lib:Cabal generally only supports the interface of - -- current and past compilers; in fact recent lib:Cabal versions - -- will warn when they encounter a too new or unknown GHC compiler - -- version (c.f. #415). To avoid running into unsupported - -- configurations we encode the compatibility matrix as lower - -- bounds on lib:Cabal here (effectively corresponding to the - -- respective major Cabal version bundled with the respective GHC - -- release). - -- - -- GHC 9.2 needs Cabal >= 3.6 - -- GHC 9.0 needs Cabal >= 3.4 - -- GHC 8.10 needs Cabal >= 3.2 - -- GHC 8.8 needs Cabal >= 3.0 - -- GHC 8.6 needs Cabal >= 2.4 - -- GHC 8.4 needs Cabal >= 2.2 - -- GHC 8.2 needs Cabal >= 2.0 - -- GHC 8.0 needs Cabal >= 1.24 - -- GHC 7.10 needs Cabal >= 1.22 - -- - -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is - -- the absolute lower bound) - -- - -- TODO: long-term, this compatibility matrix should be - -- stored as a field inside 'Distribution.Compiler.Compiler' - setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12] - | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] - | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] - | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] - | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] - | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] - | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] - | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] - | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] - | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] - | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24] - | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22] - | otherwise = mkVersion [1, 20] - where - isGHC = compFlav `elem` [GHC, GHCJS] - compFlav = compilerFlavor comp - compVer = compilerVersion comp - - -- As we can't predict the future, we also place a global upper - -- bound on the lib:Cabal version we know how to interact with: - -- - -- The upper bound is computed by incrementing the current major - -- version twice in order to allow for the current version, as - -- well as the next adjacent major version (one of which will not - -- be released, as only "even major" versions of Cabal are - -- released to Hackage or bundled with proper GHC releases). - -- - -- For instance, if the current version of cabal-install is an odd - -- development version, e.g. Cabal-2.1.0.0, then we impose an - -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a - -- stable/release even version, e.g. Cabal-2.2.1.0, the upper - -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility - -- when dealing with development snapshots of Cabal and cabal-install. - -- - setupMaxCabalVersionConstraint = - alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion - ------------------------------------------------------------------------------ -- * Install plan post-processing @@ -1614,16 +1620,14 @@ planPackages -- matching that of the classic @cabal install --user@ or @--global@ elaborateInstallPlan :: Verbosity - -> Platform - -> Compiler - -> ProgramDb - -> Maybe PkgConfigDb + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ProjectConfigShared -> PackageConfig -> PackageConfig @@ -1631,9 +1635,7 @@ elaborateInstallPlan -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity - platform - compiler - compilerprogdb + toolchains pkgConfigDB distDirLayout@DistDirLayout{..} storeDirLayout @@ -1650,9 +1652,7 @@ elaborateInstallPlan where elaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform = platform - , pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = compilerprogdb + { pkgConfigToolchains = toolchains , pkgConfigReplOptions = mempty } @@ -2011,7 +2011,7 @@ elaborateInstallPlan ++ " from " ++ prettyShow (elabPkgSourceId elab0) ) - (pkgConfigDB >>= \db -> pkgConfigDbPkgVersion db pn) + (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) ) | PkgconfigDependency pn _ <- PD.pkgconfigDepends @@ -2180,7 +2180,7 @@ elaborateInstallPlan -> ElaboratedConfiguredPackage elaborateSolverToCommon pkg@( SolverPackage - _stage + stage _qpn (SourcePackage pkgid gdesc srcloc descOverride) flags @@ -2201,12 +2201,18 @@ elaborateInstallPlan elabIsCanonical = True elabPkgSourceId = pkgid + + elabStage = stage + elabCompiler = toolchainCompiler (getStage toolchains stage) + elabPlatform = toolchainPlatform (getStage toolchains stage) + elabProgramDb = toolchainProgramDb (getStage toolchains stage) + elabPkgDescription = case PD.finalizePD flags elabEnabledSpec (const Satisfied) - platform - (compilerInfo compiler) + elabPlatform + (compilerInfo elabCompiler) [] gdesc of Right (desc, _) -> desc @@ -2281,6 +2287,10 @@ elaborateInstallPlan deps0 elabSetupPackageDBStack = buildAndRegisterDbs + inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)] + + corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout elabCompiler] + elabInplaceBuildPackageDBStack = inplacePackageDbs elabInplaceRegisterPackageDBStack = inplacePackageDbs elabInplaceSetupPackageDBStack = inplacePackageDbs @@ -2319,7 +2329,7 @@ elaborateInstallPlan , withProfLibDetail = elabProfExeDetail , withProfExeDetail = elabProfLibDetail } - okProfDyn = profilingDynamicSupportedOrUnknown compiler + okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler profExe = perPkgOptionFlag pkgid False packageConfigProf ( elabProfExeDetail @@ -2341,7 +2351,7 @@ elaborateInstallPlan elabProgramPaths = Map.fromList [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb + | prog <- configuredPrograms elabProgramDb ] <> perPkgOptionMapLast pkgid packageConfigProgramPaths elabProgramArgs = @@ -2349,14 +2359,14 @@ elaborateInstallPlan (++) ( Map.fromList [ (programId prog, args) - | prog <- configuredPrograms compilerprogdb + | prog <- configuredPrograms elabProgramDb , let args = programOverrideArgs $ addHaddockIfDocumentationEnabled prog , not (null args) ] ) (perPkgOptionMapMappend pkgid packageConfigProgramArgs) elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - elabConfiguredPrograms = configuredPrograms compilerprogdb + elabConfiguredPrograms = configuredPrograms elabProgramDb elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic @@ -2433,12 +2443,6 @@ elaborateInstallPlan mempty perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - inplacePackageDbs = - corePackageDbs - ++ [distPackageDB (compilerId compiler)] - - corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout compiler] - -- For this local build policy, every package that lives in a local source -- dir (as opposed to a tarball), or depends on such a package, will be -- built inplace into a shared dist dir. Tarball packages that depend on @@ -2761,7 +2765,12 @@ extractElabBuildStyle _ = BuildAndInstall -- * We use the state monad to cache already instantiated modules, so -- we don't instantiate the same thing multiple times. -- -instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan +instantiateInstallPlan + :: StoreDirLayout + -> Staged InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (Graph.fromDistinctList (Map.elems ready_map)) @@ -3839,8 +3848,9 @@ setupHsScriptOptions -- - if we commit to a Cabal version, the logic in Nothing else Just elabSetupScriptCliVersion - , useCompiler = Just pkgConfigCompiler - , usePlatform = Just pkgConfigPlatform + , useCompiler = Just toolchainCompiler + , usePlatform = Just toolchainPlatform + , useProgramDb = toolchainProgramDb , usePackageDB = elabSetupPackageDBStack , usePackageIndex = Nothing , useDependencies = @@ -3850,7 +3860,6 @@ setupHsScriptOptions ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps - , useProgramDb = pkgConfigCompilerProgs , useDistPref = builddir , useLoggingHandle = Nothing -- this gets set later , useWorkingDir = Just srcdir @@ -3874,6 +3883,10 @@ setupHsScriptOptions -- everything else is not a main lib or exe component ElabComponent _ -> False } + where + Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} = + -- TODO: It is disappointing that we have to change the stage here + getStage pkgConfigToolchains (prevStage elabStage) -- | To be used for the input for elaborateInstallPlan. -- @@ -3935,20 +3948,21 @@ storePackageInstallDirs' computeInstallDirs :: StoreDirLayout - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | isInplaceBuildStyle (elabBuildStyle elab) = - -- use the ordinary default install dirs +computeInstallDirs storeDirLayout defaultInstallDirs sharedConfig elab = + if isInplaceBuildStyle (elabBuildStyle elab) + then -- use the ordinary default install dirs + ( InstallDirs.absoluteInstallDirs (elabPkgSourceId elab) (elabUnitId elab) - (compilerInfo (pkgConfigCompiler elaboratedShared)) + (compilerInfo toolchainCompiler) InstallDirs.NoCopyDest - (pkgConfigPlatform elaboratedShared) - defaultInstallDirs + toolchainPlatform + defaultInstallDirs' ) { -- absoluteInstallDirs sets these as 'undefined' but we have -- to use them as "Setup.hs configure" args @@ -3956,12 +3970,15 @@ computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab , InstallDirs.libexecsubdir = "" , InstallDirs.datasubdir = "" } - | otherwise = - -- use special simplified install dirs + else -- use special simplified install dirs + storePackageInstallDirs' storeDirLayout - (pkgConfigCompiler elaboratedShared) + toolchainCompiler (elabUnitId elab) + where + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) (elabStage elab) + defaultInstallDirs' = getStage defaultInstallDirs (elabStage elab) -- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, @@ -3981,7 +3998,7 @@ setupHsConfigureFlags mkSymbolicPath plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig@ElaboratedSharedConfig{..} + sharedConfig configCommonFlags = do -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions @@ -3992,6 +4009,8 @@ setupHsConfigureFlags elab Cabal.ConfigFlags{..} where + Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage + Cabal.ConfigFlags { configVanillaLib , configSharedLib @@ -4053,7 +4072,7 @@ setupHsConfigureFlags ["-hide-all-packages"] elabProgramArgs configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) + configHcFlavor = toFlag (compilerFlavor toolchainCompiler) configHcPath = mempty -- we use configProgramPaths instead configHcPkg = mempty -- we use configProgramPaths instead configDumpBuildInfo = toFlag elabDumpBuildInfo @@ -4111,7 +4130,7 @@ setupHsConfigureFlags configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported toolchainCompiler configIgnoreBuildTools = mempty cidToGivenComponent :: ConfiguredId -> GivenComponent @@ -4286,13 +4305,13 @@ setupHsHaddockFlags -> Cabal.HaddockFlags setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) - (ElaboratedSharedConfig{..}) + sharedConfig _buildTimeSettings common = Cabal.HaddockFlags { haddockCommonFlags = common , haddockProgramPaths = - case lookupProgram haddockProgram pkgConfigCompilerProgs of + case lookupProgram haddockProgram toolchainProgramDb of Nothing -> mempty Just prg -> [ @@ -4321,6 +4340,8 @@ setupHsHaddockFlags , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir , haddockUseUnicode = toFlag elabHaddockUseUnicode } + where + Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains sharedConfig) elabStage setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well @@ -4430,11 +4451,11 @@ packageHashConfigInputs :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> PackageHashConfigInputs -packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = +packageHashConfigInputs sharedConfig pkg = PackageHashConfigInputs - { pkgHashCompilerId = compilerId pkgConfigCompiler - , pkgHashCompilerABI = compilerAbiTag pkgConfigCompiler - , pkgHashPlatform = pkgConfigPlatform + { pkgHashCompilerId = compilerId toolchainCompiler + , pkgHashCompilerABI = compilerAbiTag toolchainCompiler + , pkgHashPlatform = toolchainPlatform , pkgHashFlagAssignment = elabFlagAssignment , pkgHashConfigureScriptArgs = elabConfigureScriptArgs , pkgHashVanillaLib = withVanillaLib @@ -4481,22 +4502,10 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = , pkgHashHaddockUseUnicode = elabHaddockUseUnicode } where - ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) elabStage + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage sharedConfig pkg LBC.BuildOptions{..} = elabBuildOptions --- | Given the 'InstalledPackageIndex' for a nix-style package store, and an --- 'ElaboratedInstallPlan', replace configured source packages by installed --- packages from the store whenever they exist. -improveInstallPlanWithInstalledPackages - :: Set UnitId - -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -improveInstallPlanWithInstalledPackages installedPkgIdSet = - InstallPlan.installed canPackageBeImproved - where - canPackageBeImproved pkg = - installedUnitId pkg `Set.member` installedPkgIdSet - -- TODO: sanity checks: -- \* the installed package must have the expected deps etc -- \* the installed package must not be broken, valid dep closure @@ -4578,3 +4587,80 @@ determineCoverageFor configuredPkg plan = isIndefiniteOrInstantiation :: ModuleShape -> Bool isIndefiniteOrInstantiation = not . Set.null . modShapeRequires + +-- While we can talk to older Cabal versions (we need to be able to +-- do so for custom Setup scripts that require older Cabal lib +-- versions), we have problems talking to some older versions that +-- don't support certain features. +-- +-- For example, Cabal-1.16 and older do not know about build targets. +-- Even worse, 1.18 and older only supported the --constraint flag +-- with source package ids, not --dependency with installed package +-- ids. That is bad because we cannot reliably select the right +-- dependencies in the presence of multiple instances (i.e. the +-- store). See issue #3932. So we require Cabal 1.20 as a minimum. +-- +-- Moreover, lib:Cabal generally only supports the interface of +-- current and past compilers; in fact recent lib:Cabal versions +-- will warn when they encounter a too new or unknown GHC compiler +-- version (c.f. #415). To avoid running into unsupported +-- configurations we encode the compatibility matrix as lower +-- bounds on lib:Cabal here (effectively corresponding to the +-- respective major Cabal version bundled with the respective GHC +-- release). +-- +-- GHC 9.2 needs Cabal >= 3.6 +-- GHC 9.0 needs Cabal >= 3.4 +-- GHC 8.10 needs Cabal >= 3.2 +-- GHC 8.8 needs Cabal >= 3.0 +-- GHC 8.6 needs Cabal >= 2.4 +-- GHC 8.4 needs Cabal >= 2.2 +-- GHC 8.2 needs Cabal >= 2.0 +-- GHC 8.0 needs Cabal >= 1.24 +-- GHC 7.10 needs Cabal >= 1.22 +-- +-- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is +-- the absolute lower bound) +-- +-- TODO: long-term, this compatibility matrix should be +-- stored as a field inside 'Distribution.Compiler.Compiler' +-- +-- setupMinCabalVersionConstraint :: Compiler -> Version +-- setupMinCabalVersionConstraint compiler +-- | isGHC, compVer >= mkVersion [9, 10] = mkVersion [3, 12] +-- | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10] +-- | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8] +-- | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6] +-- | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4] +-- | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2] +-- | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0] +-- | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4] +-- | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2] +-- | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0] +-- | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24] +-- | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22] +-- | otherwise = mkVersion [1, 20] +-- where +-- isGHC = compFlav `elem` [GHC, GHCJS] +-- compFlav = compilerFlavor compiler +-- compVer = compilerVersion compiler + +-- As we can't predict the future, we also place a global upper +-- bound on the lib:Cabal version we know how to interact with: +-- +-- The upper bound is computed by incrementing the current major +-- version twice in order to allow for the current version, as +-- well as the next adjacent major version (one of which will not +-- be released, as only "even major" versions of Cabal are +-- released to Hackage or bundled with proper GHC releases). +-- +-- For instance, if the current version of cabal-install is an odd +-- development version, e.g. Cabal-2.1.0.0, then we impose an +-- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a +-- stable/release even version, e.g. Cabal-2.2.1.0, the upper +-- bound is `setup.Cabal < 2.4`. This gives us enough flexibility +-- when dealing with development snapshots of Cabal and cabal-install. +-- +-- setupMaxCabalVersionConstraint :: Version +-- setupMaxCabalVersionConstraint = +-- alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs new file mode 100644 index 00000000000..afacc83f06c --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.ProjectPlanning.Stage + ( WithStage (..) + , Stage (..) + , HasStage (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.Types.ConfiguredId (HasConfiguredId (..)) +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Package (HasUnitId (..), Package (..)) +import Distribution.Solver.Types.Stage (Stage (..)) +import Text.PrettyPrint (colon) + +-- FIXME: blaaah +data WithStage a = WithStage Stage a + deriving (Eq, Ord, Show, Generic, Functor, Foldable, Traversable) + +instance Binary a => Binary (WithStage a) +instance Structured a => Structured (WithStage a) + +instance Package pkg => Package (WithStage pkg) where + packageId (WithStage _stage pkg) = packageId pkg + +instance IsNode a => IsNode (WithStage a) where + type Key (WithStage a) = WithStage (Key a) + nodeKey = fmap nodeKey + nodeNeighbors = traverse nodeNeighbors + +instance HasUnitId a => HasUnitId (WithStage a) where + installedUnitId (WithStage _stage pkg) = installedUnitId pkg + +instance HasConfiguredId a => HasConfiguredId (WithStage a) where + configuredId (WithStage _stage pkg) = configuredId pkg + +instance Pretty a => Pretty (WithStage a) where + pretty (WithStage s pkg) = pretty s <> colon <> pretty pkg + +class HasStage a where + stageOf :: a -> Stage + +instance HasStage (WithStage a) where + stageOf (WithStage s _) = s diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index de08254fea5..fd1b0766eb2 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -59,6 +59,13 @@ module Distribution.Client.ProjectPlanning.Types , componentOptionalStanza , componentTargetName + -- * Toolchain + , Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + , WithStage (..) + -- * Setup script , SetupScriptStyle (..) ) where @@ -77,9 +84,11 @@ import Distribution.Client.InstallPlan , GenericPlanPackage (..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectPlanning.Stage import Distribution.Client.SolverInstallPlan ( SolverInstallPlan ) +import Distribution.Client.Toolchain import Distribution.Client.Types import Distribution.Backpack @@ -110,7 +119,6 @@ import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza -import Distribution.System import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) @@ -184,9 +192,7 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs data ElaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform :: Platform - , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo - , pkgConfigCompilerProgs :: ProgramDb + { pkgConfigToolchains :: Toolchains -- ^ The programs that the compiler configured (e.g. for GHC, the progs -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are -- used. @@ -245,6 +251,7 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage -- to disable. This tells us which ones we build by default, and -- helps with error messages when the user asks to build something -- they explicitly disabled. + , elabStage :: Stage , -- TODO: The 'Bool' here should be refined into an ADT with three -- cases: NotRequested, ExplicitlyRequested and -- ImplicitlyRequested. A stanza is explicitly requested if @@ -341,10 +348,11 @@ normaliseConfiguredPackage :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage -normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = +normaliseConfiguredPackage shared pkg = pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} where - knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs + Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains shared) (elabStage pkg) + knownProgramDb = addKnownPrograms builtinPrograms toolchainProgramDb pkgDesc :: PackageDescription pkgDesc = elabPkgDescription pkg @@ -537,10 +545,12 @@ elabDistDirParams shared elab = , distParamComponentName = case elabPkgOrComp elab of ElabComponent comp -> compComponentName comp ElabPackage _ -> Nothing - , distParamCompilerId = compilerId (pkgConfigCompiler shared) - , distParamPlatform = pkgConfigPlatform shared + , distParamCompilerId = compilerId toolchainCompiler + , distParamPlatform = toolchainPlatform , distParamOptimization = LBC.withOptimization $ elabBuildOptions elab } + where + Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab) -- | The full set of dependencies which dictate what order we -- need to build things in the install plan: "order dependencies" diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index c5bca638133..60930c45cb7 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -70,7 +70,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedSharedConfig (..) - , configureCompiler + , configureToolchains ) import Distribution.Client.RebuildMonad ( runRebuild @@ -194,6 +194,7 @@ import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.Stage (Stage (..), getStage) import Distribution.Utils.Path ( unsafeMakeSymbolicPath ) @@ -360,9 +361,9 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS exists <- doesFileExist script if exists then do - ctx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) + baseCtx <- withGlobalConfig verbosity globalConfigFlag (scriptBaseCtx script) - let projectRoot = distProjectRootDirectory $ distDirLayout ctx + let projectRoot = distProjectRootDirectory $ distDirLayout baseCtx writeFile (projectRoot "scriptlocation") =<< canonicalizePath script scriptContents <- BS.readFile script @@ -374,15 +375,18 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig) (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig) - projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents + projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout baseCtx) (takeFileName script) scriptContents - createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} <- - runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout baseCtx) + + toolchains <- + runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) + + let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton - let ctx' = ctx & lProjectConfig %~ (<> projectCfg) + let ctx' = baseCtx & lProjectConfig %~ (<> projectCfg) build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform exePath = build_dir "bin" scriptExeFileName script @@ -470,14 +474,13 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do let projectRoot = distProjectRootDirectory $ distDirLayout ctx absScript <- unsafeMakeSymbolicPath . makeRelative (normalise projectRoot) <$> canonicalizePath scriptPath - let - sourcePackage = - fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condExecutables - .~ [(scriptComponentName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] - executable = - scriptExecutable - & L.modulePath .~ absScript + let sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condExecutables + .~ [(scriptComponentName scriptPath, CondNode executable (targetBuildDepends $ buildInfo executable) [])] + executable = + scriptExecutable + & L.modulePath .~ absScript updateContextAndWriteProjectFile' ctx sourcePackage @@ -588,10 +591,12 @@ fakeProjectSourcePackage projectRoot = sourcePackage movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath movedExePath selectedComponent distDirLayout elabShared elabConfigured = do exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured - let CompilerId flavor _ = (compilerId . pkgConfigCompiler) elabShared + let CompilerId flavor _ = compilerId toolchainCompiler opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe) let projectRoot = distProjectRootDirectory distDirLayout fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) + where + Toolchain{..} = getStage (pkgConfigToolchains elabShared) (elabStage elabConfigured) -- Lenses diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 69c8f888698..641bae5d1ac 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -821,7 +821,7 @@ getExternalSetupMethod verbosity options pkg bt = do , SetupScriptOptions ) installedVersion = do - (comp, progdb, options') <- configureCompiler options + (comp, progdb, options') <- configureToolchains options (version, mipkgid, options'') <- installedCabalVersion options' @@ -950,10 +950,10 @@ getExternalSetupMethod verbosity options pkg bt = do _ -> False latestVersion = version - configureCompiler + configureToolchains :: SetupScriptOptions -> IO (Compiler, ProgramDb, SetupScriptOptions) - configureCompiler options' = do + configureToolchains options' = do (comp, progdb) <- case useCompiler options' of Just comp -> return (comp, useProgramDb options') Nothing -> do @@ -1081,7 +1081,7 @@ getExternalSetupMethod verbosity options pkg bt = do let outOfDate = setupHsNewer || cabalVersionNewer when (outOfDate || forceCompile) $ do debug verbosity "Setup executable needs to be updated, compiling..." - (compiler, progdb, options'') <- configureCompiler options' + (compiler, progdb, options'') <- configureToolchains options' pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion (program, extraOpts) = diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs index f3c44e76fc8..e6023fdd91a 100644 --- a/cabal-install/src/Distribution/Client/Toolchain.hs +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Client.Toolchain ( Stage (..) @@ -8,11 +7,14 @@ module Distribution.Client.Toolchain , Toolchain (..) , mkProgramDb , configToolchain + , configToolchains , module Distribution.Solver.Types.Stage , module Distribution.Solver.Types.Toolchain ) where +import Distribution.Client.Setup (ConfigExFlags (..)) +import Distribution.Simple (Compiler, CompilerFlavor) import Distribution.Simple.Compiler (interpretPackageDBStack) import Distribution.Simple.Configure import Distribution.Simple.Program (ProgArg) @@ -20,6 +22,7 @@ import Distribution.Simple.Program.Db import Distribution.Simple.Setup import Distribution.Solver.Types.Stage import Distribution.Solver.Types.Toolchain +import Distribution.System (Platform) import Distribution.Utils.NubList import Distribution.Verbosity (Verbosity) @@ -63,3 +66,57 @@ configToolchain configFlags@ConfigFlags{..} = do where -- FIXME verbosity = fromFlag (configVerbosity configFlags) + +configToolchains :: Verbosity -> ConfigFlags -> ConfigExFlags -> IO (Staged Toolchain) +configToolchains verbosity ConfigFlags{..} ConfigExFlags{..} = do + programDb <- + mkProgramDb + verbosity + (fromNubList configProgramPathExtra) + configProgramPaths + configProgramArgs + + hostToolchain <- do + (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <- + configCompilerExSafe + verbosity + (flagToMaybe configHcFlavor) + (flagToMaybe configHcPath) + (flagToMaybe configHcPkg) + programDb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + return Toolchain{..} + + buildToolchain <- do + (toolchainCompiler, toolchainPlatform, toolchainProgramDb) <- + configCompilerExSafe + verbosity + (flagToMaybe configBuildHcFlavor) + (flagToMaybe configBuildHcPath) + (flagToMaybe configBuildHcPkg) + programDb + let toolchainPackageDBs = interpretPackageDBStack Nothing $ interpretPackageDbFlags False $ configPackageDBs + return Toolchain{..} + + return $ Staged (\case Build -> buildToolchain; Host -> hostToolchain) + +configCompilerExSafe + :: Verbosity + -> Maybe CompilerFlavor + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Platform, ProgramDb) +configCompilerExSafe verbosity hcFlavor hcPath hcPkg progdb = do + (compiler, platform, progdb') <- + configCompilerEx + hcFlavor + hcPath + hcPkg + progdb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future. + -- I think this should be fixed in configCompilerExAux or even configCompilerEx + progdb'' <- configureAllKnownPrograms verbosity progdb' + return (compiler, platform, progdb'') diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 558fd2fa8f7..1159246bf16 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -1918,10 +1918,10 @@ testSetupScriptStyles config reportSubCase = do let isOSX (Platform _ OSX) = True isOSX _ = False - compilerVer = compilerVersion (pkgConfigCompiler sharedConfig) + compilerVer = compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) -- Skip the Custom tests when the shipped Cabal library is buggy unless - ( (isOSX (pkgConfigPlatform sharedConfig) && (compilerVer < mkVersion [7, 10])) + ( (isOSX (toolchainPlatform $ getStage (pkgConfigToolchains sharedConfig) Build) && (compilerVer < mkVersion [7, 10])) -- 9.10 ships Cabal 3.12.0.0 affected by #9940 || (mkVersion [9, 10] <= compilerVer && compilerVer < mkVersion [9, 11]) ) @@ -1935,7 +1935,7 @@ testSetupScriptStyles config reportSubCase = do removeFile (basedir testdir1 "marker") -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later - when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8, 2]) $ do + when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) < mkVersion [8, 2]) $ do reportSubCase (show SetupCustomImplicitDeps) (plan2, res2) <- executePlan =<< planProject testdir2 config pkg2 <- expectPackageInstalled plan2 res2 pkgidA @@ -2802,7 +2802,7 @@ testHaddockProjectDependencies config = do (_, _, sharedConfig) <- planProject testdir config -- `haddock-project` is only supported by `haddock-2.26.1` and above which is -- shipped with `ghc-9.4` - when (compilerVersion (pkgConfigCompiler sharedConfig) > mkVersion [9, 4]) $ do + when (compilerVersion (toolchainCompiler $ getStage (pkgConfigToolchains sharedConfig) Build) > mkVersion [9, 4]) $ do let dir = basedir testdir cleanHaddockProject testdir withCurrentDirectory dir $ do From 834ac3a557cfd7e008a457678d44ac2eb19fd64c Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 2 Apr 2025 14:43:52 +0800 Subject: [PATCH 020/122] feat(cabal-install): add stage to ConstraintScope and UserConstraint --- .../Solver/Modular/IndexConversion.hs | 8 +- .../Solver/Types/PackageConstraint.hs | 47 +++++++---- .../src/Distribution/Client/CmdFreeze.hs | 2 +- .../src/Distribution/Client/CmdRepl.hs | 2 +- .../src/Distribution/Client/Dependency.hs | 8 +- .../src/Distribution/Client/Targets.hs | 81 ++++++++++++++----- .../Client/Types/PackageSpecifier.hs | 2 +- cabal-install/tests/IntegrationTests2.hs | 2 +- .../Distribution/Client/ArbitraryInstances.hs | 4 + .../UnitTests/Distribution/Client/Targets.hs | 2 +- .../Distribution/Client/TreeDiffInstances.hs | 1 + .../Distribution/Solver/Modular/QuickCheck.hs | 4 +- .../Distribution/Solver/Modular/Solver.hs | 36 ++++----- 13 files changed, 133 insertions(+), 66 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index c1dc4a5417d..51a9ebad01d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs @@ -275,17 +275,19 @@ testConditionForComponent :: Stage -> (a -> Bool) -> CondTree ConfVar [Dependency] a -> Maybe Bool -testConditionForComponent _stage os arch cinfo constraints p tree = +testConditionForComponent stage os arch cinfo constraints p tree = case go $ extractCondition p tree of Lit True -> Just True Lit False -> Just False _ -> Nothing where + -- TODO: fix for stage flagAssignment :: [(FlagName, Bool)] flagAssignment = mconcat [ unFlagAssignment fa - | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) - <- L.map unlabelPackageConstraint constraints] + | PackageConstraint (ConstraintScope stage' (ScopeAnyQualifier _)) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints + , maybe True (== stage) stage'] -- Simplify the condition, using the current environment. Most of this -- function was copied from convBranch and diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 20a8399b1d3..9bdd6615824 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -7,6 +7,7 @@ -- module Distribution.Solver.Types.PackageConstraint ( ConstraintScope(..), + ConstraintQualifier(..), scopeToplevel, scopeToPackageName, constraintScopeMatches, @@ -29,11 +30,21 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import qualified Text.PrettyPrint as Disp +import Distribution.Solver.Types.Toolchain (Stage (..)) -- | Determines to what packages and in what contexts a -- constraint applies. -data ConstraintScope +data ConstraintScope = + ConstraintScope + -- | The stage at which the constraint applies, if any. + -- If Nothing, the constraint applies to all stages. + (Maybe Stage) + -- | The qualifier that determines the scope of the constraint. + ConstraintQualifier + deriving (Eq, Show) + +data ConstraintQualifier -- | A scope that applies when the given package is used as a build target. -- In other words, the scope applies iff a goal has a top-level qualifier -- and its namespace matches the given package name. A namespace is @@ -56,29 +67,37 @@ data ConstraintScope -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a --- top-level dependency in the default namespace. +-- top-level dependency in the host stage. scopeToplevel :: PackageName -> ConstraintScope -scopeToplevel = ScopeQualified QualToplevel +scopeToplevel = ConstraintScope (Just Host) . ScopeQualified QualToplevel -- | Returns the package name associated with a constraint scope. scopeToPackageName :: ConstraintScope -> PackageName -scopeToPackageName (ScopeTarget pn) = pn -scopeToPackageName (ScopeQualified _ pn) = pn -scopeToPackageName (ScopeAnySetupQualifier pn) = pn -scopeToPackageName (ScopeAnyQualifier pn) = pn +scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool -constraintScopeMatches (ScopeTarget pn) (Q (PackagePath _ q) pn') = +constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' q) pn') = + maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn' + +constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool +constraintQualifierMatches (ScopeTarget pn) q pn' = q == QualToplevel && pn == pn' -constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = +constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn' -constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = - let setup (PackagePath _ (QualSetup _)) = True - setup _ = False - in setup pp && pn == pn' -constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = + pn == pn' +constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = + pn == pn' +constraintQualifierMatches _ _ _ = False instance Pretty ConstraintScope where + pretty (ConstraintScope mstage qualifier) = + maybe mempty pretty mstage <+> pretty qualifier + +instance Pretty ConstraintQualifier where pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 2f4ddaac8b4..eb799324f7c 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -30,7 +30,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) , UserQualifier (..) ) import Distribution.Solver.Types.ConstraintSource diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 8ebe1d44747..d448e5da4bb 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -80,7 +80,7 @@ import Distribution.Client.TargetProblem ) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) ) import Distribution.Client.Types ( PackageSpecifier (..) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index bd430bc41de..c3111d29a0b 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -440,7 +440,7 @@ dontInstallNonReinstallablePackages params = where extraConstraints = [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) + (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled) ConstraintSourceNonReinstallablePackage | pkgname <- nonReinstallablePackages ] @@ -642,7 +642,7 @@ addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion minVersion) ) ConstraintSetupCabalMinVersion @@ -660,7 +660,7 @@ addSetupCabalMaxVersionConstraint maxVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ earlierVersion maxVersion) ) ConstraintSetupCabalMaxVersion @@ -676,7 +676,7 @@ addSetupCabalProfiledDynamic = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) ) ConstraintSourceProfiledDynamic diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index bfa94b0da80..8dba648d264 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -- | @@ -34,7 +35,8 @@ module Distribution.Client.Targets -- * User constraints , UserQualifier (..) , UserConstraintScope (..) - , UserConstraint (..) + , UserConstraintQualifier (..) + , UserConstraint (UserConstraint, UserConstraintStaged) , userConstraintPackageName , readUserConstraint , userToPackageConstraint @@ -99,6 +101,7 @@ import qualified Data.Map as Map import Distribution.Client.Errors import qualified Distribution.Client.GZipUtils as GZipUtils import qualified Distribution.Compat.CharParsing as P +import Distribution.Solver.Types.Stage (Stage) import Distribution.Utils.Path (makeSymbolicPath) import Network.URI ( URI (..) @@ -613,7 +616,13 @@ instance Structured UserQualifier -- | Version of 'ConstraintScope' that a user may specify on the -- command line. -data UserConstraintScope +data UserConstraintScope = UserConstraintScope (Maybe Stage) UserConstraintQualifier + deriving (Eq, Show, Generic) + +instance Binary UserConstraintScope +instance Structured UserConstraintScope + +data UserConstraintQualifier = -- | Scope that applies to the package when it has the specified qualifier. UserQualified UserQualifier PackageName | -- | Scope that applies to the package when it has a setup qualifier. @@ -622,8 +631,8 @@ data UserConstraintScope UserAnyQualifier PackageName deriving (Eq, Show, Generic) -instance Binary UserConstraintScope -instance Structured UserConstraintScope +instance Binary UserConstraintQualifier +instance Structured UserConstraintQualifier fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel @@ -631,29 +640,37 @@ fromUserQualifier (UserQualSetup name) = QualSetup name fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope -fromUserConstraintScope (UserQualified q pn) = - ScopeQualified (fromUserQualifier q) pn -fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn -fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn +fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) = + ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) = + ConstraintScope mstage (ScopeAnySetupQualifier pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) = + ConstraintScope mstage (ScopeAnyQualifier pn) -- | Version of 'PackageConstraint' that the user can specify on -- the command line. data UserConstraint - = UserConstraint UserConstraintScope PackageProperty + = UserConstraintX UserConstraintScope PackageProperty deriving (Eq, Show, Generic) instance Binary UserConstraint instance Structured UserConstraint +pattern UserConstraint :: UserConstraintQualifier -> PackageProperty -> UserConstraint +pattern UserConstraint qualifier prop = UserConstraintX (UserConstraintScope Nothing qualifier) prop + +pattern UserConstraintStaged :: Stage -> UserConstraintQualifier -> PackageProperty -> UserConstraint +pattern UserConstraintStaged stage qualifier prop = UserConstraintX (UserConstraintScope (Just stage) qualifier) prop + userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName (UserConstraint scope _) = scopePN scope +userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier) _) = scopePN qualifier where scopePN (UserQualified _ pn) = pn scopePN (UserAnyQualifier pn) = pn scopePN (UserAnySetupQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint -userToPackageConstraint (UserConstraint scope prop) = +userToPackageConstraint (UserConstraintX scope prop) = PackageConstraint (fromUserConstraintScope scope) prop readUserConstraint :: String -> Either String UserConstraint @@ -668,7 +685,7 @@ readUserConstraint str = ++ "'source', 'test', 'bench', or flags. " instance Pretty UserConstraint where - pretty (UserConstraint scope prop) = + pretty (UserConstraintX scope prop) = pretty $ PackageConstraint (fromUserConstraintScope scope) prop instance Parsec UserConstraint where @@ -684,25 +701,49 @@ instance Parsec UserConstraint where , PackagePropertyStanzas [TestStanzas] <$ P.string "test" , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" ] - return (UserConstraint scope prop) + return (UserConstraintX scope prop) where parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope parseConstraintScope = do + mstage <- P.optional (P.try (parsec <* P.char ':')) pn <- parsec - P.choice - [ P.char '.' *> withDot pn - , P.char ':' *> withColon pn - , return (UserQualified UserQualToplevel pn) - ] + c <- + P.choice + [ P.char '.' *> withDot pn + , P.char ':' *> withColon pn + , return (UserQualified UserQualToplevel pn) + ] + return $ UserConstraintScope mstage c where - withDot :: PackageName -> m UserConstraintScope + withDot :: PackageName -> m UserConstraintQualifier withDot pn | pn == mkPackageName "any" = UserAnyQualifier <$> parsec | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn - withColon :: PackageName -> m UserConstraintScope + withColon :: PackageName -> m UserConstraintQualifier withColon pn = UserQualified (UserQualSetup pn) <$ P.string "setup." <*> parsec + +-- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "setup.any source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertySource) +-- +-- >>> eitherParsec "build:rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource) +-- +-- >>> eitherParsec "setup.any installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertyInstalled) +-- +-- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled) diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs index a803a85b429..c42aa1c7991 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs @@ -52,7 +52,7 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) = where pc = PackageConstraint - (ScopeTarget $ packageName pkg) + (scopeToplevel (packageName pkg)) (PackagePropertyVersion $ thisVersion (packageVersion pkg)) mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 1159246bf16..58555cecd9d 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -31,7 +31,7 @@ import Distribution.Client.TargetSelector hiding (DirActions (..)) import qualified Distribution.Client.TargetSelector as TS (DirActions (..)) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (UserAnyQualifier) + , UserConstraintQualifier (UserAnyQualifier) ) import Distribution.Client.Types ( PackageLocation (..) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 8af811cfeb9..8b6ee203104 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -288,6 +288,10 @@ instance Arbitrary UserConstraintScope where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary UserConstraintQualifier where + arbitrary = genericArbitrary + shrink = genericShrink + instance Arbitrary UserQualifier where arbitrary = oneof diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index ac6d96cc159..cbb16c49477 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -4,7 +4,7 @@ module UnitTests.Distribution.Client.Targets import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) , UserQualifier (..) , readUserConstraint ) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index 8322b642c19..b77cdff89c6 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -81,6 +81,7 @@ instance ToExpr Timestamp instance ToExpr TotalIndexState instance ToExpr UserConstraint instance ToExpr UserConstraintScope +instance ToExpr UserConstraintQualifier instance ToExpr UserQualifier instance ToExpr WriteGhcEnvironmentFilesPolicy diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index ed51de157c2..08e917be949 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -470,8 +470,8 @@ arbitraryConstraint pkgs = do (PN pn, v) <- elements pkgs let anyQualifier = ScopeAnyQualifier (mkPackageName pn) oneof - [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v - , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] + [ ExVersionConstraint (ConstraintScope Nothing anyQualifier) <$> arbitraryVersionRange v + , ExStanzaConstraint (ConstraintScope Nothing anyQualifier) <$> sublistOf [TestStanzas, BenchStanzas] ] arbitraryPreference :: [(PN, PV)] -> Gen ExPreference diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index e0a568724de..e092b40c033 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -66,13 +66,13 @@ tests = any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" in runTest $ setVerbose $ - constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ + constraints [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "true-dep")) V.noVersion] $ mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ -- TODO: We should check the summarized log instead of the full log -- for the manual flags error message, but it currently only -- appears in the full log. SolverResult checkFullLog (Left $ const True) - , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] + , let cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "pkg")) "flag" False] in runTest $ constraints cs $ mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ @@ -81,7 +81,7 @@ tests = , testGroup "Qualified manual flag constraints" [ let name = "Top-level flag constraint does not constrain setup dep's flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False] in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ @@ -94,8 +94,8 @@ tests = ] , let name = "Solver can toggle setup dep's flag to match top-level constraint" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False - , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False + , ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "b-2-true-dep")) V.noVersion ] in runTest $ constraints cs $ @@ -109,8 +109,8 @@ tests = ] , let name = "User can constrain flags separately with qualified constraints" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True + , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False ] in runTest $ constraints cs $ @@ -124,15 +124,15 @@ tests = ] , -- Regression test for #4299 let name = "Solver can link deps when only one has constrained manual flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] + cs = [ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" False] in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ solverSuccess [("A", 1), ("B", 1), ("b-1-false-dep", 1)] , let name = "Solver cannot link deps that have conflicting manual flag constraints" cs = - [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False + [ ExFlagConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "B")) "flag" True + , ExFlagConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "A") "B")) "flag" False ] failureReason = "(constraint from unknown source requires opposite flag selection)" checkFullLog lns = @@ -259,20 +259,20 @@ tests = [ runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] - , let cs = [ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4] + , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnyQualifier "D")) $ mkVersionRange 1 4] in runTest $ constraints cs $ mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] , let cs = - [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 - , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 + [ ExVersionConstraint (ConstraintScope Nothing (ScopeQualified P.QualToplevel "D")) $ mkVersionRange 1 4 + , ExVersionConstraint (ConstraintScope Nothing (ScopeQualified (P.QualSetup "B") "D")) $ mkVersionRange 4 7 ] in runTest $ constraints cs $ mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] - , let cs = [ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4] + , let cs = [ExVersionConstraint (ConstraintScope Nothing (ScopeAnySetupQualifier "D")) $ mkVersionRange 1 4] in runTest $ constraints cs $ mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ @@ -402,7 +402,7 @@ tests = `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ] in runTest $ - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $ + constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "make-lib-private" True] $ mkTest db "reject package with sub-library made private by flag constraint" ["A"] $ solverFailure $ isInfixOf $ @@ -517,7 +517,7 @@ tests = ] , -- tests for partial fix for issue #5325 testGroup "Components that are unbuildable in the current environment" $ - let flagConstraint = ExFlagConstraint . ScopeAnyQualifier + let flagConstraint = ExFlagConstraint . ConstraintScope Nothing . ScopeAnyQualifier in [ let db = [Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]] in runTest $ constraints [flagConstraint "A" "build-lib" False] $ @@ -1994,7 +1994,7 @@ requireConsistentBuildToolVersions name = -- instead of missing. chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest chooseUnbuildableExeAfterBuildToolsPackage name = - constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $ + constraints [ExFlagConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) "build-bt2" False] $ goalOrder goals $ mkTest db name ["A"] $ solverFailure $ @@ -2110,7 +2110,7 @@ setupStanzaTest1 = constraints [ExStanzaConstraint (scopeToplevel "B") [TestStan -- With the "any" qualifier syntax setupStanzaTest2 :: SolverTest setupStanzaTest2 = - constraints [ExStanzaConstraint (ScopeAnyQualifier "B") [TestStanzas]] $ + constraints [ExStanzaConstraint (ConstraintScope Nothing (ScopeAnyQualifier "B")) [TestStanzas]] $ mkTest dbSetupStanza "setupStanzaTest2" From 10dec2723814c8444a0695682d947575ddf16d13 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 17:59:51 +0800 Subject: [PATCH 021/122] refactor(cabal-install-solver): improve messages --- cabal-install-solver/src/Distribution/Solver/Modular/Message.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index d4ce663e6be..51c0afae8f0 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs @@ -263,7 +263,7 @@ showOption :: QPN -> POption -> String showOption qpn@(Q _pp pn) (POption i linkedTo) = case linkedTo of Nothing -> showQPN qpn ++ " == " ++ showI i - Just pp' -> showQPN qpn ++ " ~> " ++ showQPN (Q pp' pn) + Just pp' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn -- | Shows a mixed list of instances and versions in a human-friendly way, -- abbreviated. From 1f218e54c2f591587ab3c35b9d756e45ee9e0eb2 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 022/122] refactor(cabal-install): use a pretty printer in showDepResolverParams --- .../src/Distribution/Client/Dependency.hs | 86 ++++++++++--------- 1 file changed, 46 insertions(+), 40 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index c3111d29a0b..01e804f4898 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -115,7 +115,8 @@ import qualified Distribution.PackageDescription.Configuration as PD import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import Distribution.Simple.Setup - ( asBool + ( BooleanFlag + , asBool ) import Distribution.Solver.Modular ( PruneAfterFirstSuccess (..) @@ -136,7 +137,8 @@ import Distribution.Types.DependencySatisfaction ( DependencySatisfaction (..) ) import Distribution.Verbosity - ( normal + ( deafening + , normal ) import Distribution.Version @@ -171,6 +173,7 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import Text.PrettyPrint -- ------------------------------------------------------------ @@ -214,45 +217,48 @@ data DepResolverParams = DepResolverParams showDepResolverParams :: DepResolverParams -> String showDepResolverParams p = - "targets: " - ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p)) - ++ "\nconstraints: " - ++ concatMap - (("\n " ++) . showLabeledConstraint) - (depResolverConstraints p) - ++ "\npreferences: " - ++ concatMap - (("\n " ++) . showPackagePreference) - (depResolverPreferences p) - ++ "\nstrategy: " - ++ show (depResolverPreferenceDefault p) - ++ "\nreorder goals: " - ++ show (asBool (depResolverReorderGoals p)) - ++ "\ncount conflicts: " - ++ show (asBool (depResolverCountConflicts p)) - ++ "\nfine grained conflicts: " - ++ show (asBool (depResolverFineGrainedConflicts p)) - ++ "\nminimize conflict set: " - ++ show (asBool (depResolverMinimizeConflictSet p)) - ++ "\navoid reinstalls: " - ++ show (asBool (depResolverAvoidReinstalls p)) - ++ "\nshadow packages: " - ++ show (asBool (depResolverShadowPkgs p)) - ++ "\nstrong flags: " - ++ show (asBool (depResolverStrongFlags p)) - ++ "\nallow boot library installs: " - ++ show (asBool (depResolverAllowBootLibInstalls p)) - ++ "\nonly constrained packages: " - ++ show (depResolverOnlyConstrained p) - ++ "\nmax backjumps: " - ++ maybe - "infinite" - show - (depResolverMaxBackjumps p) + render $ + vcat + [ hang (text "targets:") 2 $ + vcat [text (prettyShow pkgname) | pkgname <- Set.toList (depResolverTargets p)] + , hang (text "constraints:") 2 $ + vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] + , hang (text "constraints:") 2 $ + vcat [prettyLabeledConstraint lc | lc <- depResolverConstraints p] + , hang (text "preferences:") 2 $ + if depResolverVerbosity p >= deafening + then vcat [text (showPackagePreference pref) | pref <- depResolverPreferences p] + else text "... increase verbosity to see" + , hang (text "strategy:") 2 $ + text (show (depResolverPreferenceDefault p)) + , hang (text "reorder goals:") 2 $ + prettyBool (depResolverReorderGoals p) + , hang (text "count conflicts:") 2 $ + prettyBool (depResolverCountConflicts p) + , hang (text "fine grained conflicts:") 2 $ + prettyBool (depResolverFineGrainedConflicts p) + , hang (text "minimize conflict set:") 2 $ + prettyBool (depResolverMinimizeConflictSet p) + , hang (text "avoid reinstalls:") 2 $ + prettyBool (depResolverAvoidReinstalls p) + , hang (text "shadow packages:") 2 $ + prettyBool (depResolverShadowPkgs p) + , hang (text "strong flags:") 2 $ + prettyBool (depResolverStrongFlags p) + , hang (text "allow boot library installs:") 2 $ + prettyBool (depResolverAllowBootLibInstalls p) + , hang (text "only constrained packages:") 2 $ + text (show (depResolverOnlyConstrained p)) + , hang (text "max backjumps:") 2 $ + text (maybe "infinite" show (depResolverMaxBackjumps p)) + ] where - showLabeledConstraint :: LabeledPackageConstraint -> String - showLabeledConstraint (LabeledPackageConstraint pc src) = - showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")" + prettyBool :: BooleanFlag a => a -> Doc + prettyBool = pretty . asBool + + prettyLabeledConstraint :: LabeledPackageConstraint -> Doc + prettyLabeledConstraint (LabeledPackageConstraint pc src) = + pretty pc <+> parens (pretty src) -- | A package selection preference for a particular package. -- From ded3751c145b8753170e2c4ab8ec9daf6ed32c7d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 023/122] feat(cabal-install-solver): add null to ComponentDeps --- .../src/Distribution/Solver/Types/ComponentDeps.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs index 8926521673b..7619bd5c653 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -36,11 +36,12 @@ module Distribution.Solver.Types.ComponentDeps ( , setupDeps , select , components + , null ) where import Prelude () import Distribution.Types.UnqualComponentName -import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) +import Distribution.Solver.Compat.Prelude hiding (null, empty, toList, zip) import qualified Data.Map as Map import Data.Foldable (fold) @@ -133,6 +134,9 @@ insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps aux Nothing = Just a aux (Just a') = Just $ a `mappend` a' +null :: ComponentDeps a -> Bool +null = Map.null . unComponentDeps + -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. zip From 823f2f77512debdb016ab834ebd3a437aa43820e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 23 Apr 2025 18:00:53 +0800 Subject: [PATCH 024/122] feat(cabal-install-solver): add Pretty instance for SolverId --- .../src/Distribution/Solver/Types/SolverId.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index d32ccc17e74..1141530c7c4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -9,6 +9,8 @@ import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) +import Distribution.Pretty (Pretty (..)) +import Text.PrettyPrint (parens) -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't @@ -27,3 +29,7 @@ instance Show SolverId where instance Package SolverId where packageId = solverSrcId + +instance Pretty SolverId where + pretty (PreExistingId pkg unitId) = pretty pkg <+> parens (pretty unitId) + pretty (PlannedId pkg) = pretty pkg \ No newline at end of file From 0658a0e290dab4a6379f595fb1c95006fee14bd1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 28 Apr 2025 22:49:55 +0800 Subject: [PATCH 025/122] refactor(cabal-install): merge two almost identical functions Merge fromSolverInstallPlan and fromSolverInstallPlanWithProgress. --- Cabal/src/Distribution/Utils/LogProgress.hs | 11 +++++ .../src/Distribution/Client/InstallPlan.hs | 43 +++++-------------- 2 files changed, 21 insertions(+), 33 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 33c50f20b5e..0968a136372 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -4,6 +4,7 @@ module Distribution.Utils.LogProgress ( LogProgress , runLogProgress + , runLogProgress' , warnProgress , infoProgress , dieProgress @@ -61,6 +62,16 @@ runLogProgress verbosity (LogProgress m) = fail_fn doc = do dieNoWrap verbosity (render doc) +-- | Run 'LogProgress' ignoring all traces. +runLogProgress' :: LogProgress a -> Either ErrMsg a +runLogProgress' (LogProgress m) = foldProgress (\_ x -> x) Left Right (m env) + where + env = + LogEnv + { le_verbosity = silent + , le_context = [] + } + -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index f68d56c3d66..00aa273e67b 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -528,35 +528,11 @@ fromSolverInstallPlan -> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = - mkInstallPlan - "fromSolverInstallPlan" - (Graph.fromDistinctList pkgs'') - where - (_, _, pkgs'') = - foldl' - f' - (Map.empty, Map.empty, []) - (SolverInstallPlan.reverseTopologicalOrder plan) - - f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) - where - pkgs' = f (mapDep pidMap ipiMap) pkg - - (pidMap', ipiMap') = - case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) - - mapDep _ ipiMap (PreExistingId _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) - --- This shouldn't happen, since mapDep should only be called --- on neighbor SolverId, which must have all been done already --- by the reverse top-sort (we assume the graph is not broken). + either (error . show) id $ + runLogProgress' $ + fromSolverInstallPlanWithProgress + (\mapDep planpkg -> return $ f mapDep planpkg) + plan fromSolverInstallPlanWithProgress :: (IsUnit ipkg, IsUnit srcpkg) @@ -585,6 +561,11 @@ fromSolverInstallPlanWithProgress f plan = do PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) return (pidMap', ipiMap', pkgs' ++ pkgs) + -- The error below shouldn't happen, since mapDep should only + -- be called on neighbor SolverId, which must have all been done + -- already by the reverse top-sort (we assume the graph is not broken). + -- + -- FIXME: stage is ignored mapDep _ ipiMap (PreExistingId _pid uid) | Just pkgs <- Map.lookup uid ipiMap = pkgs | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) @@ -592,10 +573,6 @@ fromSolverInstallPlanWithProgress f plan = do | Just pkgs <- Map.lookup pid pidMap = pkgs | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) --- This shouldn't happen, since mapDep should only be called --- on neighbor SolverId, which must have all been done already --- by the reverse top-sort (we assume the graph is not broken). - -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan From 04f7f38464ea20ef6d658886fdac56d4ab110c7e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 29 Apr 2025 17:23:02 +0800 Subject: [PATCH 026/122] chore(cabal-install-solver): add comments and improve readability --- .../Distribution/Solver/Modular/Builder.hs | 74 ++++++++------- .../Distribution/Solver/Modular/Dependency.hs | 64 ++++++++++--- .../src/Distribution/Solver/Modular/Index.hs | 13 ++- .../src/Distribution/Solver/Modular/Tree.hs | 91 +++++++++++++++---- 4 files changed, 176 insertions(+), 66 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs index 7f0568f97a6..84d709346f4 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Builder.hs @@ -62,41 +62,48 @@ type LinkingState = M.Map (PN, I) [PackagePath] -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState -extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs +extendOpen qpn deps buildState@(BS { rdeps = rdeps0, open = goals0 }) = go rdeps0 goals0 deps where go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState - go g o [] = s { rdeps = g, open = o } - go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = - go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs - -- Note: for 'Flagged' goals, we always insert, so later additions win. - -- This is important, because in general, if a goal is inserted twice, - -- the later addition will have better dependency information. - go g o ((Stanza sn@(SN qpn _) t) : ngs) = - go g (StanzaGoal sn t (flagGR qpn) : o) ngs - go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) - | qpn == qpn' = - -- We currently only add a self-dependency to the graph if it is - -- between a package and its setup script. The edge creates a cycle - -- and causes the solver to backtrack and choose a different - -- instance for the setup script. We may need to track other - -- self-dependencies once we implement component-based solving. + go rdeps goals [] = + buildState { rdeps = rdeps, open = goals } + + go rdeps goals ((Flagged fn@(FN qpn' _) fInfo t f) : fdeps) = + go rdeps (FlagGoal fn fInfo t f (flagGR qpn') : goals) fdeps + + -- Note: for 'Flagged' goals, we always insert, so later additions win. + -- This is important, because in general, if a goal is inserted twice, + -- the later addition will have better dependency information. + go rdeps goals ((Stanza sn@(SN qpn' _) t) : fdeps) = + go rdeps (StanzaGoal sn t (flagGR qpn') : goals) fdeps + + go rdeps goals ((Simple (LDep dr (Dep (PkgComponent qpn' _) _)) c) : fdeps) + | qpn' == qpn = + -- We currently only add a self-dependency to the graph if it is + -- between a package and its setup script. The edge creates a cycle + -- and causes the solver to backtrack and choose a different + -- instance for the setup script. We may need to track other + -- self-dependencies once we implement component-based solving. case c of - ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs - _ -> go g o ngs - | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs - | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs - -- code above is correct; insert/adjust have different arg order - go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs - go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs + ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn)) qpn' rdeps) goals fdeps + _ -> go rdeps goals fdeps + | qpn' `M.member` rdeps = + go (M.adjust (addIfAbsent (c, qpn)) qpn' rdeps) goals fdeps + | otherwise = + -- Note: insert/adjust have different arg order + go (M.insert qpn' [(c, qpn)] rdeps) (PkgGoal qpn' (DependencyGoal dr) : goals) fdeps + + go rdeps o ((Simple (LDep _dr (Ext _ext )) _c) : goals) = go rdeps o goals + go rdeps o ((Simple (LDep _dr (Lang _lang)) _c) : goals) = go rdeps o goals + go rdeps o ((Simple (LDep _dr (Pkg _pn _vr)) _c) : goals) = go rdeps o goals addIfAbsent :: Eq a => a -> [a] -> [a] addIfAbsent x xs = if x `elem` xs then xs else x : xs - -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by - -- its containing package. - flagGR :: qpn -> GoalReason qpn - flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) +-- GoalReason for a flag or stanza. Each flag/stanza is introduced only by +-- its containing package. +flagGR :: qpn -> GoalReason qpn +flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. @@ -127,12 +134,14 @@ build = ana go go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) go s = addLinking (linkingState s) $ addChildren (buildState s) +-- | Add children to the tree based on the current build state. addChildren :: BuildState -> TreeF () QGoalReason BuildState -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) + -- No goals left. We have done. | L.null gs = DoneF rdm () | otherwise = GoalChoiceF rdm $ P.fromList $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) @@ -254,16 +263,17 @@ buildTree idx igs = build Linker { buildState = BS { index = idx - , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) - , open = L.map topLevelGoal qpns + , rdeps = M.fromList [(qpn, []) | qpn <- qpns] + , open = [ PkgGoal qpn UserGoal | qpn <- qpns ] , next = Goals } , linkingState = M.empty } where - topLevelGoal qpn = PkgGoal qpn UserGoal + -- The package names are interpreted as top-level goals in the host stage. + path = PackagePath Stage.Host QualToplevel + qpns = [ Q path pn | pn <- igs ] - qpns = L.map (Q (PackagePath Stage.Host QualToplevel)) igs {------------------------------------------------------------------------------- Goals diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 6a91197823e..dbd47c1dcc9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs @@ -90,14 +90,36 @@ type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. +-- +-- Note: this is a recursive data structure representing a tree of dependencies. +-- +-- Note 2: why LDep contains its own DependencyReason? I am thinking it should +-- be external to this type. Basically you traverse the tree and the flag and +-- stanza choices are the DepedencyReason? data FlaggedDep qpn = -- | Dependencies which are conditional on a flag choice. - Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - | -- | Dependencies which are conditional on whether or not a stanza + Flagged + (FN qpn) + -- ^ The qualified flag name. + FInfo + -- ^ The flag information. + (FlaggedDeps qpn) + -- ^ Extra dependencies when the flag is true. + (FlaggedDeps qpn) + -- ^ Extra dependencies when the flag is false. + | -- | Dependencies which are conditional on whether or not a stanza. -- (e.g., a test suite or benchmark) is enabled. - Stanza (SN qpn) (TrueFlaggedDeps qpn) - | -- | Dependencies which are always enabled, for the component 'comp'. - Simple (LDep qpn) Component + Stanza + (SN qpn) + -- ^ The qualified stanza name. + (FlaggedDeps qpn) + -- ^ Extra dependencies when stanza is enabled. + | -- | Dependencies which are always enabled. + Simple + (LDep qpn) + -- ^ The dependency. + Component + -- ^ The component of `qpn` introducing the dependency. deriving Show -- | Conservatively flatten out flagged dependencies @@ -111,16 +133,18 @@ flattenFlaggedDeps = concatMap aux aux (Stanza _ t) = flattenFlaggedDeps t aux (Simple d c) = [(d, c)] -type TrueFlaggedDeps qpn = FlaggedDeps qpn -type FalseFlaggedDeps qpn = FlaggedDeps qpn - -- | A 'Dep' labeled with the reason it was introduced. -- -- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- 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) +data LDep qpn + = LDep + (DependencyReason qpn) + -- ^ The reason the dependency was introduced. + (Dep qpn) + -- ^ The dependency itself. deriving Show -- | A dependency (constraint) associates a package name with a constrained @@ -139,21 +163,35 @@ data 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 +data PkgComponent qpn + = PkgComponent + qpn + -- ^ The qualified name of the package. + ExposedComponent + -- ^ The component exposed by the package. deriving (Eq, Ord, Functor, Show) -- | A component that can be depended upon by another package, i.e., a library -- or an executable. data ExposedComponent - = ExposedLib LibraryName - | ExposedExe UnqualComponentName + = -- | A library component + ExposedLib LibraryName + | -- | An executable component + ExposedExe UnqualComponentName deriving (Eq, Ord, Show) -- | 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) +data DependencyReason qpn + = DependencyReason + qpn + -- ^ The qualified name of the dependent package. + (Map Flag FlagValue) + -- ^ The flag choices that introduced the dependency. + (S.Set Stanza) + -- ^ The stanza choices that introduced the dependency. deriving (Functor, Eq, Show) -- | Print the reason that a dependency was introduced. diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs index 28ed5c9cd2d..3833c95de69 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Index.hs @@ -31,10 +31,15 @@ type Index = Map PN (Map I PInfo) -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) - (Map ExposedComponent ComponentInfo) - FlagInfo - (Maybe FailReason) +data PInfo = PInfo + (FlaggedDeps PN) + -- ^ The package dependencies, whether they are conditional on a flag, a + -- stanza or always active. + (Map ExposedComponent ComponentInfo) + -- ^ Info associated with each library and executable component. + FlagInfo + -- + (Maybe FailReason) -- | Info associated with each library and executable in a package instance. data ComponentInfo = ComponentInfo { diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs index 36aef5ebac7..b406e2c1b83 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs @@ -49,19 +49,52 @@ type Weight = Double -- -- TODO: The weight type should be changed from [Double] to Double to avoid -- giving too much weight to preferences that are applied later. -data Tree d c = - -- | Choose a version for a package (or choose to link) - PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) +-- +-- Note: this the tree *of possible choices*, which is used to explore all +-- possible solutions to a given problem. It does not describe a single solution. +data Tree d c + = -- | Choose a version for a package (or choose to link) + PChoice + QPN + -- ^ The package to choose an instance for + RevDepMap + -- ^ The reverse dependency map (FIXME ?) + c + -- ^ Additional data for the choice node + (WeightedPSQ [Weight] POption (Tree d c)) + -- ^ Weighted list of possible options (`POption`) paired with the subsequent search tree. - -- | Choose a value for a flag - -- - -- The Bool is the default value. - | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose a value for a flag. + FChoice + QFN + -- ^ The flag to choose a value for. + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + c + -- ^ Additional data for the choice node. + WeakOrTrivial + -- ^ Whether the choice should be deferred. + FlagType + -- ^ Whether the flag is manual or automatic. + Bool + -- ^ The flag default value + (WeightedPSQ [Weight] Bool (Tree d c)) + -- ^ Weighted list of possible options paired with the subsequent search tree. - -- | Choose whether or not to enable a stanza - | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) + | -- | Choose whether or not to enable a stanza. + SChoice + QSN + -- ^ The stanza to choose to enable or disable. + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + c + -- ^ Additional data for the choice node. + WeakOrTrivial + -- ^ Whether the choice should be deferred. + (WeightedPSQ [Weight] Bool (Tree d c)) + -- ^ Weighted list of possible options paired with the subsequent search tree. - -- | Choose which choice to make next + | -- | Choose which choice to make next -- -- Invariants: -- @@ -72,13 +105,25 @@ data Tree d c = -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. - | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) + GoalChoice + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + (PSQ (Goal QPN) (Tree d c)) + -- ^ Priority search queue associating a goal with the search tree. - -- | We're done -- we found a solution! - | Done RevDepMap d + | -- | We're done -- we found a solution! + Done + RevDepMap + -- ^ The reverse dependency map (FIXME ?). + d + -- ^ The solution. - -- | We failed to find a solution in this path through the tree - | Fail ConflictSet FailReason + | -- | We failed to find a solution in this path through the tree + Fail + ConflictSet + -- ^ The conflict set. + FailReason + -- ^ The reason for failure. -- | A package option is a package instance with an optional linking annotation -- @@ -96,7 +141,12 @@ data Tree d c = -- dependencies must also be the exact same). -- -- See for details. -data POption = POption I (Maybe PackagePath) +data POption + = POption + I + -- ^ The choosen package instance. + (Maybe PackagePath) + -- ^ The package this choice is linked to (if any). deriving (Eq, Show) data FailReason = UnsupportedExtension Extension @@ -132,7 +182,14 @@ data FailReason = UnsupportedExtension Extension deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI +data ConflictingDep + = ConflictingDep + (DependencyReason QPN) + -- ^ The reason for the dependency. + (PkgComponent QPN) + -- ^ The component of the package that caused the conflict. + CI + -- ^ The constrained instance. deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' From 30ce81d8a5f8384c0e73a99d91c843d071b268f1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 2 Jul 2025 13:11:36 +0800 Subject: [PATCH 027/122] feat(cabal-install, cabal-install-solver): track stage in SolverId --- .../Solver/Modular/ConfiguredConversion.hs | 8 ++++---- .../Distribution/Solver/Types/ResolverPackage.hs | 15 +++++++++++++-- .../src/Distribution/Solver/Types/SolverId.hs | 13 ++++++++----- cabal-install/src/Distribution/Client/Freeze.hs | 12 ++++++++++-- .../src/Distribution/Client/InstallPlan.hs | 9 +++++---- .../src/Distribution/Client/ProjectPlanning.hs | 11 ++++++----- 6 files changed, 46 insertions(+), 22 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs index 72eedf3ceaa..af78f678712 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -57,9 +57,9 @@ convCP iidx sidx (CP qpi fa es ds) = ds' = fmap (partitionEithers . map convConfId) ds convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} -convConfId (PI (Q (PackagePath _stage q) pn) (I _stage' v loc)) = +convConfId (PI (Q (PackagePath _stage q) pn) (I stage v loc)) = case loc of - Inst pi -> Left (PreExistingId sourceId pi) + Inst pi -> Left (PreExistingId stage sourceId pi) _otherwise | QualExe _ pn' <- q -- NB: the dependencies of the executable are also @@ -68,7 +68,7 @@ convConfId (PI (Q (PackagePath _stage q) pn) (I _stage' v loc)) = -- at the actual thing. Fortunately for us, I was -- silly and didn't allow arbitrarily nested build-tools -- dependencies, so a shallow check works. - , pn == pn' -> Right (PlannedId sourceId) - | otherwise -> Left (PlannedId sourceId) + , pn == pn' -> Right (PlannedId stage sourceId) + | otherwise -> Left (PlannedId stage sourceId) where sourceId = PackageIdentifier pn v diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs index 840e58aff94..c7b57da9b76 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ResolverPackage.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ResolverPackage ( ResolverPackage(..) + , solverId + , solverQPN , resolverPackageLibDeps , resolverPackageExeDeps ) where @@ -12,6 +14,7 @@ import Prelude () import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.PackagePath (QPN) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Compat.Graph (IsNode(..)) @@ -34,6 +37,14 @@ instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg +solverId :: ResolverPackage loc -> SolverId +solverId (PreExisting ipkg) = PreExistingId (instSolverStage ipkg) (packageId ipkg) (installedUnitId ipkg) +solverId (Configured spkg) = PlannedId (solverPkgStage spkg) (packageId spkg) + +solverQPN :: ResolverPackage loc -> QPN +solverQPN (PreExisting ipkg) = instSolverQPN ipkg +solverQPN (Configured spkg) = solverPkgQPN spkg + resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg @@ -44,8 +55,8 @@ resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId - nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) - nodeKey (Configured spkg) = PlannedId (packageId spkg) + nodeKey = solverId + -- Use dependencies for ALL components nodeNeighbors pkg = ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index 1141530c7c4..9afb8bf1338 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -10,15 +10,18 @@ import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) import Distribution.Pretty (Pretty (..)) -import Text.PrettyPrint (parens) +import Distribution.Solver.Types.Stage (Stage) + +import Text.PrettyPrint (colon, punctuate, text) + -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't -- yet know the 'UnitId' for planned packages, because it's -- not the solver's job to compute them. -- -data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } - | PlannedId { solverSrcId :: PackageId } +data SolverId = PreExistingId { solverStage :: Stage, solverSrcId :: PackageId, solverInstId :: UnitId } + | PlannedId { solverStage :: Stage, solverSrcId :: PackageId } deriving (Eq, Ord, Generic) instance Binary SolverId @@ -31,5 +34,5 @@ instance Package SolverId where packageId = solverSrcId instance Pretty SolverId where - pretty (PreExistingId pkg unitId) = pretty pkg <+> parens (pretty unitId) - pretty (PlannedId pkg) = pretty pkg \ No newline at end of file + pretty (PreExistingId stage pkg unitId) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "installed", pretty unitId] + pretty (PlannedId stage pkg) = mconcat $ punctuate colon $ [pretty stage, pretty pkg, text "planned"] \ No newline at end of file diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index 42f2a89b386..d9c47bb6da9 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -51,7 +51,9 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb +import Distribution.Solver.Types.ResolverPackage (solverId) import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.SolverPackage (SolverPackage (..)) import qualified Distribution.Solver.Types.Stage as Stage import Distribution.Client.Errors @@ -285,9 +287,15 @@ pruneInstallPlan installPlan pkgSpecifiers = removeSelf pkgIds $ SolverInstallPlan.dependencyClosure installPlan pkgIds where + -- Get the source packages from the (specific) package specifiers. + srcpkgs :: [UnresolvedSourcePackage] + srcpkgs = [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] + -- Get the 'SolverId's of the packages we are freezing. + pkgIds :: [SolverId] pkgIds = - [ PlannedId (packageId pkg) - | SpecificSourcePackage pkg <- pkgSpecifiers + [ solverId (SolverInstallPlan.Configured pkg) + | SolverInstallPlan.Configured pkg <- SolverInstallPlan.toList installPlan + , solverPkgSource pkg `elem` srcpkgs ] removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg) removeSelf _ = diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 00aa273e67b..d247dab9e3f 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -557,8 +557,9 @@ fromSolverInstallPlanWithProgress f plan = do pkgs' <- f (mapDep pidMap ipiMap) pkg let (pidMap', ipiMap') = case nodeKey pkg of - PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap) + -- FIXME: stage is ignored + PreExistingId _stage _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) + PlannedId _stage pid -> (Map.insert pid pkgs' pidMap, ipiMap) return (pidMap', ipiMap', pkgs' ++ pkgs) -- The error below shouldn't happen, since mapDep should only @@ -566,10 +567,10 @@ fromSolverInstallPlanWithProgress f plan = do -- already by the reverse top-sort (we assume the graph is not broken). -- -- FIXME: stage is ignored - mapDep _ ipiMap (PreExistingId _pid uid) + mapDep _ ipiMap (PreExistingId _stage _pid uid) | Just pkgs <- Map.lookup uid ipiMap = pkgs | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId pid) + mapDep pidMap _ (PlannedId _stage pid) | Just pkgs <- Map.lookup pid pidMap = pkgs | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 92e7ddf04af..9527211f152 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2455,11 +2455,12 @@ elaborateInstallPlan pkgsToBuildInplaceOnly :: Set PackageId pkgsToBuildInplaceOnly = - Set.fromList $ - map packageId $ - SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) + Set.fromList + [ packageId pkg + | stage <- stages + , let solverIds = [PlannedId stage pkgId | pkgId <- Set.toList pkgsLocalToProject] + , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan solverIds + ] isLocalToProject :: Package pkg => pkg -> Bool isLocalToProject pkg = From c6fe9d05d47988c23ebbe68b756409f0c80d980d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 1 May 2025 11:15:24 +0800 Subject: [PATCH 028/122] fix(cabal-install): rewrite dependencyInconsistencies --- .../Distribution/Client/SolverInstallPlan.hs | 29 ++++++++++--------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index b35cc344bdc..1aecb7e4512 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -56,11 +56,7 @@ import Prelude () import Distribution.Package ( HasUnitId (..) , Package (..) - , PackageId , PackageIdentifier (..) - , PackageName - , packageName - , packageVersion ) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Types.Flag (nullFlagAssignment) @@ -68,10 +64,8 @@ import Distribution.Types.Flag (nullFlagAssignment) import Distribution.Client.Types ( UnresolvedPkgLoc ) -import Distribution.Version - ( Version - ) +import Distribution.Solver.Types.PackagePath (QPN) import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage @@ -189,7 +183,7 @@ data SolverPlanProblem SolverPlanPackage [PackageIdentifier] | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageInconsistency QPN [(SolverId, SolverId)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage showPlanProblem :: SolverPlanProblem -> String @@ -210,7 +204,7 @@ showPlanProblem (PackageInconsistency name inconsistencies) = [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) + ++ prettyShow ver | (pkg, ver) <- inconsistencies ] showPlanProblem (PackageStateInvalid pkg pkg') = @@ -267,7 +261,7 @@ problems index = -- for them here. dependencyInconsistencies :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] + -> [(QPN, [(SolverId, SolverId)])] dependencyInconsistencies index = concatMap dependencyInconsistencies' subplans where @@ -318,6 +312,8 @@ rootSets index = [libRoots] ++ setupRoots index -- -- The library roots are the set of packages with no reverse dependencies -- (no reverse library dependencies but also no reverse setup dependencies). +-- +-- FIXME: misleading name, this includes executables too! libraryRoots :: SolverPlanIndex -> [SolverId] libraryRoots index = map (nodeKey . toPkgId) roots @@ -345,9 +341,14 @@ setupRoots = -- distinct. dependencyInconsistencies' :: SolverPlanIndex - -> [(PackageName, [(PackageIdentifier, Version)])] + -> [(QPN, [(SolverId, SolverId)])] dependencyInconsistencies' index = - [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids]) + [ ( name + , [ (sid, solverId dep) + | (dep, sids) <- uses + , sid <- sids + ] + ) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map , length uses > 1 @@ -357,11 +358,11 @@ dependencyInconsistencies' index = -- and each installed ID of that package -- the associated package instance -- and a list of reverse dependencies (as source IDs) - inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId])) + inverseIndex :: Map QPN (Map SolverId (SolverPlanPackage, [SolverId])) inverseIndex = Map.fromListWith (Map.unionWith (\(a, b) (_, b') -> (a, b ++ b'))) - [ (packageName dep, Map.fromList [(sid, (dep, [packageId pkg]))]) + [ (solverQPN dep, Map.fromList [(sid, (dep, [solverId pkg]))]) | -- For each package @pkg@ pkg <- Foldable.toList index , -- Find out which @sid@ @pkg@ depends on From 9936f55bc566651f942a1b0dead1b7b66a93c67f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 23 Jun 2025 17:59:22 +0800 Subject: [PATCH 029/122] refactor(cabal-install-solver): refactor modularResolver --- .../src/Distribution/Solver/Modular.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index 1b23cd80d44..e8426add2f7 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular.hs @@ -22,7 +22,7 @@ import Distribution.Compat.Graph import Distribution.Compiler ( CompilerInfo ) import Distribution.Solver.Modular.Assignment - ( Assignment, toCPs ) + ( Assignment(..), toCPs ) import Distribution.Solver.Modular.ConfiguredConversion ( convCP ) import qualified Distribution.Solver.Modular.ConflictSet as CS @@ -81,7 +81,12 @@ import Distribution.Verbosity ( normal, verbose ) -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do - uncurry postprocess <$> solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + (assignment, revdepmap) <- solve' sc cinfo pkgConfigDbs idx pprefs gcs pns + + -- Results have to be converted into an install plan. 'convCP' removes + -- package qualifiers, which means that linked packages become duplicates + -- and can be removed. + return $ ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs assignment revdepmap) where cinfo = fst <$> toolchains @@ -92,12 +97,6 @@ modularResolver sc toolchains pkgConfigDbs iidx sidx pprefs pcs pns = do 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) - -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN pcName (PackageConstraint scope _) = scopeToPackageName scope From 7579565bb67047e01b83f2e28dbdd6654f68b1de Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 12:23:15 +0800 Subject: [PATCH 030/122] refactor(cabal-install): generalise GenericInstallPlan to arbitrary node keys --- Cabal/src/Distribution/Utils/LogProgress.hs | 1 + .../src/Distribution/Client/InstallPlan.hs | 243 +++++++++++------- .../Distribution/Client/ProjectBuilding.hs | 21 +- .../Client/ProjectOrchestration.hs | 5 +- .../Client/ProjectPlanning/Types.hs | 3 +- .../Distribution/Client/InstallPlan.hs | 13 +- 6 files changed, 179 insertions(+), 107 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 0968a136372..b1a3e7168f0 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -9,6 +9,7 @@ module Distribution.Utils.LogProgress , infoProgress , dieProgress , addProgressCtx + , ErrMsg ) where import Distribution.Compat.Prelude diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index d247dab9e3f..fc36c007365 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1,7 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -25,7 +28,6 @@ module Distribution.Client.InstallPlan , PlanPackage , GenericPlanPackage (..) , foldPlanPackage - , IsUnit -- * Operations on 'InstallPlan's , new @@ -69,6 +71,7 @@ module Distribution.Client.InstallPlan , dependencyClosure , reverseTopologicalOrder , reverseDependencyClosure + , IsGraph (..) ) where import Distribution.Client.Compat.Prelude hiding (lookup, toList) @@ -90,7 +93,6 @@ import Distribution.Package ( HasMungedPackageId (..) , HasUnitId (..) , Package (..) - , UnitId ) import Distribution.Pretty (defaultStyle) import Distribution.Solver.Types.SolverPackage @@ -109,11 +111,15 @@ import Distribution.Utils.Structured (Structure (Nominal), Structured (..)) import Control.Exception ( assert ) +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import qualified Data.Foldable as Foldable (all, toList) import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. @@ -172,38 +178,33 @@ data GenericPlanPackage ipkg srcpkg = PreExisting ipkg | Configured srcpkg | Installed srcpkg - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Traversable, Foldable, Functor) -displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String -displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) -displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) +instance Bifunctor GenericPlanPackage where + bimap f _ (PreExisting ipkg) = PreExisting (f ipkg) + bimap _ g (Configured srcpkg) = Configured (g srcpkg) + bimap _ g (Installed srcpkg) = Installed (g srcpkg) --- | Convenience combinator for destructing 'GenericPlanPackage'. --- This is handy because if you case manually, you have to handle --- 'Configured' and 'Installed' separately (where often you want --- them to be the same.) -foldPlanPackage - :: (ipkg -> a) - -> (srcpkg -> a) - -> GenericPlanPackage ipkg srcpkg - -> a -foldPlanPackage f _ (PreExisting ipkg) = f ipkg -foldPlanPackage _ g (Configured srcpkg) = g srcpkg -foldPlanPackage _ g (Installed srcpkg) = g srcpkg +instance Bifoldable GenericPlanPackage where + bifoldMap f _ (PreExisting ipkg) = f ipkg + bifoldMap _ g (Configured srcpkg) = g srcpkg + bifoldMap _ g (Installed srcpkg) = g srcpkg -type IsUnit a = (IsNode a, Key a ~ UnitId) +instance Bitraversable GenericPlanPackage where + bitraverse f _ (PreExisting ipkg) = PreExisting <$> f ipkg + bitraverse _ g (Configured srcpkg) = Configured <$> g srcpkg + bitraverse _ g (Installed srcpkg) = Installed <$> g srcpkg -depends :: IsUnit a => a -> [UnitId] -depends = nodeNeighbors +-- I admit this is a bit awkward but I could not find a better way. --- NB: Expanded constraint synonym here to avoid undecidable --- instance errors in GHC 7.8 and earlier. -instance - (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId) - => IsNode (GenericPlanPackage ipkg srcpkg) - where - type Key (GenericPlanPackage ipkg srcpkg) = UnitId +class (IsNode a, IsNode b, Key a ~ Key b) => IsGraph a b where + type GraphKey a b + +instance (IsNode a, Key a ~ key, IsNode b, Key b ~ key) => IsGraph a b where + type GraphKey a b = Key a + +instance IsGraph ipkg srcpkg => IsNode (GenericPlanPackage ipkg srcpkg) where + type Key (GenericPlanPackage ipkg srcpkg) = GraphKey ipkg srcpkg nodeKey (PreExisting ipkg) = nodeKey ipkg nodeKey (Configured spkg) = nodeKey spkg nodeKey (Installed spkg) = nodeKey spkg @@ -214,11 +215,6 @@ instance instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) -type PlanPackage = - GenericPlanPackage - InstalledPackageInfo - (ConfiguredPackage UnresolvedPkgLoc) - instance (Package ipkg, Package srcpkg) => Package (GenericPlanPackage ipkg srcpkg) @@ -252,10 +248,38 @@ instance configuredId (Configured spkg) = configuredId spkg configuredId (Installed spkg) = configuredId spkg -data GenericInstallPlan ipkg srcpkg = GenericInstallPlan +displayGenericPlanPackage :: (IsNode ipkg, Key ipkg ~ key, IsNode srcpkg, Key srcpkg ~ key, Pretty key) => GenericPlanPackage ipkg srcpkg -> String +displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg) +displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg) + +-- | Convenience combinator for destructing 'GenericPlanPackage'. +-- This is handy because if you case manually, you have to handle +-- 'Configured' and 'Installed' separately (where often you want +-- them to be the same.) +foldPlanPackage + :: (ipkg -> a) + -> (srcpkg -> a) + -> GenericPlanPackage ipkg srcpkg + -> a +foldPlanPackage f _ (PreExisting ipkg) = f ipkg +foldPlanPackage _ g (Configured srcpkg) = g srcpkg +foldPlanPackage _ g (Installed srcpkg) = g srcpkg + +depends :: IsNode a => a -> [Key a] +depends = nodeNeighbors + +type PlanPackage = + GenericPlanPackage + InstalledPackageInfo + (ConfiguredPackage UnresolvedPkgLoc) + +data GenericInstallPlan' key ipkg srcpkg = GenericInstallPlan { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)) } +type GenericInstallPlan ipkg srcpkg = GenericInstallPlan' (GraphKey ipkg srcpkg) ipkg srcpkg + -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan @@ -264,7 +288,9 @@ type InstallPlan = -- | Smart constructor that deals with caching the 'Graph' representation. mkInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => String -> Graph (GenericPlanPackage ipkg srcpkg) -> GenericInstallPlan ipkg srcpkg @@ -282,7 +308,10 @@ internalError loc msg = ++ loc ++ if null msg then "" else ": " ++ msg -instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where +instance + (Typeable key, Structured ipkg, Structured srcpkg) + => Structured (GenericInstallPlan' key ipkg srcpkg) + where structure p = Nominal (typeRep p) @@ -293,14 +322,14 @@ instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ] instance - ( IsNode ipkg - , Key ipkg ~ UnitId - , IsNode srcpkg - , Key srcpkg ~ UnitId + ( IsGraph ipkg srcpkg + , key ~ GraphKey ipkg srcpkg , Binary ipkg , Binary srcpkg + , Pretty key + , Show key ) - => Binary (GenericInstallPlan ipkg srcpkg) + => Binary (GenericInstallPlan' key ipkg srcpkg) where put p = put (planGraph p) @@ -331,7 +360,11 @@ showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . pla showInstallPlan :: forall ipkg srcpkg - . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) + . ( IsGraph ipkg srcpkg + , Package ipkg + , Package srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => GenericInstallPlan ipkg srcpkg -> String showInstallPlan = showInstallPlan_gen toShow @@ -354,7 +387,9 @@ showPlanPackageTag (Installed _) = "Installed" -- | Build an installation plan from a valid set of resolved packages. new - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => Graph (GenericPlanPackage ipkg srcpkg) -> GenericInstallPlan ipkg srcpkg new = mkInstallPlan "new" @@ -371,13 +406,13 @@ toList = Foldable.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg - -> Map UnitId (GenericPlanPackage ipkg srcpkg) + -> Map (Key ipkg) (GenericPlanPackage ipkg srcpkg) toMap = Graph.toMap . planGraph -keys :: GenericInstallPlan ipkg srcpkg -> [UnitId] +keys :: GenericInstallPlan ipkg srcpkg -> [Key ipkg] keys = Graph.keys . planGraph -keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId +keysSet :: GenericInstallPlan ipkg srcpkg -> Set (Key ipkg) keysSet = Graph.keysSet . planGraph -- | Remove packages from the install plan. This will result in an @@ -386,7 +421,10 @@ keysSet = Graph.keysSet . planGraph -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. remove - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg @@ -403,7 +441,7 @@ remove shouldRemove plan = -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). installed - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => (srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg @@ -428,7 +466,7 @@ installed shouldBeInstalled installPlan = -- To preserve invariants, the package must have all of its dependencies -- already installed too (that is 'PreExisting' or 'Installed'). installedM - :: (IsUnit ipkg, IsUnit srcpkg, Monad m) + :: (IsGraph ipkg srcpkg, Monad m) => (srcpkg -> m Bool) -> GenericInstallPlan ipkg srcpkg -> m (GenericInstallPlan ipkg srcpkg) @@ -444,9 +482,9 @@ installedM shouldBeInstalled installPlan = do -- | Lookup a package in the plan. lookup - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> Maybe (GenericPlanPackage ipkg srcpkg) lookup plan pkgid = Graph.lookup pkgid (planGraph plan) @@ -455,7 +493,7 @@ lookup plan pkgid = Graph.lookup pkgid (planGraph plan) -- Note that the package must exist in the plan or it is an error. directDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] directDeps plan pkgid = case Graph.neighbors (planGraph plan) pkgid of @@ -467,7 +505,7 @@ directDeps plan pkgid = -- Note that the package must exist in the plan or it is an error. revDirectDeps :: GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] revDirectDeps plan pkgid = case Graph.revNeighbors (planGraph plan) pkgid of @@ -490,7 +528,7 @@ reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) -- the given packages. dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] dependencyClosure plan = fromMaybe [] @@ -500,7 +538,7 @@ dependencyClosure plan = -- given packages. reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] reverseDependencyClosure plan = fromMaybe [] @@ -520,7 +558,11 @@ reverseDependencyClosure plan = -- because that's not enough information. fromSolverInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( HasCallStack + , IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg] @@ -535,7 +577,10 @@ fromSolverInstallPlan f plan = plan fromSolverInstallPlanWithProgress - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> LogProgress [GenericPlanPackage ipkg srcpkg] @@ -658,7 +703,7 @@ configureInstallPlan configFlags solverPlan = -- and includes the set of packages that are in the processing state, e.g. in -- the process of being installed, plus those that have been completed and -- those where processing failed. -data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) +data Processing key = Processing !(Set key) !(Set key) !(Set key) -- processing, completed, failed @@ -671,9 +716,13 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) -- all the packages that are ready will now be processed and so we can consider -- them to be in the processing state. ready - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => GenericInstallPlan ipkg srcpkg - -> ([GenericReadyPackage srcpkg], Processing) + -> ([GenericReadyPackage srcpkg], Processing key) ready plan = assert (processingInvariant plan processing) $ (readyPackages, processing) @@ -699,11 +748,11 @@ isInstalled _ = False -- process), along with the updated 'Processing' state. completed :: forall ipkg srcpkg - . (IsUnit ipkg, IsUnit srcpkg) + . (IsGraph ipkg srcpkg, Ord (GraphKey ipkg srcpkg), Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg - -> Processing - -> UnitId - -> ([GenericReadyPackage srcpkg], Processing) + -> Processing (GraphKey ipkg srcpkg) + -> (GraphKey ipkg srcpkg) + -> ([GenericReadyPackage srcpkg], Processing (GraphKey ipkg srcpkg)) completed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert (processingInvariant plan processing') $ @@ -734,11 +783,11 @@ completed plan (Processing processingSet completedSet failedSet) pkgid = asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg failed - :: (IsUnit ipkg, IsUnit srcpkg) + :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg - -> Processing - -> UnitId - -> ([srcpkg], Processing) + -> Processing (GraphKey ipkg srcpkg) + -> GraphKey ipkg srcpkg + -> ([srcpkg], Processing (GraphKey ipkg srcpkg)) failed plan (Processing processingSet completedSet failedSet) pkgid = assert (pkgid `Set.member` processingSet) $ assert (all (`Set.notMember` processingSet) (drop 1 newlyFailedIds)) $ @@ -763,9 +812,13 @@ failed plan (Processing processingSet completedSet failedSet) pkgid = asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg processingInvariant - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => GenericInstallPlan ipkg srcpkg - -> Processing + -> Processing key -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) = -- All the packages in the three sets are actually in the graph @@ -844,7 +897,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) = -- source packages in the dependency graph, albeit not necessarily exactly the -- same ordering as that produced by 'reverseTopologicalOrder'. executionOrder - :: (IsUnit ipkg, IsUnit srcpkg) + :: (IsGraph ipkg srcpkg, Pretty (GraphKey ipkg srcpkg)) => GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg] executionOrder plan = @@ -866,15 +919,15 @@ executionOrder plan = -- ------------------------------------------------------------ -- | The set of results we get from executing an install plan. -type BuildOutcomes failure result = Map UnitId (Either failure result) +type BuildOutcomes key failure result = Map key (Either failure result) -- | Lookup the build result for a single package. lookupBuildOutcome - :: HasUnitId pkg + :: (IsNode pkg, Key pkg ~ key) => pkg - -> BuildOutcomes failure result + -> BuildOutcomes key failure result -> Maybe (Either failure result) -lookupBuildOutcome = Map.lookup . installedUnitId +lookupBuildOutcome = Map.lookup . nodeKey -- | Execute an install plan. This traverses the plan in dependency order. -- @@ -892,29 +945,30 @@ lookupBuildOutcome = Map.lookup . installedUnitId -- these will have no 'BuildOutcome'. execute :: forall m ipkg srcpkg result failure - . ( IsUnit ipkg - , IsUnit srcpkg + . ( IsGraph ipkg srcpkg , Monad m + , Pretty (Key srcpkg) ) - => JobControl m (UnitId, Either failure result) + => JobControl m (GraphKey ipkg srcpkg, Either failure result) -> Bool -- ^ Keep going after failure -> (srcpkg -> failure) -- ^ Value for dependents of failed packages -> GenericInstallPlan ipkg srcpkg -> (GenericReadyPackage srcpkg -> m (Either failure result)) - -> m (BuildOutcomes failure result) + -> m (BuildOutcomes (GraphKey ipkg srcpkg) failure result) execute jobCtl keepGoing depFailure plan installPkg = let (newpkgs, processing) = ready plan - in tryNewTasks Map.empty False False processing newpkgs + in tryNewTasks mempty False False processing newpkgs where tryNewTasks - :: BuildOutcomes failure result + :: (Pretty key, Key srcpkg ~ key) + => BuildOutcomes key failure result -> Bool -> Bool - -> Processing + -> Processing key -> [GenericReadyPackage srcpkg] - -> m (BuildOutcomes failure result) + -> m (BuildOutcomes key failure result) tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs -- we were in the process of cancelling and now we're finished @@ -941,11 +995,12 @@ execute jobCtl keepGoing depFailure plan installPkg = waitForTasks results tasksFailed processing waitForTasks - :: BuildOutcomes failure result + :: (Pretty key, Key srcpkg ~ key) + => BuildOutcomes key failure result -> Bool - -> Processing - -> m (BuildOutcomes failure result) - waitForTasks !results tasksFailed !processing = do + -> Processing key + -> m (BuildOutcomes key failure result) + waitForTasks results tasksFailed !processing = do (pkgid, result) <- collectJob jobCtl case result of @@ -988,7 +1043,9 @@ execute jobCtl keepGoing depFailure plan installPkg = -- -- * if the result is @False@ use 'problems' to get a detailed list. valid - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool @@ -998,14 +1055,16 @@ valid loc graph = ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) data PlanProblem ipkg srcpkg - = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId] + = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [GraphKey ipkg srcpkg] | PackageCycle [GenericPlanPackage ipkg srcpkg] | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) (GenericPlanPackage ipkg srcpkg) showPlanProblem - :: (IsUnit ipkg, IsUnit srcpkg) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) => PlanProblem ipkg srcpkg -> String showPlanProblem (PackageMissingDeps pkg missingDeps) = @@ -1031,7 +1090,7 @@ showPlanProblem (PackageStateInvalid pkg pkg') = -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. problems - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg] problems graph = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 222edd55522..87ae3ddc7a6 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -58,7 +58,6 @@ import Distribution.Client.GlobalFlags (RepoContext) import Distribution.Client.InstallPlan ( GenericInstallPlan , GenericPlanPackage - , IsUnit ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl @@ -259,21 +258,26 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. foldMInstallPlanDepOrder - :: forall m ipkg srcpkg b - . (Monad m, IsUnit ipkg, IsUnit srcpkg) + :: forall m ipkg srcpkg b key + . ( Monad m + , IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + ) => ( GenericPlanPackage ipkg srcpkg -> [b] -> m b ) -> GenericInstallPlan ipkg srcpkg - -> m (Map UnitId b) + -> m (Map key b) foldMInstallPlanDepOrder visit = go Map.empty . InstallPlan.reverseTopologicalOrder where go - :: Map UnitId b + :: Map key b -> [GenericPlanPackage ipkg srcpkg] - -> m (Map UnitId b) + -> m (Map key b) go !results [] = return results go !results (pkg : pkgs) = do -- we go in the right order so the results map has entries for all deps @@ -298,7 +302,7 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus = where canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool canPackageBeImproved pkg = - case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + case Map.lookup (nodeKey pkg) pkgsBuildStatus of Just BuildStatusUpToDate{} -> True Just _ -> False Nothing -> @@ -384,8 +388,7 @@ rebuildTargets $ \pkg -> -- TODO: review exception handling handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do - let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus + let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus rebuildTarget verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 4c3e65aa4ea..2db062816e2 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -108,6 +108,7 @@ import Distribution.Client.Compat.Prelude import Distribution.Compat.Directory ( makeAbsolute ) +import qualified Distribution.Compat.Graph as Graph import Prelude () import Distribution.Client.ProjectBuilding @@ -1442,7 +1443,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes case reason of DownloadFailed _ -> "Failed to download " ++ pkgstr UnpackFailed _ -> "Failed to unpack " ++ pkgstr - ConfigureFailed _ -> "Failed to build " ++ pkgstr + ConfigureFailed _ -> "Failed to configure " ++ pkgstr BuildFailed _ -> "Failed to build " ++ pkgstr ReplFailed _ -> "repl failed for " ++ pkgstr HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr @@ -1452,7 +1453,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes GracefulFailure msg -> msg DependentFailed depid -> "Failed to build " - ++ prettyShow (packageId pkg) + ++ prettyShow (Graph.nodeKey pkg) ++ " because it depends on " ++ prettyShow depid ++ " which itself failed to build" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index fd1b0766eb2..ab1fc8be09c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -131,6 +131,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Monoid as Mon +import qualified Distribution.Compat.Graph as Graph import System.FilePath (()) import Text.PrettyPrint (hsep, parens, text) @@ -532,7 +533,7 @@ elabConfiguredName verbosity elab Just (CLibName LMainLibName) -> "" Just cname -> prettyShow cname ++ " from " ) - ++ prettyShow (packageId elab) + ++ prettyShow (Graph.nodeKey elab) | otherwise = prettyShow (elabUnitId elab) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index 920aa0ce1aa..aff2318dab7 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} @@ -6,7 +8,7 @@ module UnitTests.Distribution.Client.InstallPlan (tests) where import Distribution.Client.Compat.Prelude -import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) +import Distribution.Client.InstallPlan (GenericInstallPlan) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl import Distribution.Client.Types @@ -223,8 +225,13 @@ arbitraryTestInstallPlan = do -- It takes generators for installed and source packages and the chance that -- each package is installed (for those packages with no prerequisites). arbitraryInstallPlan - :: ( IsUnit ipkg - , IsUnit srcpkg + :: forall ipkg srcpkg key + . ( IsNode ipkg + , Key ipkg ~ key + , IsNode srcpkg + , Key srcpkg ~ key + , Show key + , Pretty key ) => (Vertex -> [Vertex] -> Gen ipkg) -> (Vertex -> [Vertex] -> Gen srcpkg) From d6cceffbefcaa69450c40685bc4e8743a9dd42f1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 6 May 2025 15:01:33 +0800 Subject: [PATCH 031/122] chore(Cabal): update reference to backpack-include field, now called mixin --- Cabal/src/Distribution/Backpack/ConfiguredComponent.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs index 947c370f16f..6c512ed1c5b 100644 --- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -94,7 +94,7 @@ dispConfiguredComponent cc = -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary --- work this does is handling implicit @backpack-include@ fields. +-- work this does is handling implicit @mixin@ fields. mkConfiguredComponent :: PackageDescription -> ComponentId @@ -121,7 +121,7 @@ mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do } -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. + -- @mixin@ is converted into an "implicit" include. let used_explicitly = Set.fromList (map ci_id explicit_includes) implicit_includes = map From a4d641a455ee0aeb0780efe934350207c9628c84 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 25 Jun 2025 16:41:51 +0800 Subject: [PATCH 032/122] feat: add a bunch of HasCallStack --- Cabal-syntax/src/Distribution/Compat/Graph.hs | 3 ++- .../Distribution/Backpack/ComponentsGraph.hs | 4 +++- Cabal/src/Distribution/Backpack/Configure.hs | 11 +++++++---- Cabal/src/Distribution/Simple/Configure.hs | 4 +++- .../src/Distribution/Types/LocalBuildInfo.hs | 3 ++- .../src/Distribution/Solver/Modular/Cycles.hs | 5 +++-- .../src/Distribution/Client/Dependency.hs | 4 +++- .../Distribution/Client/ProjectPlanOutput.hs | 6 ++++-- .../Distribution/Client/ProjectPlanning.hs | 19 +++++++++++++------ .../Distribution/Client/SolverInstallPlan.hs | 4 +++- 10 files changed, 43 insertions(+), 20 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index c716563f52a..5d7dfcf5d56 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -104,6 +104,7 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tree as Tree import qualified Distribution.Compat.Prelude as Prelude +import GHC.Stack (HasCallStack) -- | A graph of nodes @a@. The nodes are expected to have instance -- of class 'IsNode'. @@ -377,7 +378,7 @@ fromMap m = bounds = (0, Map.size m - 1) -- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. -fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a +fromDistinctList :: HasCallStack => (IsNode a, Show (Key a)) => [a] -> Graph a fromDistinctList = fromMap . Map.fromListWith (\_ -> duplicateError) diff --git a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs index aef3db817c6..6ce25d2a323 100644 --- a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs +++ b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs @@ -22,6 +22,7 @@ import Distribution.Types.ComponentRequestedSpec import Distribution.Utils.Generic import Distribution.Pretty (pretty) +import GHC.Stack (HasCallStack) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -50,7 +51,8 @@ dispComponentsWithDeps graph = -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem. mkComponentsGraph - :: ComponentRequestedSpec + :: HasCallStack + => ComponentRequestedSpec -> PackageDescription -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr = diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index 55d1ae03254..aec217ebd22 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -54,6 +54,7 @@ import Data.Either import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Pretty +import GHC.Stack (HasCallStack) import Text.PrettyPrint ------------------------------------------------------------------------------ @@ -61,7 +62,8 @@ import Text.PrettyPrint ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity + :: HasCallStack + => Verbosity -> Bool -- use_external_internal_deps -> ComponentRequestedSpec -> Bool -- deterministic @@ -206,7 +208,8 @@ configureComponentLocalBuildInfos ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler + :: HasCallStack + => Compiler -> InstalledPackageIndex -- FULL set -> [ConfiguredPromisedComponent] -> PackageDescription @@ -232,12 +235,12 @@ toComponentLocalBuildInfos -- since we will pay for the ALL installed packages even if -- they are not related to what we are building. This was true -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent) external_graph = Graph.fromDistinctList . map Left $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent) internal_graph = Graph.fromDistinctList . map Right diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 08fb14520d7..80faf3edae0 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -183,6 +183,7 @@ import Text.PrettyPrint import qualified Data.Maybe as M import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NES +import GHC.Stack (HasCallStack) type UseExternalInternalDeps = Bool @@ -1208,7 +1209,8 @@ finalCheckPackage enabled configureComponents - :: LBC.LocalBuildConfig + :: HasCallStack + => LBC.LocalBuildConfig -> LBC.PackageBuildDescr -> PackageInfo -> ([PreExistingComponent], [ConfiguredPromisedComponent]) diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs index 854f454dc87..de95e66f292 100644 --- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -131,6 +131,7 @@ import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack (HasCallStack) import qualified System.FilePath as FilePath (takeDirectory) -- | Data cached after configuration step. See also @@ -415,7 +416,7 @@ withAllTargetsInBuildOrder' pkg_descr lbi f = -- the order they need to be built. -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. -neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] +neededTargetsInBuildOrder' :: HasCallStack => PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids = case Graph.closure compsGraph uids of Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs index b82e39a0d26..c2229a27ada 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs @@ -15,6 +15,7 @@ import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath +import GHC.Stack (HasCallStack) -- | Find and reject any nodes with cyclic dependencies detectCyclesPhase :: Tree d c -> Tree d c @@ -51,7 +52,7 @@ detectCyclesPhase = go -- all decisions that could potentially break the cycle. -- -- TODO: The conflict set should also contain flag and stanza variables. -findCycles :: QPN -> RevDepMap -> Maybe ConflictSet +findCycles :: HasCallStack => QPN -> RevDepMap -> Maybe ConflictSet findCycles pkg rdm = -- This function has two parts: a faster cycle check that is called at every -- step and a slower calculation of the conflict set. @@ -115,6 +116,6 @@ instance G.IsNode RevDepMapNode where nodeKey (RevDepMapNode qpn _) = qpn nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns -revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode +revDepMapToGraph :: HasCallStack => RevDepMap -> G.Graph RevDepMapNode revDepMapToGraph rdm = G.fromDistinctList [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index 01e804f4898..1cf232ee340 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -173,6 +173,7 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Stack (HasCallStack) import Text.PrettyPrint -- ------------------------------------------------------------ @@ -904,7 +905,8 @@ interpretPackagesPreference selected defaultPref prefs = -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. validateSolverResult - :: Staged (CompilerInfo, Platform) + :: HasCallStack + => Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] -> SolverInstallPlan validateSolverResult toolchains pkgs = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index c1ab2473d94..c70e45f8f8d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -77,6 +77,7 @@ import System.FilePath import System.IO import Distribution.Simple.Program.GHC (packageDbArgsDb) +import GHC.Stack (HasCallStack) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -529,7 +530,8 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- | Work out which packages are out of date or invalid after a build. postBuildProjectStatus - :: ElaboratedInstallPlan + :: HasCallStack + => ElaboratedInstallPlan -> PackagesUpToDate -> BuildStatusMap -> BuildOutcomes @@ -626,7 +628,7 @@ postBuildProjectStatus ) -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph :: HasCallStack => Graph (Node UnitId ElaboratedPlanPackage) packagesLibDepGraph = Graph.fromDistinctList [ Graph.N pkg (installedUnitId pkg) libdeps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 9527211f152..4a76597b644 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -232,6 +232,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.Errors import Distribution.Solver.Types.ProjectConfigPath +import GHC.Stack (HasCallStack) import System.Directory (getCurrentDirectory) import System.FilePath import qualified Text.PrettyPrint as Disp @@ -1694,7 +1695,8 @@ elaborateInstallPlan -- NB: We don't INSTANTIATE packages at this point. That's -- a post-pass. This makes it simpler to compute dependencies. elaborateSolverToComponents - :: (SolverId -> [ElaboratedPlanPackage]) + :: HasCallStack + => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ _ _ deps0 exe_deps0) = @@ -1831,7 +1833,8 @@ elaborateInstallPlan ++ " not implemented yet" buildComponent - :: ( ConfiguredComponentMap + :: HasCallStack + => ( ConfiguredComponentMap , LinkedComponentMap , Map ComponentId FilePath ) @@ -2767,7 +2770,8 @@ extractElabBuildStyle _ = BuildAndInstall -- we don't instantiate the same thing multiple times. -- instantiateInstallPlan - :: StoreDirLayout + :: HasCallStack + => StoreDirLayout -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan @@ -3298,7 +3302,8 @@ data TargetAction -- will prune differently depending on what is already installed (to -- implement "sticky" test suite enabling behavior). pruneInstallPlanToTargets - :: TargetAction + :: HasCallStack + => TargetAction -> Map UnitId [ComponentTarget] -> ElaboratedInstallPlan -> ElaboratedInstallPlan @@ -3394,7 +3399,8 @@ setRootTargets targetAction perPkgTargetsMap = -- are used only by unneeded optional stanzas. These pruned deps are only -- used for the dependency closure and are not persisted in this pass. pruneInstallPlanPass1 - :: [ElaboratedPlanPackage] + :: HasCallStack + => [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] pruneInstallPlanPass1 pkgs -- if there are repl targets, we need to do a bit more work @@ -3754,7 +3760,8 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- -- This is not always possible. pruneInstallPlanToDependencies - :: Set UnitId + :: HasCallStack + => Set UnitId -> ElaboratedInstallPlan -> Either CannotPruneDependencies diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 1aecb7e4512..69ae14704ed 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -76,6 +76,7 @@ import qualified Data.Graph as OldGraph import qualified Data.Map as Map import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph +import GHC.Stack (HasCallStack) type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc @@ -153,7 +154,8 @@ toMap = Graph.toMap . planIndex -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. remove - :: (SolverPlanPackage -> Bool) + :: HasCallStack + => (SolverPlanPackage -> Bool) -> SolverInstallPlan -> Either [SolverPlanProblem] From 7258a096be7ec78d595f0e0724fc79cd2bae41ed Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 19 May 2025 16:54:37 +0800 Subject: [PATCH 033/122] fix: use nodeKey in fromSolverInstallPlanWithProgress --- .../src/Distribution/Client/InstallPlan.hs | 25 ++++++------------- 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index fc36c007365..d60557c86ab 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -588,36 +588,25 @@ fromSolverInstallPlanWithProgress -> SolverInstallPlan -> LogProgress (GenericInstallPlan ipkg srcpkg) fromSolverInstallPlanWithProgress f plan = do - (_, _, pkgs'') <- + (_, pkgs'') <- foldM f' - (Map.empty, Map.empty, []) + (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) return $ mkInstallPlan "fromSolverInstallPlanWithProgress" (Graph.fromDistinctList pkgs'') where - f' (pidMap, ipiMap, pkgs) pkg = do - pkgs' <- f (mapDep pidMap ipiMap) pkg - let (pidMap', ipiMap') = - case nodeKey pkg of - -- FIXME: stage is ignored - PreExistingId _stage _ uid -> (pidMap, Map.insert uid pkgs' ipiMap) - PlannedId _stage pid -> (Map.insert pid pkgs' pidMap, ipiMap) - return (pidMap', ipiMap', pkgs' ++ pkgs) + f' (pMap, pkgs) pkg = do + pkgs' <- f (mapDep pMap) pkg + let pMap' = Map.insert (nodeKey pkg) pkgs' pMap + return (pMap', pkgs' ++ pkgs) -- The error below shouldn't happen, since mapDep should only -- be called on neighbor SolverId, which must have all been done -- already by the reverse top-sort (we assume the graph is not broken). - -- - -- FIXME: stage is ignored - mapDep _ ipiMap (PreExistingId _stage _pid uid) - | Just pkgs <- Map.lookup uid ipiMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid) - mapDep pidMap _ (PlannedId _stage pid) - | Just pkgs <- Map.lookup pid pidMap = pkgs - | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid) + mapDep pMap key = fromMaybe (error ("fromSolverInstallPlanWithProgress: " ++ prettyShow key)) (Map.lookup key pMap) -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' From fa7d943e6c775cdd16b5a2f6594dfdfd25831844 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 5 May 2025 16:31:02 +0800 Subject: [PATCH 034/122] propagate stage trough elaborateProjectPlanning available targets are only host --- .../src/Distribution/Client/CmdGenBounds.hs | 10 +- .../Distribution/Client/CmdHaddockProject.hs | 12 +- .../src/Distribution/Client/CmdInstall.hs | 15 +- .../src/Distribution/Client/CmdListBin.hs | 6 +- .../src/Distribution/Client/CmdPath.hs | 2 - .../src/Distribution/Client/CmdRepl.hs | 43 +- .../src/Distribution/Client/CmdRun.hs | 13 +- .../src/Distribution/Client/CmdTarget.hs | 6 +- .../src/Distribution/Client/Errors.hs | 3 +- .../src/Distribution/Client/PackageHash.hs | 17 +- .../Distribution/Client/ProjectBuilding.hs | 9 +- .../Client/ProjectBuilding/Types.hs | 8 +- .../Client/ProjectOrchestration.hs | 67 ++- .../Distribution/Client/ProjectPlanOutput.hs | 103 ++-- .../Distribution/Client/ProjectPlanning.hs | 482 +++++++++++------- .../Client/ProjectPlanning/Stage.hs | 3 +- .../Client/ProjectPlanning/Types.hs | 121 +++-- cabal-install/tests/IntegrationTests2.hs | 68 +-- 18 files changed, 577 insertions(+), 411 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index b19161e3ac9..5989fb55e23 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -38,6 +38,7 @@ import Distribution.Client.ProjectFlags import Distribution.Client.ProjectOrchestration import Distribution.Client.ScriptUtils import Distribution.Client.TargetProblem +import qualified Distribution.Compat.Graph as Graph import Distribution.Simple.Command import Distribution.Types.Component import Distribution.Verbosity @@ -129,8 +130,8 @@ genBoundsAction flags targetStrings globalFlags = pkgVersionMap :: Map.Map ComponentId PackageIdentifier pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan')) - externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier) - externalVersion pkg = (installedComponentId pkg, packageId pkg) + externalVersion :: WithStage InstalledPackageInfo -> (ComponentId, PackageIdentifier) + externalVersion (WithStage _stage pkg) = (installedComponentId pkg, packageId pkg) localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier) localVersion pkg = (elabComponentId pkg, packageId pkg) @@ -138,7 +139,7 @@ genBoundsAction flags targetStrings globalFlags = let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult] genBoundsActionForPkg pkg = -- Step 5: Match up the user specified targets with the local packages. - case Map.lookup (installedUnitId pkg) targets of + case Map.lookup (Graph.nodeKey pkg) targets of Nothing -> [] Just tgts -> map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts @@ -187,7 +188,8 @@ getBoundsForComponent tgt pkg pkgVersionMap = let componentDeps = elabLibDependencies pkg -- Match these up to package names, this is a list of Package name to versions. -- Now just match that up with what the user wrote in the build-depends section. - depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps + -- FIXME: I am not quite sure how this is supposed to work + depsWithVersions = mapMaybe (\(WithStage _stage cid, _) -> Map.lookup (confInstId cid) pkgVersionMap) componentDeps isNeeded = hasElem needBounds . packageName in boundsResult (Just (filter isNeeded depsWithVersions)) where diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index b864b73d7cf..d6f31a27e72 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -35,11 +35,11 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedSharedConfig (..) , TargetAction (..) - ) -import Distribution.Client.ProjectPlanning.Types - ( Toolchain (..) + , Toolchain (..) + , WithStage (..) , elabDistDirParams , getStage ) @@ -160,7 +160,7 @@ haddockProjectAction flags _extraArgs globalFlags = do sharedConfig :: ElaboratedSharedConfig sharedConfig = elaboratedShared buildCtx - pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] + pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] pkgs = matchingPackages elaboratedPlan -- TODO @@ -210,7 +210,7 @@ haddockProjectAction flags _extraArgs globalFlags = do packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> case pkg of - Left package | localStyle -> do + Left (WithStage _ package) | localStyle -> do let packageName = unPackageName (pkgName $ sourcePackageId package) destDir = outputDir packageName fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do @@ -442,7 +442,7 @@ haddockProjectAction flags _extraArgs globalFlags = do matchingPackages :: ElaboratedInstallPlan - -> [Either InstalledPackageInfo ElaboratedConfiguredPackage] + -> [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] matchingPackages = fmap (foldPlanPackage Left Right) . InstallPlan.toList diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 0ab5b5c83bc..08562fce6d3 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -91,10 +91,10 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectFlags (ProjectFlags (..)) import Distribution.Client.ProjectPlanning - ( storePackageInstallDirs' - ) -import Distribution.Client.ProjectPlanning.Types ( ElaboratedInstallPlan + , ElaboratedPlanPackage + , Stage (..) + , storePackageInstallDirs' ) import Distribution.Client.RebuildMonad ( runRebuild @@ -115,6 +115,7 @@ import Distribution.Client.Types import Distribution.Client.Types.OverwritePolicy ( OverwritePolicy (..) ) +import qualified Distribution.Compat.Graph as Graph import Distribution.Package ( Package (..) , PackageName @@ -565,7 +566,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg - traverse_ actionOnExe . Map.toList $ targetsMap buildCtx + traverse_ actionOnExe . Map.toList $ filterTargetsWithStage Host $ targetsMap buildCtx withProject :: Verbosity @@ -784,7 +785,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector localPkgs = sdistize <$> localPackages baseCtx - gatherTargets :: UnitId -> TargetSelector + gatherTargets :: Graph.Key ElaboratedPlanPackage -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName targetFilter where targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap @@ -829,7 +830,7 @@ partitionToKnownTargetsAndHackagePackages -> SourcePackageDb -> ElaboratedInstallPlan -> [TargetSelector] - -> IO (TargetsMap, [PackageName]) + -> IO (TargetsMapS, [PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do let mTargets = resolveTargetsFromSolver @@ -1005,7 +1006,7 @@ installLibraries ordNub $ globalEntries ++ envEntries - ++ entriesForLibraryComponents (targetsMap buildCtx) + ++ entriesForLibraryComponents (filterTargetsWithStage Host $ targetsMap buildCtx) contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) createDirectoryIfMissing True (takeDirectory envFile) writeFileAtomic envFile (BS.pack contents') diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 8d358bc9802..d1c6a824295 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -224,7 +224,7 @@ listbinAction flags args globalFlags = do -- Target Problem: the very similar to CmdRun ------------------------------------------------------------------------------- -singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleComponentOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName) singleComponentOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap of [(unitId, CExeName component)] -> return (unitId, component) @@ -316,7 +316,7 @@ data ListBinProblem | -- | A single 'TargetSelector' matches multiple targets TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets TargetsMap + TargetProblemMultipleTargets TargetsMapS | -- | The 'TargetSelector' refers to a component that is not an executable TargetProblemComponentNotRightKind PackageId ComponentName | -- | Asking to run an individual file or module is not supported @@ -333,7 +333,7 @@ matchesMultipleProblem selector targets = CustomTargetProblem $ TargetProblemMatchesMultiple selector targets -multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem +multipleTargetsProblem :: TargetsMapS -> TargetProblem ListBinProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index b9bfa0a2451..a80a772ad5f 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -42,7 +42,6 @@ import Distribution.Client.ProjectConfig.Types ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types (Toolchain (..)) import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Client.ScriptUtils import Distribution.Client.Setup @@ -82,7 +81,6 @@ import Distribution.Simple.Utils , withOutputMarker , wrapText ) -import Distribution.Solver.Types.Stage import Distribution.Verbosity ( normal ) diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index d448e5da4bb..f91574df105 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -55,6 +55,9 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedInstallPlan , ElaboratedSharedConfig (..) + , Stage (..) + , WithStage + , getStage ) import Distribution.Client.ProjectPlanning.Types ( Toolchain (..) @@ -92,7 +95,6 @@ import Distribution.Compiler import Distribution.Package ( Package (..) , UnitId - , installedUnitId , mkPackageName , packageName ) @@ -181,11 +183,11 @@ import Distribution.Client.ReplFlags , topReplOptions ) import Distribution.Compat.Binary (decode) +import qualified Distribution.Compat.Graph as Graph import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag) import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Types -import Distribution.Solver.Types.Stage import System.Directory ( doesFileExist , getCurrentDirectory @@ -363,15 +365,14 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- especially in the no-project case. withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - -- TODO: This only makes sense for the build stage let Toolchain{toolchainCompiler = compiler} = getStage (pkgConfigToolchains sharedConfig) Build + -- FIXME there is total confusion here about who is filtering for the stage targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors - let - (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets - originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId - oci = OriginalComponentInfo unitId originalDeps - pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId + (key, _uid) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets + originalDeps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan key + oci = OriginalComponentInfo key originalDeps + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow key) $ packageId <$> InstallPlan.lookup elaboratedPlan key baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' return (Just oci, baseCtx'') @@ -525,6 +526,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g verbosity = cfgVerbosity normal flags tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags + -- FIXME: the compiler depends on the stage!! validatedTargets ctx compiler elaboratedPlan targetSelectors = do let multi_repl_enabled = multiReplDecision ctx compiler r -- Interpret the targets on the command line as repl targets @@ -564,8 +566,8 @@ minMultipleHomeUnitsVersion :: Version minMultipleHomeUnitsVersion = mkVersion [9, 4] data OriginalComponentInfo = OriginalComponentInfo - { ociUnitId :: UnitId - , ociOriginalDeps :: [UnitId] + { ociUnitId :: WithStage UnitId + , ociOriginalDeps :: [WithStage UnitId] } deriving (Show) @@ -600,18 +602,25 @@ addDepsToProjectTarget deps pkgId ctx = generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String] generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags where - exeDeps :: [UnitId] + exeDeps :: [WithStage UnitId] exeDeps = foldMap (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies) (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId]) - deps, deps', trans, trans' :: [UnitId] - flags :: [String] - deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId + deps :: [WithStage UnitId] + deps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan ociUnitId + + deps' :: [WithStage UnitId] deps' = deps \\ ociOriginalDeps - trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + + trans :: [WithStage UnitId] + trans = Graph.nodeKey <$> InstallPlan.dependencyClosure elaboratedPlan deps' + + trans' :: [WithStage UnitId] trans' = trans \\ ociOriginalDeps + + flags :: [String] flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $ if includeTransitive then trans' else deps' @@ -763,7 +772,7 @@ selectComponentTarget = selectComponentTargetBasic data ReplProblem = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets MultiReplDecision TargetsMap + TargetProblemMultipleTargets MultiReplDecision TargetsMapS deriving (Eq, Show) -- | The various error conditions that can occur when matching a @@ -780,7 +789,7 @@ matchesMultipleProblem decision targetSelector targetsExesBuildable = multipleTargetsProblem :: MultiReplDecision - -> TargetsMap + -> TargetsMapS -> ReplTargetProblem multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 6f3d4123af7..8dd2ac0e2e9 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -55,6 +55,7 @@ import qualified Distribution.Client.ProjectOrchestration as Orchestration (targ import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , WithStage (..) , binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types @@ -384,7 +385,7 @@ handleShebang :: FilePath -> [String] -> IO () handleShebang script args = runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags -singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) +singleExeOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName) singleExeOrElse action targetsMap = case Set.toList . distinctTargetComponents $ targetsMap of [(unitId, CExeName component)] -> return (unitId, component) @@ -396,16 +397,16 @@ singleExeOrElse action targetsMap = -- 'ElaboratedConfiguredPackage's that match the specified -- 'UnitId'. matchingPackagesByUnitId - :: UnitId + :: WithStage UnitId -> ElaboratedInstallPlan -> [ElaboratedConfiguredPackage] -matchingPackagesByUnitId uid = +matchingPackagesByUnitId (WithStage s uid) = catMaybes . fmap ( foldPlanPackage (const Nothing) ( \x -> - if elabUnitId x == uid + if elabUnitId x == uid && elabStage x == s then Just x else Nothing ) @@ -494,7 +495,7 @@ data RunProblem | -- | A single 'TargetSelector' matches multiple targets TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] | -- | Multiple 'TargetSelector's match multiple targets - TargetProblemMultipleTargets TargetsMap + TargetProblemMultipleTargets TargetsMapS | -- | The 'TargetSelector' refers to a component that is not an executable TargetProblemComponentNotExe PackageId ComponentName | -- | Asking to run an individual file or module is not supported @@ -511,7 +512,7 @@ matchesMultipleProblem selector targets = CustomTargetProblem $ TargetProblemMatchesMultiple selector targets -multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem +multipleTargetsProblem :: TargetsMapS -> TargetProblem RunProblem multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs index 6fc0f9f973c..7c9b986b929 100644 --- a/cabal-install/src/Distribution/Client/CmdTarget.hs +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -170,7 +170,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors localPackages Nothing targetStrings - targets :: TargetsMap <- + targets <- either (reportBuildTargetProblems verbosity) return $ resolveTargetsFromSolver selectPackageTargets @@ -192,7 +192,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a reportBuildTargetProblems verbosity = reportTargetProblems verbosity "target" -printTargetForms :: Verbosity -> [String] -> TargetsMap -> ElaboratedInstallPlan -> IO () +printTargetForms :: Verbosity -> [String] -> TargetsMapS -> ElaboratedInstallPlan -> IO () printTargetForms verbosity targetStrings targets elaboratedPlan = noticeDoc verbosity $ vcat @@ -218,7 +218,7 @@ printTargetForms verbosity targetStrings targets elaboratedPlan = sort $ catMaybes [ targetForm ct <$> pkg - | (u :: UnitId, xs) <- Map.toAscList targets + | (WithStage _ u, xs) <- Map.toAscList targets , let pkg = safeHead $ filter ((== u) . elabUnitId) localPkgs , (ct :: ComponentTarget, _) <- xs ] diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs index 4270435b54f..b7d49b9b615 100644 --- a/cabal-install/src/Distribution/Client/Errors.hs +++ b/cabal-install/src/Distribution/Client/Errors.hs @@ -24,6 +24,7 @@ import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Char8 as BS8 import Data.List (groupBy) import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.ProjectPlanning.Stage (WithStage) import qualified Distribution.Client.Types.Repo as Repo import qualified Distribution.Client.Types.RepoName as RepoName import Distribution.Compat.Prelude @@ -96,7 +97,7 @@ data CabalInstallException | PlanPackages String | NoSupportForRunCommand | RunPhaseReached - | UnknownExecutable String UnitId + | UnknownExecutable String (WithStage UnitId) | MultipleMatchingExecutables String [String] | CmdRunReportTargetProblems String | CleanAction [String] diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index c19827461ae..cc5c9a8831a 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -182,7 +182,8 @@ data PackageHashInputs = PackageHashInputs , pkgHashComponent :: Maybe CD.Component , pkgHashSourceHash :: PackageSourceHash , pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion) - , pkgHashDirectDeps :: Set InstalledPackageId + , pkgHashLibDeps :: Set InstalledPackageId + , pkgHashExeDeps :: Set InstalledPackageId , pkgHashOtherConfig :: PackageHashConfigInputs } @@ -257,7 +258,8 @@ renderPackageHashInputs { pkgHashPkgId , pkgHashComponent , pkgHashSourceHash - , pkgHashDirectDeps + , pkgHashLibDeps + , pkgHashExeDeps , pkgHashPkgConfigDeps , pkgHashOtherConfig = PackageHashConfigInputs{..} @@ -296,12 +298,19 @@ renderPackageHashInputs ) pkgHashPkgConfigDeps , entry - "deps" + "lib-deps" ( intercalate ", " . map prettyShow . Set.toList ) - pkgHashDirectDeps + pkgHashLibDeps + , entry + "exe-deps" + ( intercalate ", " + . map prettyShow + . Set.toList + ) + pkgHashExeDeps , -- and then all the config entry "compilerid" prettyShow pkgHashCompilerId , entry "compilerabi" prettyShow pkgHashCompilerABI diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 87ae3ddc7a6..98f83b47962 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -96,6 +96,7 @@ import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import qualified Distribution.Compat.Graph as Graph ------------------------------------------------------------------------------ @@ -458,13 +459,14 @@ rebuildTargets offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where - makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome) + makeBuildOutcome :: ElaboratedConfiguredPackage -> (Graph.Key ElaboratedPlanPackage, BuildOutcome) makeBuildOutcome ElaboratedConfiguredPackage { elabUnitId + , elabStage , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion} } = - ( elabUnitId + ( WithStage elabStage elabUnitId , Left ( BuildFailure { buildFailureLogFile = Nothing @@ -656,8 +658,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body [ elabPkgSourceLocation elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan - , let uid = installedUnitId elab - pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , let pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") (Graph.nodeKey elab) pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 864455cb540..3d8b9ff9082 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -25,8 +25,10 @@ import Prelude () import Distribution.Client.FileMonitor (MonitorChangedReason (..)) import Distribution.Client.Types (DocsResult, TestsResult) +import Distribution.Client.ProjectPlanning.Types (ElaboratedPlanPackage) +import qualified Distribution.Compat.Graph as Graph import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Package (PackageId, UnitId) +import Distribution.Package (PackageId) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -36,7 +38,7 @@ import Distribution.Simple.LocalBuildInfo (ComponentName) -- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'. -- -- This is used as the result of the dry-run of building an install plan. -type BuildStatusMap = Map UnitId BuildStatus +type BuildStatusMap = Map (Graph.Key ElaboratedPlanPackage) BuildStatus -- | The build status for an individual package is the state that the -- package is in /prior/ to initiating a (re)build. @@ -135,7 +137,7 @@ data BuildReason -- -- | A summary of the outcome for building a whole set of packages. -type BuildOutcomes = Map UnitId BuildOutcome +type BuildOutcomes = Map (Graph.Key ElaboratedPlanPackage) BuildOutcome -- | A summary of the outcome for building a single package: either success -- or failure. diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 2db062816e2..650a2a1e190 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -61,6 +62,7 @@ module Distribution.Client.ProjectOrchestration , resolveTargetsFromSolver , resolveTargetsFromLocalPackages , TargetsMap + , TargetsMapS , allTargetSelectors , uniqueTargetSelectors , TargetSelector (..) @@ -102,6 +104,7 @@ module Distribution.Client.ProjectOrchestration -- * Dummy projects , establishDummyProjectBaseContext , establishDummyDistDirLayout + , filterTargetsWithStage ) where import Distribution.Client.Compat.Prelude @@ -152,9 +155,6 @@ import Distribution.Client.Setup hiding (packageName) import Distribution.Types.ComponentName ( componentNameString ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo - ) import Distribution.Types.UnqualComponentName ( UnqualComponentName , packageNameToUnqualComponentName @@ -323,7 +323,7 @@ data ProjectBuildContext = ProjectBuildContext , pkgsBuildStatus :: BuildStatusMap -- ^ The result of the dry-run phase. This tells us about each member of -- the 'elaboratedPlanToExecute'. - , targetsMap :: TargetsMap + , targetsMap :: TargetsMapS -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in -- CmdRun, where we need a valid target to execute. } @@ -361,7 +361,7 @@ withInstallPlan runProjectPreBuildPhase :: Verbosity -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMapS)) -> IO ProjectBuildContext runProjectPreBuildPhase verbosity @@ -547,12 +547,22 @@ type TargetsMap = TargetsMapX UnitId type TargetsMapX u = Map u [(ComponentTarget, NonEmpty TargetSelector)] +type TargetsMapS = TargetsMapX (WithStage UnitId) + +filterTargetsWithStage :: Stage -> TargetsMapS -> TargetsMap +filterTargetsWithStage stage = + Map.fromList + . mapMaybe (\(WithStage s uid, v) -> if s == stage then Just (uid, v) else Nothing) + . Map.toList + +-- Map.mapMaybeWithKey (\(WithStage s uid) v -> if s == stage then Just v else Nothing) + -- | Get all target selectors. -allTargetSelectors :: TargetsMap -> [TargetSelector] +allTargetSelectors :: TargetsMapS -> [TargetSelector] allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems -- | Get all unique target selectors. -uniqueTargetSelectors :: TargetsMap -> [TargetSelector] +uniqueTargetSelectors :: TargetsMapS -> [TargetSelector] uniqueTargetSelectors = ordNub . allTargetSelectors -- | Resolve targets from a solver result. @@ -575,7 +585,7 @@ resolveTargetsFromSolver -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap + -> Either [TargetProblem err] TargetsMapS resolveTargetsFromSolver selectPackageTargets selectComponentTarget installPlan sourceDb targetSelectors = resolveTargets selectPackageTargets @@ -797,18 +807,18 @@ type AvailableTargetsMap k u = Map k [AvailableTarget (u, ComponentName)] -- -- They are all constructed lazily because they are not necessarily all used. -- -availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes UnitId +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes (WithStage UnitId) availableTargetIndexes installPlan = AvailableTargetIndexes{..} where availableTargetsByPackageIdAndComponentName :: Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageIdAndComponentName = availableTargets installPlan availableTargetsByPackageId - :: Map PackageId [AvailableTarget (UnitId, ComponentName)] + :: Map PackageId [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageId = Map.mapKeysWith (++) @@ -817,7 +827,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} `Map.union` availableTargetsEmptyPackages availableTargetsByPackageName - :: Map PackageName [AvailableTarget (UnitId, ComponentName)] + :: Map PackageName [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageName = Map.mapKeysWith (++) @@ -827,7 +837,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndComponentName :: Map (PackageName, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndComponentName = Map.mapKeysWith (++) @@ -837,7 +847,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndUnqualComponentName :: Map (PackageName, UnqualComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndUnqualComponentName = Map.mapKeysWith (++) @@ -1029,7 +1039,7 @@ selectComponentTargetBasic -- for the extra unneeded info in the 'TargetsMap'. pruneInstallPlanToTargets :: TargetAction - -> TargetsMap + -> TargetsMapS -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = @@ -1041,7 +1051,7 @@ pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = -- | Utility used by repl and run to check if the targets spans multiple -- components, since those commands do not support multiple components. -distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName) +distinctTargetComponents :: TargetsMapS -> Set.Set (WithStage UnitId, ComponentName) distinctTargetComponents targetsMap = Set.fromList [ (uid, cname) @@ -1111,6 +1121,7 @@ printPlan unwords $ filter (not . null) $ [ " -" + , prettyShow (elabStage elab) , if verbosity >= deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) @@ -1123,7 +1134,7 @@ printPlan "(" ++ showComp comp ++ ")" , showFlagAssignment (nonDefaultFlags elab) , showConfigureFlags elab - , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab + , let buildStatus = pkgsBuildStatus Map.! Graph.nodeKey elab in "(" ++ showBuildStatus buildStatus ++ ")" ] @@ -1336,7 +1347,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes , (pkg, failureClassification) <- failuresClassification ] where - failures :: [(UnitId, BuildFailure)] + failures :: [(Graph.Key ElaboratedPlanPackage, BuildFailure)] failures = [ (pkgid, failure) | (pkgid, Left failure) <- Map.toList buildOutcomes @@ -1394,9 +1405,10 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes -- isSimpleCase :: Bool isSimpleCase - | [(pkgid, failure)] <- failures + | [(WithStage s pkgid, failure)] <- failures , [pkg] <- rootpkgs , installedUnitId pkg == pkgid + , stageOf pkg == s , isFailureSelfExplanatory (buildFailureReason failure) , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] = True @@ -1420,16 +1432,15 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes , hasNoDependents pkg ] - ultimateDeps - :: UnitId - -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage] - ultimateDeps pkgid = + ultimateDeps :: (WithStage UnitId) -> [ElaboratedPlanPackage] + ultimateDeps pkgid@(WithStage s uid) = filter - (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid) + (\pkg -> hasNoDependents pkg && installedUnitId pkg /= uid && stageOf pkg == s) (InstallPlan.reverseDependencyClosure plan [pkgid]) - hasNoDependents :: HasUnitId pkg => pkg -> Bool - hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId + -- TODO: ugly + hasNoDependents :: (Graph.IsNode pkg, Graph.Key pkg ~ WithStage UnitId) => pkg -> Bool + hasNoDependents = null . InstallPlan.revDirectDeps plan . Graph.nodeKey renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String renderFailureDetail mentionDepOf pkg reason = @@ -1461,7 +1472,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes pkgstr = elabConfiguredName verbosity pkg ++ if mentionDepOf - then renderDependencyOf (installedUnitId pkg) + then renderDependencyOf (Graph.nodeKey pkg) else "" renderFailureExtraDetail :: BuildFailureReason -> String @@ -1472,7 +1483,7 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes renderFailureExtraDetail _ = "" - renderDependencyOf :: UnitId -> String + renderDependencyOf :: Graph.Key ElaboratedConfiguredPackage -> String renderDependencyOf pkgid = case ultimateDeps pkgid of [] -> "" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index c70e45f8f8d..9e71be71140 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -141,7 +141,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- that case, but the code supports it in case we want to use this -- later in some use case where we want the status of the build. - installedPackageInfoToJ :: InstalledPackageInfo -> J.Value + installedPackageInfoToJ :: WithStage InstalledPackageInfo -> J.Value installedPackageInfoToJ ipi = -- Pre-existing packages lack configuration information such as their flag -- settings or non-lib components. We only get pre-existing packages for @@ -150,10 +150,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- J.object [ "type" J..= J.String "pre-existing" - , "id" J..= (jdisplay . installedUnitId) ipi + , "stage" J..= jdisplay (stageOf ipi) + , "id" J..= (jdisplay . Graph.nodeKey) ipi , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi , "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi - , "depends" J..= map jdisplay (installedDepends ipi) + , "depends" J..= map jdisplay (traverse installedDepends ipi) ] elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value @@ -165,7 +166,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = then "installed" else "configured" ) - , "id" J..= (jdisplay . installedUnitId) elab + , "id" J..= (jdisplay . Graph.nodeKey) elab , "stage" J..= jdisplay (elabStage elab) , "pkg-name" J..= (jdisplay . pkgName . packageId) elab , "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab @@ -197,7 +198,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = [ comp2str c J..= J.object ( [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps) - , "exe-depends" J..= map (jdisplay . confInstId) edeps + , "exe-depends" J..= map (jdisplay . fmap confInstId) edeps ] ++ bin_file c ) @@ -209,7 +210,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] in ["components" J..= components] ElabComponent comp -> - [ "depends" J..= map (jdisplay . confInstId) (map fst $ elabLibDependencies elab) + [ "depends" J..= map (jdisplay . fmap confInstId . fst) (elabLibDependencies elab) , "exe-depends" J..= map jdisplay (elabExeDependencies elab) , "component-name" J..= J.String (comp2str (compSolverName comp)) ] @@ -454,7 +455,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- successfully then they're still out of date -- meeting our definition of -- invalid. -type PackageIdSet = Set UnitId +type PackageIdSet = Set (Graph.Key ElaboratedPlanPackage) type PackagesUpToDate = PackageIdSet data PostBuildProjectStatus = PostBuildProjectStatus @@ -507,7 +508,7 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- or data file generation failing. -- -- This is a subset of 'packagesInvalidByChangedLibDeps'. - , packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage) + , packagesLibDepGraph :: Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage) -- ^ A subset of the plan graph, including only dependency-on-library -- edges. That is, dependencies /on/ libraries, not dependencies /of/ -- libraries. This tells us all the libraries that packages link to. @@ -577,11 +578,13 @@ postBuildProjectStatus -- The previous set of up-to-date packages will contain bogus package ids -- when the solver plan or config contributing to the hash changes. -- So keep only the ones where the package id (i.e. hash) is the same. + previousPackagesUpToDate' :: Set (WithStage UnitId) previousPackagesUpToDate' = Set.intersection previousPackagesUpToDate (InstallPlan.keysSet plan) + packagesUpToDatePreBuild :: Set (WithStage UnitId) packagesUpToDatePreBuild = Set.filter (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid)) @@ -589,23 +592,26 @@ postBuildProjectStatus -- know anything about their status, so not known to be /up to date/. (InstallPlan.keysSet plan) + packagesOutOfDatePreBuild :: Set (WithStage UnitId) packagesOutOfDatePreBuild = - Set.fromList . map installedUnitId $ + Set.fromList . map Graph.nodeKey $ InstallPlan.reverseDependencyClosure plan [ ipkgid | pkg <- InstallPlan.toList plan - , let ipkgid = installedUnitId pkg + , let ipkgid = Graph.nodeKey pkg , lookupBuildStatusRequiresBuild False ipkgid -- For packages not in the plan subset we did the dry-run on we don't -- know anything about their status, so not known to be /out of date/. ] + packagesSuccessfulPostBuild :: Set (WithStage UnitId) packagesSuccessfulPostBuild = Set.fromList [ikgid | (ikgid, Right _) <- Map.toList buildOutcomes] -- direct failures, not failures due to deps + packagesFailurePostBuild :: Set (WithStage UnitId) packagesFailurePostBuild = Set.fromList [ ikgid @@ -617,6 +623,7 @@ postBuildProjectStatus -- Packages that have a library dependency on a package for which a build -- was attempted + packagesDepOnChangedLib :: Set (WithStage UnitId) packagesDepOnChangedLib = Set.fromList . map Graph.nodeKey $ fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $ @@ -628,19 +635,25 @@ postBuildProjectStatus ) -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: HasCallStack => Graph (Node UnitId ElaboratedPlanPackage) + packagesLibDepGraph :: HasCallStack => Graph (Node (Graph.Key ElaboratedPlanPackage) ElaboratedPlanPackage) packagesLibDepGraph = Graph.fromDistinctList - [ Graph.N pkg (installedUnitId pkg) libdeps + [ Graph.N pkg (Graph.nodeKey pkg) libdeps | pkg <- InstallPlan.toList plan , let libdeps = case pkg of - InstallPlan.PreExisting ipkg -> installedDepends ipkg - InstallPlan.Configured srcpkg -> elabLibDeps srcpkg - InstallPlan.Installed srcpkg -> elabLibDeps srcpkg + InstallPlan.PreExisting (WithStage s ipkg) -> map (WithStage s) (installedDepends ipkg) + InstallPlan.Configured srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg) + InstallPlan.Installed srcpkg -> map (WithStage (elabStage srcpkg)) (elabLibDeps srcpkg) ] elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] - elabLibDeps = map (newSimpleUnitId . confInstId) . map fst . elabLibDependencies + elabLibDeps = + map (newSimpleUnitId . confInstId) + -- Note, we remove the stage here. In the end we only care about the hash which already incorporates the stage. + -- Moreover, library dependencies are always in the same stage as the package itself. + . map (\(WithStage _ d) -> d) + . map fst + . elabLibDependencies -- Was a build was attempted for this package? -- If it doesn't have both a build status and outcome then the answer is no. @@ -657,13 +670,13 @@ postBuildProjectStatus buildAttempted _ (Left BuildFailure{}) = True buildAttempted _ (Right _) = True - lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool - lookupBuildStatusRequiresBuild def ipkgid = - case Map.lookup ipkgid pkgBuildStatus of + lookupBuildStatusRequiresBuild :: Bool -> Graph.Key ElaboratedPlanPackage -> Bool + lookupBuildStatusRequiresBuild def key = + case Map.lookup key pkgBuildStatus of Nothing -> def -- Not in the plan subset we did the dry-run on Just buildStatus -> buildStatusRequiresBuild buildStatus - packagesBuildLocal :: Set UnitId + packagesBuildLocal :: Set (WithStage UnitId) packagesBuildLocal = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -671,7 +684,7 @@ postBuildProjectStatus InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg - packagesBuildInplace :: Set UnitId + packagesBuildInplace :: Set (WithStage UnitId) packagesBuildInplace = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -679,7 +692,7 @@ postBuildProjectStatus InstallPlan.Installed _ -> False InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) - packagesAlreadyInStore :: Set UnitId + packagesAlreadyInStore :: Set (WithStage UnitId) packagesAlreadyInStore = selectPlanPackageIdSet $ \pkg -> case pkg of @@ -688,10 +701,8 @@ postBuildProjectStatus InstallPlan.Configured _ -> False selectPlanPackageIdSet - :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - -> Bool - ) - -> Set UnitId + :: (ElaboratedPlanPackage -> Bool) + -> Set (Graph.Key ElaboratedPlanPackage) selectPlanPackageIdSet p = Map.keysSet . Map.filter p @@ -868,33 +879,13 @@ writePlanGhcEnvironment path toolchainPlatform (compilerVersion toolchainCompiler) - ( renderGhcEnvironmentFile - path - stagePlan - postBuildStatus - ) + env else return Nothing where - Toolchain{..} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage - -- TODO - stagePlan = InstallPlan.remove {- (\pkg -> undefined pkg /= Host) -} (const False) elaboratedInstallPlan + Toolchain{toolchainPlatform, toolchainCompiler} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage --- TODO: [required eventually] support for writing user-wide package --- environments, e.g. like a global project, but we would not put the --- env file in the home dir, rather it lives under ~/.ghc/ + env = headerComment : simpleGhcEnvironmentFile packageDBs unitIds -renderGhcEnvironmentFile - :: FilePath - -> ElaboratedInstallPlan - -> PostBuildProjectStatus - -> [GhcEnvironmentFileEntry FilePath] -renderGhcEnvironmentFile - projectRootDir - elaboratedInstallPlan - postBuildStatus = - headerComment - : simpleGhcEnvironmentFile packageDBs unitIds - where headerComment = GhcEnvFileComment $ "This is a GHC environment file written by cabal. This means you can\n" @@ -902,11 +893,17 @@ renderGhcEnvironmentFile ++ "But you still need to use cabal repl $target to get the environment\n" ++ "of specific components (libs, exes, tests etc) because each one can\n" ++ "have its own source dirs, cpp flags etc.\n\n" - unitIds = selectGhcEnvironmentFileLibraries postBuildStatus + + unitIds = [unitId | WithStage Host unitId <- selectGhcEnvironmentFileLibraries postBuildStatus] + packageDBs = - relativePackageDBPaths projectRootDir $ + relativePackageDBPaths path $ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan +-- TODO: [required eventually] support for writing user-wide package +-- environments, e.g. like a global project, but we would not put the +-- env file in the home dir, rather it lives under ~/.ghc/ + argsEquivalentOfGhcEnvironmentFile :: Compiler -> DistDirLayout @@ -974,7 +971,7 @@ argsEquivalentOfGhcEnvironmentFileGhc -- to find the libs) then those exes still end up in our list so we have -- to filter them out at the end. -- -selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId] +selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [WithStage UnitId] selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of Nothing -> error "renderGhcEnvironmentFile: broken dep closure" @@ -991,7 +988,7 @@ selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} = -- or just locally. Check it's a lib and that it is probably up to date. InstallPlan.Configured pkg -> elabRequiresRegistration pkg - && installedUnitId pkg `Set.member` packagesProbablyUpToDate + && Graph.nodeKey pkg `Set.member` packagesProbablyUpToDate selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStackCWD selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 4a76597b644..18c982eeb02 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -36,12 +36,17 @@ module Distribution.Client.ProjectPlanning ( -- * Types for the elaborated install plan ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) , ElaboratedPlanPackage , ElaboratedSharedConfig (..) , ElaboratedReadyPackage , BuildStyle (..) , CabalFileText + , Toolchain (..) + , Stage (..) + , Staged (..) + , WithStage (..) , elabOrderLibDependencies , elabOrderExeDependencies , elabLibDependencies @@ -99,12 +104,12 @@ module Distribution.Client.ProjectPlanning , binDirectories , storePackageInstallDirs , storePackageInstallDirs' + , elabDistDirParams ) where import Distribution.Client.Compat.Prelude import Text.PrettyPrint - ( colon - , comma + ( comma , fsep , hang , punctuate @@ -231,7 +236,10 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.Errors +import Distribution.Client.InstallPlan (foldPlanPackage) import Distribution.Solver.Types.ProjectConfigPath +import Distribution.Solver.Types.ResolverPackage (solverId) +import qualified Distribution.Solver.Types.ResolverPackage as ResolverPackage import GHC.Stack (HasCallStack) import System.Directory (getCurrentDirectory) import System.FilePath @@ -870,7 +878,7 @@ rebuildInstallPlan (solverSettingIndexState solverSettings) (solverSettingActiveRepos solverSettings) - ipis <- for toolchains (\t -> getInstalledPackages verbosity t corePackageDbs) + ipis <- for toolchains (getInstalledPackages verbosity) pkgConfigDbs <- for toolchains (getPkgConfigDb verbosity . toolchainProgramDb) -- TODO: [code cleanup] it'd be better if the Compiler contained the @@ -904,10 +912,6 @@ rebuildInstallPlan (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform)) toolchains - corePackageDbs :: PackageDBStackCWD - corePackageDbs = - Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain projectConfigShared)) - withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = projectConfigWithSolverRepoContext @@ -1119,9 +1123,8 @@ programsMonitorFiles progdb = getInstalledPackages :: Verbosity -> Toolchain - -> PackageDBStackCWD -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, toolchainProgramDb} packagedbs = do +getInstalledPackages verbosity Toolchain{..} = do monitorFiles . map monitorFileOrDirectory =<< liftIO @@ -1129,7 +1132,7 @@ getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, t verbosity toolchainCompiler Nothing -- use ambient working directory - (coercePackageDBStack packagedbs) + (coercePackageDBStack toolchainPackageDBs) toolchainProgramDb toolchainPlatform ) @@ -1137,7 +1140,7 @@ getInstalledPackages verbosity Toolchain{toolchainCompiler, toolchainPlatform, t IndexUtils.getInstalledPackages verbosity toolchainCompiler - packagedbs + toolchainPackageDBs toolchainProgramDb {- @@ -1673,13 +1676,12 @@ elaborateInstallPlan ) f _ = Nothing - elaboratedInstallPlan - :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan :: LogProgress ElaboratedInstallPlan elaboratedInstallPlan = flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> case planpkg of SolverInstallPlan.PreExisting pkg -> - return [InstallPlan.PreExisting (instSolverPkgIPI pkg)] + return [InstallPlan.PreExisting (WithStage (instSolverStage pkg) (instSolverPkgIPI pkg))] SolverInstallPlan.Configured pkg -> let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace" @@ -1699,13 +1701,13 @@ elaborateInstallPlan => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ _ _ deps0 exe_deps0) = + elaborateSolverToComponents mapDep spkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = case mkComponentsGraph (elabEnabledSpec elab0) pd of Right g -> do let src_comps = componentsGraphToList g infoProgress $ hang - (text "Component graph for" <+> pretty pkgid <<>> colon) + (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured spkg))) 4 (dispComponentsWithDeps src_comps) (_, comps) <- @@ -1803,7 +1805,21 @@ elaborateInstallPlan , elabUnitId = notImpl "elabUnitId" , elabComponentId = notImpl "elabComponentId" , elabInstallDirs = notImpl "elabInstallDirs" - , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) + , elabPkgOrComp = + ElabComponent + ( ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compLinkedLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compOrderLibDependencies + , compInstantiatedWith + , compLinkedInstantiatedWith + } + ) } | otherwise = Nothing @@ -1811,7 +1827,7 @@ elaborateInstallPlan compSolverName = CD.ComponentSetup compComponentName = Nothing - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 + dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps solverPkgLibDeps compLibDependencies = -- MP: No idea what this function does @@ -1832,16 +1848,17 @@ elaborateInstallPlan ++ f ++ " not implemented yet" + -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) buildComponent :: HasCallStack - => ( ConfiguredComponentMap - , LinkedComponentMap + => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) , Map ComponentId FilePath ) -> Cabal.Component -> LogProgress - ( ( ConfiguredComponentMap - , LinkedComponentMap + ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) , Map ComponentId FilePath ) , ElaboratedConfiguredPackage @@ -1852,19 +1869,30 @@ elaborateInstallPlan <+> quotes (text (componentNameStanza cname)) ) $ do + let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map + -- TODO: is cc_map correct here? + exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map + -- 1. Configure the component, but with a place holder ComponentId. + infoProgress $ + hang (text "configuring component" <+> pretty cname) 4 $ + vcat + [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) + , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) + ] cc0 <- toConfiguredComponent pd (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - (Map.unionWith Map.union external_lib_cc_map cc_map) - (Map.unionWith Map.union external_exe_cc_map cc_map) + lib_dep_map + exe_dep_map comp let do_ cid = let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid in (cid', False) -- filled in later in pruneInstallPlanPhase2) - -- 2. Read out the dependencies from the ConfiguredComponent cc0 + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 let compLibDependencies = -- Nub because includes can show up multiple times ordNub @@ -1872,19 +1900,59 @@ elaborateInstallPlan (\cid -> do_ cid) (cc_includes cc0) ) + + compExeDependencies :: [WithStage ConfiguredId] compExeDependencies = - map - annotatedIdToConfiguredId - (cc_exe_deps cc0) + -- External + [ WithStage (stageOf pkg) confId + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , -- only executables + Just (CExeName _) <- [confCompName confId] + , confSrcId confId /= pkgid + ] + <> + -- Internal, assume the same stage + [ WithStage solverPkgStage confId + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + ] + + compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths + -- External + [ (WithStage solverPkgStage confId, path) + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , confSrcId confId /= pkgid + , -- only executables + Just (CExeName _) <- [confCompName confId] + , path <- planPackageExePaths pkg ] - compInstantiatedWith = Map.empty - compLinkedInstantiatedWith = Map.empty - elab_comp = ElaboratedComponent{..} + <> + -- Internal, assume the same stage + [ (WithStage solverPkgStage confId, path) + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + , Just paths <- [Map.lookup (ann_id aid) exe_map1] + , path <- paths + ] + + elab_comp = + ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compLinkedLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compOrderLibDependencies + , compInstantiatedWith = Map.empty + , compLinkedInstantiatedWith = Map.empty + } -- 3. Construct a preliminary ElaboratedConfiguredPackage, -- and use this to compute the component ID. Fix up cc_id @@ -1909,22 +1977,30 @@ elaborateInstallPlan elab1 -- knot tied ) cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - infoProgress $ dispConfiguredComponent cc + + infoProgress $ hang (text "configured component:") 4 (dispConfiguredComponent cc) -- 4. Perform mix-in linking let lookup_uid def_uid = case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of Just full -> full Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) + lc_dep_map = Map.union external_lc_map lc_map lc <- toLinkedComponent verbosity False + -- \^ whether there are any "promised" package dependencies which we won't find already installed lookup_uid + -- \^ full db (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) + -- \^ the source package id + lc_dep_map + -- \^ linked component map cc - infoProgress $ dispLinkedComponent lc + -- \^ configured component + + infoProgress $ hang (text "linked component:") 4 (dispLinkedComponent lc) -- NB: elab is setup to be the correct form for an -- indefinite library, or a definite library with no holes. -- We will modify it in 'instantiateInstallPlan' to handle @@ -1974,23 +2050,15 @@ elaborateInstallPlan compComponentName = Just cname compSolverName = CD.componentNameToComponent cname - -- NB: compLinkedLibDependencies and - -- compOrderLibDependencies are defined when we define - -- 'elab'. - external_lib_dep_sids = CD.select (== compSolverName) deps0 - external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 + -- External dependencies. I.e. dependencies of the component on components of other packages. + external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps - external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids - external_exe_dep_pkgs = - concatMap mapDep $ - ordNubBy (pkgName . packageId) $ - external_exe_dep_sids + external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps external_exe_map = Map.fromList $ - [ (getComponentId pkg, paths) + [ (getComponentId pkg, planPackageExePaths pkg) | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg ] exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map @@ -2003,7 +2071,7 @@ elaborateInstallPlan external_lc_map = Map.fromList $ map mkShapeMapping $ - external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids + external_lib_dep_pkgs ++ external_exe_dep_pkgs compPkgConfigDependencies = [ ( pn @@ -2095,14 +2163,29 @@ elaborateInstallPlan -- of the other fields of the elaboratedPackage. return elab where - elab0@ElaboratedConfiguredPackage{..} = - elaborateSolverToCommon pkg + elab0@ElaboratedConfiguredPackage + { elabPkgSourceHash + , elabStanzasRequested + , elabStage + } = elaborateSolverToCommon pkg elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} + , elabPkgOrComp = + ElabPackage $ + ElaboratedPackage + { pkgStage = elabStage + , pkgInstalledId + , pkgLibDependencies + , pkgDependsOnSelfLib + , pkgExeDependencies + , pkgExeDependencyPaths + , pkgPkgConfigDependencies + , pkgStanzasEnabled + , pkgWhyNotPerComponent + } , elabModuleShape = modShape } @@ -2133,18 +2216,17 @@ elaborateInstallPlan -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. - isExt confid = confSrcId confid /= pkgid - filterExt = filter isExt - - filterExt' :: [(ConfiguredId, a)] -> [(ConfiguredId, a)] - filterExt' = filter (isExt . fst) + isExternal confid = confSrcId confid /= pkgid + isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId pkgLibDependencies = - buildComponentDeps (filterExt' . compLibDependencies) + buildComponentDeps (filter (isExternal . fst) . compLibDependencies) + pkgExeDependencies = - buildComponentDeps (filterExt . compExeDependencies) + buildComponentDeps (filter isExternal' . compExeDependencies) + pkgExeDependencyPaths = - buildComponentDeps (filterExt' . compExeDependencyPaths) + buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) -- TODO: Why is this flat? pkgPkgConfigDependencies = @@ -2588,7 +2670,7 @@ shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool -matchPlanPkg p = InstallPlan.foldPlanPackage (p . ipiComponentName) (matchElabPkg p) +matchPlanPkg p = InstallPlan.foldPlanPackage (\(WithStage _stage ipkg) -> p (ipiComponentName ipkg)) (matchElabPkg p) -- | Get the appropriate 'ComponentName' which identifies an installed -- component. @@ -2614,15 +2696,14 @@ matchElabPkg p elab = (p . componentName) (Cabal.pkgBuildableComponents (elabPkgDescription elab)) --- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName' --- and 'ComponentName' to the 'ComponentId' that should be used --- in this case. +-- | Extract from an 'ElaboratedPlanPackage' a mapping from package and component name +-- to a component id. mkCCMapping :: ElaboratedPlanPackage -> (PackageName, Map ComponentName (AnnotatedId ComponentId)) mkCCMapping = InstallPlan.foldPlanPackage - ( \ipkg -> + ( \(WithStage _ ipkg) -> ( packageName ipkg , Map.singleton (ipiComponentName ipkg) @@ -2646,12 +2727,14 @@ mkCCMapping = , case elabPkgOrComp elab of ElabComponent comp -> case compComponentName comp of + -- This should be an error because we cannot explicitly depend on a setup Nothing -> Map.empty Just n -> Map.singleton n (mk_aid n) ElabPackage _ -> Map.fromList $ map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn)) + -- Shouldn't this be available in ElaboratedPackage? (Cabal.pkgBuildableComponents (elabPkgDescription elab)) ) @@ -2665,9 +2748,8 @@ mkShapeMapping dpkg = where (dcid, shape) = InstallPlan.foldPlanPackage - -- Uses Monad (->) - (liftM2 (,) IPI.installedComponentId shapeInstalledPackage) - (liftM2 (,) elabComponentId elabModuleShape) + (\(WithStage _stage ipkg) -> (IPI.installedComponentId ipkg, shapeInstalledPackage ipkg)) + (\elab -> (elabComponentId elab, elabModuleShape elab)) dpkg indef_uid = IndefFullUnitId @@ -2715,7 +2797,7 @@ type InstM a = State InstS a getComponentId :: ElaboratedPlanPackage -> ComponentId -getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg +getComponentId (InstallPlan.PreExisting (WithStage _stage dipkg)) = IPI.installedComponentId dipkg getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab @@ -2725,6 +2807,17 @@ extractElabBuildStyle extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab extractElabBuildStyle _ = BuildAndInstall +-- When using Backpack, packages can have "holes" that need to be filled with concrete implementations. + +-- This function takes an initial install plan and creates additional plan entries for all the instantiated versions of packages + +-- The function deals with: + +-- Indefinite packages - Packages with holes/signatures that need to be filled +-- Instantiated packages - Concrete packages created by filling holes with specific implementations +-- Component IDs - Unique identifiers for components (libraries, executables etc.) +-- Unit IDs - Identifiers that track how holes are filled in instantiated packages + -- instantiateInstallPlan is responsible for filling out an InstallPlan -- with all of the extra Configured packages that would be generated by -- recursively instantiating the dependencies of packages. @@ -3048,15 +3141,17 @@ availableTargets :: ElaboratedInstallPlan -> Map (PackageId, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargets installPlan = let rs = [ (pkgid, cname, fake, target) | pkg <- InstallPlan.toList installPlan - , (pkgid, cname, fake, target) <- case pkg of + , (stage, pkgid, cname, fake, target) <- case pkg of InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg InstallPlan.Installed elab -> availableSourceTargets elab InstallPlan.Configured elab -> availableSourceTargets elab + , -- Only host stage can be explicitly requested by the user + stage == Host ] in Map.union ( Map.fromListWith @@ -3079,27 +3174,29 @@ availableTargets installPlan = -- more details on this fake stuff is about. availableInstalledTargets - :: IPI.InstalledPackageInfo - -> [ ( PackageId + :: WithStage IPI.InstalledPackageInfo + -> [ ( Stage + , PackageId , ComponentName , Bool - , AvailableTarget (UnitId, ComponentName) + , AvailableTarget (WithStage UnitId, ComponentName) ) ] -availableInstalledTargets ipkg = +availableInstalledTargets (WithStage stage ipkg) = let unitid = installedUnitId ipkg cname = CLibName LMainLibName - status = TargetBuildable (unitid, cname) TargetRequestedByDefault + status = TargetBuildable (WithStage stage unitid, cname) TargetRequestedByDefault target = AvailableTarget (packageId ipkg) cname status False fake = False - in [(packageId ipkg, cname, fake, target)] + in [(stage, IPI.sourcePackageId ipkg, cname, fake, target)] availableSourceTargets :: ElaboratedConfiguredPackage - -> [ ( PackageId + -> [ ( Stage + , PackageId , ComponentName , Bool - , AvailableTarget (UnitId, ComponentName) + , AvailableTarget (WithStage UnitId, ComponentName) ) ] availableSourceTargets elab = @@ -3133,7 +3230,7 @@ availableSourceTargets elab = -- map (thus eliminating the duplicates) and then we overlay that map with -- the normal buildable targets. (This is done above in 'availableTargets'.) -- - [ (packageId elab, cname, fake, target) + [ (elabStage elab, elabPkgSourceId elab, cname, fake, target) | component <- pkgComponents (elabPkgDescription elab) , let cname = componentName component status = componentAvailableTargetStatus component @@ -3167,7 +3264,7 @@ availableSourceTargets elab = /= Just cname componentAvailableTargetStatus - :: Component -> AvailableTargetStatus (UnitId, ComponentName) + :: Component -> AvailableTargetStatus (WithStage UnitId, ComponentName) componentAvailableTargetStatus component = case componentOptionalStanza $ CD.componentNameToComponent cname of -- it is not an optional stanza, so a library, exe or foreign lib @@ -3175,7 +3272,7 @@ availableSourceTargets elab = | not buildable -> TargetNotBuildable | otherwise -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetRequestedByDefault -- it is not an optional stanza, so a testsuite or benchmark Just stanza -> @@ -3188,11 +3285,11 @@ availableSourceTargets elab = _ | not buildable -> TargetNotBuildable (Just True, True) -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetRequestedByDefault (Nothing, True) -> TargetBuildable - (elabUnitId elab, cname) + (WithStage (elabStage elab) (elabUnitId elab), cname) TargetNotRequestedByDefault (Just True, False) -> error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname @@ -3304,7 +3401,7 @@ data TargetAction pruneInstallPlanToTargets :: HasCallStack => TargetAction - -> Map UnitId [ComponentTarget] + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = @@ -3325,16 +3422,16 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = -- -- For 'ElaboratedComponent', this the cached unit IDs always -- coincide with the real thing. -data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [WithStage UnitId] instance Package PrunedPackage where packageId (PrunedPackage elab _) = packageId elab instance HasUnitId PrunedPackage where - installedUnitId = Graph.nodeKey + installedUnitId (PrunedPackage elab _) = installedUnitId elab instance Graph.IsNode PrunedPackage where - type Key PrunedPackage = UnitId + type Key PrunedPackage = WithStage UnitId nodeKey (PrunedPackage elab _) = Graph.nodeKey elab nodeNeighbors (PrunedPackage _ deps) = deps @@ -3345,7 +3442,7 @@ fromPrunedPackage (PrunedPackage elab _) = elab -- This is required before we can prune anything. setRootTargets :: TargetAction - -> Map UnitId [ComponentTarget] + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] setRootTargets targetAction perPkgTargetsMap = @@ -3358,7 +3455,7 @@ setRootTargets targetAction perPkgTargetsMap = -- dependencies. Those comes in the second pass once we know the rev deps. -- setElabBuildTargets elab = - case ( Map.lookup (installedUnitId elab) perPkgTargetsMap + case ( Map.lookup (Graph.nodeKey elab) perPkgTargetsMap , targetAction ) of (Nothing, _) -> elab @@ -3409,7 +3506,7 @@ pruneInstallPlanPass1 pkgs -- otherwise we'll do less | otherwise = pruned_packages where - pkgs' :: [InstallPlan.GenericPlanPackage IPI.InstalledPackageInfo PrunedPackage] + pkgs' :: [InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage] pkgs' = map (mapConfiguredPackage prune) pkgs prune :: ElaboratedConfiguredPackage -> PrunedPackage @@ -3419,8 +3516,8 @@ pruneInstallPlanPass1 pkgs graph = Graph.fromDistinctList pkgs' - roots :: [UnitId] - roots = mapMaybe find_root pkgs' + roots :: [Graph.Key ElaboratedPlanPackage] + roots = map Graph.nodeKey (filter is_root pkgs') -- Make a closed graph by calculating the closure from the roots pruned_packages :: [ElaboratedPlanPackage] @@ -3459,25 +3556,21 @@ pruneInstallPlanPass1 pkgs | anyMultiReplTarget = map (mapConfiguredPackage add_repl_target) (Graph.toList closed_graph) | otherwise = Graph.toList closed_graph - is_root :: PrunedPackage -> Maybe UnitId - is_root (PrunedPackage elab _) = - if not $ - and - [ null (elabConfigureTargets elab) - , null (elabBuildTargets elab) - , null (elabTestTargets elab) - , null (elabBenchTargets elab) - , null (elabReplTarget elab) - , null (elabHaddockTargets elab) - ] - then Just (installedUnitId elab) - else Nothing - - find_root (InstallPlan.Configured pkg) = is_root pkg - -- When using the extra-packages stanza we need to - -- look at installed packages as well. - find_root (InstallPlan.Installed pkg) = is_root pkg - find_root _ = Nothing + is_root :: InstallPlan.GenericPlanPackage (WithStage IPI.InstalledPackageInfo) PrunedPackage -> Bool + is_root = + foldPlanPackage + (const False) + ( \(PrunedPackage elab _) -> + not $ + and + [ null (elabConfigureTargets elab) + , null (elabBuildTargets elab) + , null (elabTestTargets elab) + , null (elabBenchTargets elab) + , null (elabReplTarget elab) + , null (elabHaddockTargets elab) + ] + ) -- Note [Sticky enabled testsuites] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3527,7 +3620,7 @@ pruneInstallPlanPass1 pkgs -- the optional stanzas and we'll make further tweaks to the optional -- stanzas in the next pass. -- - pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [Graph.Key ElaboratedConfiguredPackage] pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} = InstallPlan.depends elab -- no pruning pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = @@ -3558,7 +3651,7 @@ pruneInstallPlanPass1 pkgs availablePkgs = Set.fromList - [ installedUnitId pkg + [ Graph.nodeKey pkg | InstallPlan.PreExisting pkg <- pkgs ] @@ -3594,7 +3687,7 @@ into the repl to uphold the closure property. -- all of the deps needed for the test suite, we go ahead and -- enable it always. optionalStanzasWithDepsAvailable - :: Set UnitId + :: Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedConfiguredPackage -> ElaboratedPackage -> OptionalStanzaSet @@ -3602,8 +3695,7 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg = optStanzaSetFromList [ stanza | stanza <- optStanzaSetToList (elabStanzasAvailable elab) - , let deps :: [UnitId] - deps = + , let deps = CD.select (optionalStanzaDeps stanza) -- TODO: probably need to select other @@ -3696,7 +3788,7 @@ pruneInstallPlanPass2 pkgs = libTargetsRequiredForRevDeps = [ c - | installedUnitId elab `Set.member` hasReverseLibDeps + | Graph.nodeKey elab `Set.member` hasReverseLibDeps , let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent , -- Don't enable building for anything which is being build in memory elabBuildStyle elab /= BuildInplaceOnly InMemory @@ -3711,11 +3803,10 @@ pruneInstallPlanPass2 pkgs = elabPkgSourceId elab ) WholeComponent - | installedUnitId elab `Set.member` hasReverseExeDeps + | Graph.nodeKey elab `Set.member` hasReverseExeDeps ] - availablePkgs :: Set UnitId - availablePkgs = Set.fromList (map installedUnitId pkgs) + availablePkgs = Set.fromList (map Graph.nodeKey pkgs) inMemoryTargets :: Set ConfiguredId inMemoryTargets = do @@ -3725,7 +3816,6 @@ pruneInstallPlanPass2 pkgs = , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] ] - hasReverseLibDeps :: Set UnitId hasReverseLibDeps = Set.fromList [ depid @@ -3733,7 +3823,6 @@ pruneInstallPlanPass2 pkgs = , depid <- elabOrderLibDependencies pkg ] - hasReverseExeDeps :: Set UnitId hasReverseExeDeps = Set.fromList [ depid @@ -3761,7 +3850,7 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- This is not always possible. pruneInstallPlanToDependencies :: HasCallStack - => Set UnitId + => Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedInstallPlan -> Either CannotPruneDependencies @@ -3775,7 +3864,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = $ fmap InstallPlan.new . checkBrokenDeps . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets) . InstallPlan.toList $ installPlan where @@ -3863,7 +3952,7 @@ setupHsScriptOptions , usePackageIndex = Nothing , useDependencies = [ (uid, srcid) - | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- + | (WithStage _ (ConfiguredId srcid (Just (CLibName LMainLibName)) uid), _) <- elabSetupDependencies elab ] , useDependenciesExclusive = True @@ -4004,7 +4093,7 @@ setupHsConfigureFlags -> m Cabal.ConfigFlags setupHsConfigureFlags mkSymbolicPath - plan + _plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) sharedConfig configCommonFlags = do @@ -4105,29 +4194,33 @@ setupHsConfigureFlags -- dependencies which should NOT be fed in here (also you don't have -- enough info anyway) -- + -- FIXME: stage? configDependencies = [ cidToGivenComponent cid - | (cid, is_internal) <- elabLibDependencies elab + | (WithStage _stage cid, is_internal) <- elabLibDependencies elab , not is_internal ] + -- FIXME: stage? configPromisedDependencies = [ cidToPromisedComponent cid - | (cid, is_internal) <- elabLibDependencies elab + | (WithStage _stage cid, is_internal) <- elabLibDependencies elab , is_internal ] + -- FIXME: stage? configConstraints = case elabPkgOrComp of ElabPackage _ -> [ thisPackageVersionConstraint srcid - | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab + | (WithStage _stage (ConfiguredId srcid _ _uid), _) <- elabLibDependencies elab ] ElabComponent _ -> [] configTests = case elabPkgOrComp of ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg) ElabComponent _ -> mempty @@ -4149,7 +4242,9 @@ setupHsConfigureFlags Just _ -> error "non-library dependency" Nothing -> LMainLibName - configCoverageFor = determineCoverageFor elab plan + -- FIXME: whathever + -- configCoverageFor = determineCoverageFor elab plan + configCoverageFor = NoFlag cidToPromisedComponent :: ConfiguredId -> PromisedComponent cidToPromisedComponent (ConfiguredId srcid mb_cn cid) = @@ -4412,33 +4507,39 @@ packageHashInputs ) = PackageHashInputs { pkgHashPkgId = packageId elab - , pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp) + , pkgHashComponent , pkgHashSourceHash = srchash , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) - , pkgHashDirectDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList $ - [ confInstId dep - | (dep, _) <- CD.select relevantDeps pkgLibDependencies - ] - ++ [ confInstId dep - | dep <- CD.select relevantDeps pkgExeDependencies - ] - ElabComponent comp -> - Set.fromList - ( map - confInstId - ( map fst (compLibDependencies comp) - ++ compExeDependencies comp - ) - ) + , pkgHashLibDeps + , pkgHashExeDeps , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab } where + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp) + pkgHashLibDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [confInstId c | (c, _promised) <- CD.select relevantDeps pkgLibDependencies] + ElabComponent comp -> + Set.fromList + [confInstId c | (c, _promised) <- compLibDependencies comp] + pkgHashExeDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [ confInstId c + | WithStage _stage c <- CD.select relevantDeps pkgExeDependencies + ] + ElabComponent comp -> + Set.fromList + [ confInstId c + | WithStage _stage c <- compExeDependencies comp + ] + -- Obviously the main deps are relevant relevantDeps CD.ComponentLib = True relevantDeps (CD.ComponentSubLib _) = True @@ -4555,46 +4656,47 @@ inplaceBinRoot layout config package = distBuildDirectory layout (elabDistDirParams config package) "build" --------------------------------------------------------------------------------- --- Configure --coverage-for flags +-- FIXME: whathever +-- -------------------------------------------------------------------------------- +-- -- Configure --coverage-for flags -- The list of non-pre-existing libraries without module holes, i.e. the -- main library and sub-libraries components of all the local packages in -- the project that are dependencies of the components being built and that do -- not require instantiations or are instantiations. -determineCoverageFor - :: ElaboratedConfiguredPackage - -- ^ The package or component being configured - -> ElaboratedInstallPlan - -> Flag [UnitId] -determineCoverageFor configuredPkg plan = - Flag - $ mapMaybe - ( \case - InstallPlan.Installed elab - | shouldCoverPkg elab -> Just $ elabUnitId elab - InstallPlan.Configured elab - | shouldCoverPkg elab -> Just $ elabUnitId elab - _ -> Nothing - ) - $ Graph.toList - $ InstallPlan.toGraph plan - where - libDeps = elabLibDependencies configuredPkg - shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = - elabLocalToProject - && not (isIndefiniteOrInstantiation elabModuleShape) - -- TODO(#9493): We can only cover libraries in the same package - -- as the testsuite - && elabPkgSourceId configuredPkg == pkgSID - -- Libraries only! We don't cover testsuite modules, so we never need - -- the paths to their mix dirs. Furthermore, we do not install testsuites... - && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) - -- We only want coverage for libraries which are dependencies of the given one - && pkgSID `elem` map (confSrcId . fst) libDeps - - isIndefiniteOrInstantiation :: ModuleShape -> Bool - isIndefiniteOrInstantiation = not . Set.null . modShapeRequires +-- determineCoverageFor +-- :: ElaboratedConfiguredPackage +-- -- ^ The package or component being configured +-- -> ElaboratedInstallPlan +-- -> Flag [UnitId] +-- determineCoverageFor configuredPkg plan = +-- Flag +-- $ mapMaybe +-- ( \case +-- InstallPlan.Installed elab +-- | shouldCoverPkg elab -> Just $ elabUnitId elab +-- InstallPlan.Configured elab +-- | shouldCoverPkg elab -> Just $ elabUnitId elab +-- _ -> Nothing +-- ) +-- $ Graph.toList +-- $ InstallPlan.toGraph plan +-- where +-- libDeps = elabLibDependencies configuredPkg +-- shouldCoverPkg elab@ElaboratedConfiguredPackage{elabModuleShape, elabPkgSourceId = pkgSID, elabLocalToProject} = +-- elabLocalToProject +-- && not (isIndefiniteOrInstantiation elabModuleShape) +-- -- TODO(#9493): We can only cover libraries in the same package +-- -- as the testsuite +-- && elabPkgSourceId configuredPkg == pkgSID +-- -- Libraries only! We don't cover testsuite modules, so we never need +-- -- the paths to their mix dirs. Furthermore, we do not install testsuites... +-- && maybe False (\case CLibName{} -> True; CNotLibName{} -> False) (elabComponentName elab) +-- -- We only want coverage for libraries which are dependencies of the given one +-- && pkgSID `elem` map (confSrcId . fst) libDeps + +-- isIndefiniteOrInstantiation :: ModuleShape -> Bool +-- isIndefiniteOrInstantiation = not . Set.null . modShapeRequires -- While we can talk to older Cabal versions (we need to be able to -- do so for custom Setup scripts that require older Cabal lib diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs index afacc83f06c..d2a5f186e18 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs @@ -6,6 +6,7 @@ module Distribution.Client.ProjectPlanning.Stage ( WithStage (..) , Stage (..) , HasStage (..) + , Staged (..) ) where import Distribution.Client.Compat.Prelude @@ -14,7 +15,7 @@ import Prelude () import Distribution.Client.Types.ConfiguredId (HasConfiguredId (..)) import Distribution.Compat.Graph (IsNode (..)) import Distribution.Package (HasUnitId (..), Package (..)) -import Distribution.Solver.Types.Stage (Stage (..)) +import Distribution.Solver.Types.Stage (Stage (..), Staged (..)) import Text.PrettyPrint (colon) -- FIXME: blaaah diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index ab1fc8be09c..09ae286491b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} @@ -14,6 +15,7 @@ module Distribution.Client.ProjectPlanning.Types -- * Elaborated install plan types , ElaboratedInstallPlan , normaliseConfiguredPackage + , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) , showElaboratedInstallPlan , elabDistDirParams @@ -65,6 +67,8 @@ module Distribution.Client.ProjectPlanning.Types , Stage (..) , Staged (..) , WithStage (..) + , withStage + , HasStage (..) -- * Setup script , SetupScriptStyle (..) @@ -130,10 +134,9 @@ import Distribution.Version import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map -import qualified Data.Monoid as Mon import qualified Distribution.Compat.Graph as Graph import System.FilePath (()) -import Text.PrettyPrint (hsep, parens, text) +import Text.PrettyPrint (colon, hsep, parens, text) -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -143,14 +146,27 @@ import Text.PrettyPrint (hsep, parens, text) -- connections). type ElaboratedInstallPlan = GenericInstallPlan - InstalledPackageInfo + ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage type ElaboratedPlanPackage = GenericPlanPackage - InstalledPackageInfo + ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage +instance HasStage ElaboratedPlanPackage where + stageOf (PreExisting ipkg) = stageOf ipkg + stageOf (Configured srcpkg) = stageOf srcpkg + stageOf (Installed srcpkg) = stageOf srcpkg + +instance HasStage ElaboratedPackage where + stageOf = pkgStage + +withStage :: HasStage a => a -> WithStage a +withStage a = WithStage (stageOf a) a + +type ElaboratedInstalledPackageInfo = WithStage InstalledPackageInfo + -- | User-friendly display string for an 'ElaboratedPlanPackage'. elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String elabPlanPackageName verbosity (PreExisting ipkg) @@ -164,6 +180,7 @@ elabPlanPackageName verbosity (Installed elab) = showElaboratedInstallPlan :: ElaboratedInstallPlan -> String showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where + showNode :: ElaboratedPlanPackage -> InstallPlan.ShowPlanNode showNode pkg = InstallPlan.ShowPlanNode { InstallPlan.showPlanHerald = herald @@ -187,7 +204,10 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode installed_deps = map pretty . nodeNeighbors - local_deps cfg = [(if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg] + local_deps cfg = + [ (if internal then text "+" else mempty) <> pretty s <> colon <> pretty (confInstId uid) + | (WithStage s uid, internal) <- elabLibDependencies cfg + ] -- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things @@ -500,10 +520,14 @@ instance HasUnitId ElaboratedConfiguredPackage where installedUnitId = elabUnitId instance IsNode ElaboratedConfiguredPackage where - type Key ElaboratedConfiguredPackage = UnitId - nodeKey = elabUnitId + type Key ElaboratedConfiguredPackage = WithStage UnitId + nodeKey elab = WithStage (elabStage elab) (elabUnitId elab) nodeNeighbors = elabOrderDependencies +instance HasStage ElaboratedConfiguredPackage where + stageOf :: ElaboratedConfiguredPackage -> Stage + stageOf = elabStage + instance Binary ElaboratedConfiguredPackage instance Structured ElaboratedConfiguredPackage @@ -562,45 +586,52 @@ elabDistDirParams shared elab = -- 'nodeNeighbors'. -- -- NB: this method DOES include setup deps. -elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = - case elabPkgOrComp elab of - -- Important not to have duplicates: otherwise InstallPlan gets - -- confused. - ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) - ElabComponent comp -> compOrderDependencies comp + elabOrderLibDependencies elab ++ elabOrderExeDependencies elab -- | Like 'elabOrderDependencies', but only returns dependencies on -- libraries. -elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> - map (newSimpleUnitId . confInstId) $ - ordNub $ - CD.flatDeps (map fst <$> pkgLibDependencies pkg) - ElabComponent comp -> compOrderLibDependencies comp + ordNub + [ WithStage (pkgStage pkg) (newSimpleUnitId (confInstId cid)) + | cid <- CD.flatDeps (map fst <$> pkgLibDependencies pkg) + ] + ElabComponent comp -> + [ WithStage (elabStage elab) c + | c <- compOrderLibDependencies comp + ] -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. -- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] +elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] elabLibDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp + ElabPackage pkg -> + ordNub + [ (WithStage (pkgStage pkg) cid, promised) + | (cid, promised) <- CD.nonSetupDeps (pkgLibDependencies pkg) + ] + ElabComponent comp -> + [ (WithStage (elabStage elab) c, promised) + | (c, promised) <- compLibDependencies comp + ] -- | Like 'elabOrderDependencies', but only returns dependencies on -- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies + fmap (fmap newSimpleUnitId) . elabExeDependencies -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. -elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies elab = map confInstId $ +elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] +elabExeDependencies elab = fmap (fmap confInstId) $ case elabPkgOrComp elab of ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) ElabComponent comp -> compExeDependencies comp @@ -618,10 +649,15 @@ elabExeDependencyPaths elab = -- | The setup dependencies (the library dependencies of the setup executable; -- note that it is not legal for setup scripts to have executable -- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] +elabSetupDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] elabSetupDependencies elab = case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) + -- FIXME: this should be wrong. Setup and its dependencies can be on a different stage. Where did that information go? + ElabPackage pkg -> + ordNub + [ (WithStage (pkgStage pkg) cid, promised) + | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) + ] -- TODO: Custom setups not supported for components yet. When -- they are, need to do this differently ElabComponent _ -> [] @@ -694,12 +730,12 @@ data ElaboratedComponent = ElaboratedComponent -- dependencies. , compInstantiatedWith :: Map ModuleName Module , compLinkedInstantiatedWith :: Map ModuleName OpenModule - , compExeDependencies :: [ConfiguredId] + , compExeDependencies :: [WithStage ConfiguredId] -- ^ The executable dependencies of this component (including -- internal executables). , compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] -- ^ The @pkg-config@ dependencies of the component - , compExeDependencyPaths :: [(ConfiguredId, FilePath)] + , compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] -- ^ The paths all our executable dependencies will be installed -- to once they are installed. , compOrderLibDependencies :: [UnitId] @@ -715,18 +751,9 @@ data ElaboratedComponent = ElaboratedComponent instance Binary ElaboratedComponent instance Structured ElaboratedComponent --- | See 'elabOrderDependencies'. -compOrderDependencies :: ElaboratedComponent -> [UnitId] -compOrderDependencies comp = - compOrderLibDependencies comp - ++ compOrderExeDependencies comp - --- | See 'elabOrderExeDependencies'. -compOrderExeDependencies :: ElaboratedComponent -> [UnitId] -compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies - data ElaboratedPackage = ElaboratedPackage - { pkgInstalledId :: InstalledPackageId + { pkgStage :: Stage + , pkgInstalledId :: InstalledPackageId , pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)] -- ^ The exact dependencies (on other plan packages) -- The boolean value indicates whether the dependency is a promised dependency @@ -736,9 +763,9 @@ data ElaboratedPackage = ElaboratedPackage -- defined library. These are used by 'elabRequiresRegistration', -- to determine if a user-requested build is going to need -- a library registration - , pkgExeDependencies :: ComponentDeps [ConfiguredId] + , pkgExeDependencies :: ComponentDeps [WithStage ConfiguredId] -- ^ Dependencies on executable packages. - , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)] + , pkgExeDependencyPaths :: ComponentDeps [(WithStage ConfiguredId, FilePath)] -- ^ Paths where executable dependencies live. , pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)] -- ^ Dependencies on @pkg-config@ packages. @@ -799,10 +826,14 @@ whyNotPerComponent = \case -- | See 'elabOrderDependencies'. This gives the unflattened version, -- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) - `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) + fmap + (map (\(cid, _) -> WithStage (pkgStage pkg) (newSimpleUnitId $ confInstId cid))) + (pkgLibDependencies pkg) + <> fmap + (map (fmap (newSimpleUnitId . confInstId))) + (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 58555cecd9d..e19e096b600 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -959,11 +959,11 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "disabled component kinds" @@ -985,9 +985,9 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "requested component kinds" @@ -1002,8 +1002,8 @@ testTargetProblemsBuild config reportSubCase = do [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion @@ -1090,8 +1090,8 @@ testTargetProblemsRepl config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "libs-disabled" @@ -1160,7 +1160,7 @@ testTargetProblemsRepl config reportSubCase = do (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] Nothing] - [("p-0.1-inplace", (CLibName LMainLibName))] + [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))] -- When we select the package with an explicit filter then we get those -- components even though we did not explicitly enable tests/benchmarks assertProjectDistinctTargets @@ -1168,13 +1168,13 @@ testTargetProblemsRepl config reportSubCase = do (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind)] - [("p-0.1-inplace-a-testsuite", CTestName "a-testsuite")] + [(WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite")] assertProjectDistinctTargets elaboratedPlan (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind)] - [("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")] + [(WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark")] testTargetProblemsListBin :: ProjectConfig -> (String -> IO ()) -> Assertion testTargetProblemsListBin config reportSubCase = do @@ -1187,7 +1187,7 @@ testTargetProblemsListBin config reportSubCase = do CmdListBin.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace-p1", CExeName "p1") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") ] reportSubCase "multiple-exes" @@ -1224,8 +1224,8 @@ testTargetProblemsListBin config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "exes-disabled" @@ -1272,7 +1272,7 @@ testTargetProblemsRun config reportSubCase = do CmdRun.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace-p1", CExeName "p1") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") ] reportSubCase "multiple-exes" @@ -1309,8 +1309,8 @@ testTargetProblemsRun config reportSubCase = do [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") + [ (WithStage Host "p-0.1-inplace-p1", CExeName "p1") + , (WithStage Host "p-0.1-inplace-p2", CExeName "p2") ] reportSubCase "exes-disabled" @@ -1713,11 +1713,11 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget [mkTargetPackage "p-0.1"] - [ ("p-0.1-inplace", (CLibName LMainLibName)) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace", (CLibName LMainLibName)) + , (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] reportSubCase "disabled component kinds" @@ -1729,7 +1729,7 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget [mkTargetPackage "p-0.1"] - [("p-0.1-inplace", (CLibName LMainLibName))] + [(WithStage Host "p-0.1-inplace", (CLibName LMainLibName))] reportSubCase "requested component kinds" -- When we selecting the package with an explicit filter then it does not @@ -1744,10 +1744,10 @@ testTargetProblemsHaddock config reportSubCase = do , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") + [ (WithStage Host "p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") + , (WithStage Host "p-0.1-inplace-a-testsuite", CTestName "a-testsuite") + , (WithStage Host "p-0.1-inplace-an-exe", CExeName "an-exe") + , (WithStage Host "p-0.1-inplace-libp", CFLibName "libp") ] where mkHaddockFlags flib exe test bench = @@ -1765,7 +1765,7 @@ assertProjectDistinctTargets -> (forall k. TargetSelector -> [AvailableTarget k] -> Either (TargetProblem err) [k]) -> (forall k. SubComponentTarget -> AvailableTarget k -> Either (TargetProblem err) k) -> [TargetSelector] - -> [(UnitId, ComponentName)] + -> [(WithStage UnitId, ComponentName)] -> Assertion assertProjectDistinctTargets elaboratedPlan @@ -2242,7 +2242,7 @@ executePlan , elaboratedPlan , elaboratedShared ) = do - let targets :: Map.Map UnitId [ComponentTarget] + let targets :: Map.Map (WithStage UnitId) [ComponentTarget] targets = Map.fromList [ (unitid, [ComponentTarget cname WholeComponent]) @@ -2346,7 +2346,7 @@ expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO InstalledPackageInfo + -> IO (WithStage InstalledPackageInfo) expectPackagePreExisting plan buildOutcomes pkgid = do planpkg <- expectPlanPackage plan pkgid case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of From 81b922aa09eea24035d093f783a039df70df38f3 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 13:59:33 +0800 Subject: [PATCH 035/122] fix(cabal-install): rewrite instantiateInstallPlan --- .../Distribution/Client/ProjectPlanning.hs | 303 ++++++++++-------- 1 file changed, 167 insertions(+), 136 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 18c982eeb02..ff768f2b5dc 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -204,7 +204,7 @@ import Distribution.Types.PackageVersionConstraint import Distribution.Types.PkgconfigDependency import Distribution.Types.UnqualComponentName -import Distribution.Backpack +import Distribution.Backpack hiding (mkDefUnitId) import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent import Distribution.Backpack.FullUnitId @@ -229,7 +229,7 @@ import qualified Distribution.Compat.Graph as Graph import Control.Exception (assert) import Control.Monad (sequence) import Control.Monad.IO.Class (liftIO) -import Control.Monad.State as State (State, execState, runState, state) +import Control.Monad.State (State, execState, gets, modify) import Data.Foldable (fold) import Data.List (deleteBy, groupBy) import qualified Data.List.NonEmpty as NE @@ -2791,7 +2791,7 @@ binDirectories layout config package = case elabBuildStyle package of distBuildDirectory layout (elabDistDirParams config package) "build" -type InstS = Map UnitId ElaboratedPlanPackage +type InstS = Map (WithStage UnitId) ElaboratedPlanPackage type InstM a = State InstS a getComponentId @@ -2875,67 +2875,75 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = where pkgs = InstallPlan.toList plan - cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs] + cmap = Map.fromList [(WithStage (stageOf pkg) (getComponentId pkg), pkg) | pkg <- pkgs] instantiateUnitId - :: ComponentId + :: Stage + -> ComponentId + -- \^ The id of the component being instantiated -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names (the "holes" or signatures in Backpack) + -- to the concrete modules (and their build styles) that should fill those + -- holes. -> InstM (DefUnitId, BuildStyle) - instantiateUnitId cid insts = state $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - -- TODO: I don't think the knot tying actually does - -- anything useful - let (r, s') = - runState - (instantiateComponent uid cid insts) - (Map.insert uid r s) - in ((def_uid, extractElabBuildStyle r), Map.insert uid r s') - Just r -> ((def_uid, extractElabBuildStyle r), s) + instantiateUnitId stage cid insts = + gets (Map.lookup (WithStage stage uid)) >>= \case + Nothing -> do + r <- instantiateComponent uid (WithStage stage cid) insts + modify (Map.insert (WithStage stage uid) r) + return (unsafeMkDefUnitId uid, extractElabBuildStyle r) + Just r -> + return (unsafeMkDefUnitId uid, extractElabBuildStyle r) where - def_uid = mkDefUnitId cid (fmap fst insts) - uid = unDefUnitId def_uid + uid = mkDefUnitId cid (fmap fst insts) -- No need to InplaceT; the inplace-ness is properly computed for -- the ElaboratedPlanPackage, so that will implicitly pass it on instantiateComponent :: UnitId - -> ComponentId + -- \^ The unit id to assign to the instantiated component + -> WithStage ComponentId + -- \^ The id of the component being instantiated -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names (the "holes" or signatures in Backpack) + -- to the concrete modules (and their build styles) that should fill those + -- holes. -> InstM ElaboratedPlanPackage - instantiateComponent uid cid insts - | Just planpkg <- Map.lookup cid cmap = + instantiateComponent uid cidws@(WithStage stage cid) insts = + case Map.lookup cidws cmap of + Nothing -> error ("instantiateComponent: " ++ prettyShow cid) + Just planpkg -> case planpkg of - InstallPlan.Configured - ( elab0@ElaboratedConfiguredPackage - { elabPkgOrComp = ElabComponent comp - } - ) -> do - deps <- - traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp) - let build_style = fold (fmap snd insts) - let getDep (Module dep_uid _) = [dep_uid] - elab1 = - fixupBuildStyle build_style $ - elab0 - { elabUnitId = uid - , elabComponentId = cid - , elabIsCanonical = Map.null (fmap fst insts) - , elabPkgOrComp = - ElabComponent - comp - { compOrderLibDependencies = - (if Map.null insts then [] else [newSimpleUnitId cid]) - ++ ordNub - ( map - unDefUnitId - (deps ++ concatMap (getDep . fst) (Map.elems insts)) - ) - , compInstantiatedWith = fmap fst insts - } - } - elab = + InstallPlan.Installed{} -> return planpkg + InstallPlan.PreExisting{} -> return planpkg + InstallPlan.Configured elab0 -> + case elabPkgOrComp elab0 of + ElabPackage{} -> return planpkg + ElabComponent comp -> do + deps <- traverse (fmap fst . instantiateUnit stage insts) (compLinkedLibDependencies comp) + let build_style = fold (fmap snd insts) + let getDep (Module dep_uid _) = [dep_uid] + elab1 = + fixupBuildStyle build_style $ + elab0 + { elabUnitId = uid + , elabComponentId = cid + , elabIsCanonical = Map.null (fmap fst insts) + , elabPkgOrComp = + ElabComponent + comp + { compOrderLibDependencies = + (if Map.null insts then [] else [newSimpleUnitId cid]) + ++ ordNub + ( map + unDefUnitId + (deps ++ concatMap (getDep . fst) (Map.elems insts)) + ) + , compInstantiatedWith = fmap fst insts + } + } + return $ + InstallPlan.Configured elab1 { elabInstallDirs = computeInstallDirs @@ -2944,112 +2952,135 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = elaboratedShared elab1 } - return $ InstallPlan.Configured elab - _ -> return planpkg - | otherwise = error ("instantiateComponent: " ++ prettyShow cid) - substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle) - substUnitId _ (DefiniteUnitId uid) = + -- \| Instantiates an OpenUnitId into a concrete UnitId, producing a concrete UnitId and its associated BuildStyle. + -- + -- This function recursively applies a module substitution to an OpenUnitId, producing a fully instantiated + -- (definite) unit and its build style. This is a key step in Backpack-style instantiation, where "holes" in + -- a package are filled with concrete modules. + -- + -- Behavior + -- + -- If given a DefiniteUnitId, it returns the id and a default build style (BuildAndInstall). + -- + -- If given an IndefFullUnitId, it: + -- Recursively applies the substitution to each module in the instantiation map using substSubst. + -- Calls instantiateUnitId to create or retrieve the fully instantiated unit id and build style for this instantiation. + -- + instantiateUnit + :: Stage + -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names to their corresponding modules and build styles. + -> OpenUnitId + -- \^ The unit to instantiate. This can be: + -- DefiniteUnitId uid: already fully instantiated (no holes). + -- IndefFullUnitId cid insts: an indefinite unit (with holes), described by a component id and a mapping of holes to modules. + -> InstM (DefUnitId, BuildStyle) + instantiateUnit _stage _subst (DefiniteUnitId def_uid) = -- This COULD actually, secretly, be an inplace package, but in -- that case it doesn't matter as it's already been recorded -- in the package that depends on this - return (uid, BuildAndInstall) - substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' - - -- NB: NOT composition - substSubst - :: Map ModuleName (Module, BuildStyle) - -> Map ModuleName OpenModule - -> InstM (Map ModuleName (Module, BuildStyle)) - substSubst subst insts = traverse (substModule subst) insts - - substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle) - substModule subst (OpenModuleVar mod_name) + return (def_uid, BuildAndInstall) + instantiateUnit stage subst (IndefFullUnitId cid insts) = do + insts' <- traverse (instantiateModule stage subst) insts + instantiateUnitId stage cid insts' + + -- \| Instantiates an OpenModule into a concrete Module producing a concrete Module + -- and its associated BuildStyle. + instantiateModule + :: Stage + -> Map ModuleName (Module, BuildStyle) + -- \^ A mapping from module names to their corresponding modules and build styles. + -> OpenModule + -- \^ The module to substitute, which can be: + -- OpenModuleVar mod_name: a hole (variable) named mod_name + -- OpenModule uid mod_name: a module from a specific unit (uid). + -> InstM (Module, BuildStyle) + instantiateModule _stage subst (OpenModuleVar mod_name) | Just m <- Map.lookup mod_name subst = return m | otherwise = error "substModule: non-closing substitution" - substModule subst (OpenModule uid mod_name) = do - (uid', build_style) <- substUnitId subst uid + instantiateModule stage subst (OpenModule uid mod_name) = do + (uid', build_style) <- instantiateUnit stage subst uid return (Module uid' mod_name, build_style) - indefiniteUnitId :: ComponentId -> InstM UnitId - indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - state $ \s -> (uid, Map.insert uid r s) - - indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage - indefiniteComponent _uid cid - -- Only need Configured; this phase happens before improvement, so - -- there shouldn't be any Installed packages here. - | Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap - , ElabComponent elab_comp <- elabPkgOrComp epkg = - do - -- We need to do a little more processing of the includes: some - -- of them are fully definite even without substitution. We - -- want to build those too; see #5634. - -- - -- This code mimics similar code in Distribution.Backpack.ReadyComponent; - -- however, unlike the conversion from LinkedComponent to - -- ReadyComponent, this transformation is done *without* - -- changing the type in question; and what we are simply - -- doing is enforcing tighter invariants on the data - -- structure in question. The new invariant is that there - -- is no IndefFullUnitId in compLinkedLibDependencies that actually - -- has no holes. We couldn't specify this invariant when - -- we initially created the ElaboratedPlanPackage because - -- we have no way of actually reifying the UnitId into a - -- DefiniteUnitId (that's what substUnitId does!) - new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> - if Set.null (openUnitIdFreeHoles uid) - then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid) - else return uid - -- NB: no fixupBuildStyle needed here, as if the indefinite - -- component depends on any inplace packages, it itself must - -- be indefinite! There is no substitution here, we can't - -- post facto add inplace deps - return . InstallPlan.Configured $ - epkg - { elabPkgOrComp = - ElabComponent - elab_comp - { compLinkedLibDependencies = new_deps - , -- I think this is right: any new definite unit ids we - -- minted in the phase above need to be built before us. - -- Add 'em in. This doesn't remove any old dependencies - -- on the indefinite package; they're harmless. - compOrderLibDependencies = - ordNub $ - compOrderLibDependencies elab_comp - ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] - } - } - | Just planpkg <- Map.lookup cid cmap = - return planpkg - | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) + indefiniteComponent + :: ElaboratedConfiguredPackage + -> InstM ElaboratedConfiguredPackage + indefiniteComponent epkg = + case elabPkgOrComp epkg of + ElabPackage{} -> return epkg + ElabComponent elab_comp -> do + -- We need to do a little more processing of the includes: some + -- of them are fully definite even without substitution. We + -- want to build those too; see #5634. + -- + -- This code mimics similar code in Distribution.Backpack.ReadyComponent; + -- however, unlike the conversion from LinkedComponent to + -- ReadyComponent, this transformation is done *without* + -- changing the type in question; and what we are simply + -- doing is enforcing tighter invariants on the data + -- structure in question. The new invariant is that there + -- is no IndefFullUnitId in compLinkedLibDependencies that actually + -- has no holes. We couldn't specify this invariant when + -- we initially created the ElaboratedPlanPackage because + -- we have no way of actually reifying the UnitId into a + -- DefiniteUnitId (that's what substUnitId does!) + new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> + if Set.null (openUnitIdFreeHoles uid) + then fmap (DefiniteUnitId . fst) (instantiateUnit (elabStage epkg) Map.empty uid) + else return uid + -- NB: no fixupBuildStyle needed here, as if the indefinite + -- component depends on any inplace packages, it itself must + -- be indefinite! There is no substitution here, we can't + -- post facto add inplace deps + return + epkg + { elabPkgOrComp = + ElabComponent + elab_comp + { compLinkedLibDependencies = new_deps + , -- I think this is right: any new definite unit ids we + -- minted in the phase above need to be built before us. + -- Add 'em in. This doesn't remove any old dependencies + -- on the indefinite package; they're harmless. + compOrderLibDependencies = + ordNub $ + compOrderLibDependencies elab_comp + ++ [unDefUnitId d | DefiniteUnitId d <- new_deps] + } + } fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab - fixupBuildStyle t@(BuildInplaceOnly{}) elab = + fixupBuildStyle _buildStyle (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab + fixupBuildStyle buildStyle@(BuildInplaceOnly{}) elab = elab - { elabBuildStyle = t + { elabBuildStyle = buildStyle , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab } ready_map = execState work Map.empty - work = for_ pkgs $ \pkg -> case pkg of InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) - | not (Map.null (compLinkedInstantiatedWith comp)) -> - indefiniteUnitId (elabComponentId elab) - >> return () + | not (Map.null (compLinkedInstantiatedWith comp)) -> do + r <- indefiniteComponent elab + modify (Map.insert (WithStage (elabStage elab) (elabUnitId elab)) (InstallPlan.Configured r)) _ -> - instantiateUnitId (getComponentId pkg) Map.empty - >> return () + void $ instantiateUnitId (stageOf pkg) (getComponentId pkg) Map.empty + +-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation +-- with no holes. +-- +-- This function is defined in Cabal-syntax but only cabal-install +-- cares about it so I am putting it here. +-- +-- I am also not using the DefUnitId newtype since I believe it +-- provides little value in the code above. +mkDefUnitId :: ComponentId -> Map ModuleName Module -> UnitId +mkDefUnitId cid insts = + mkUnitId (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts)) --------------------------- -- Build targets From cbd4ee31d76fe4f14606e76b74cf65244b9117ee Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 14 Jul 2025 12:42:15 +0800 Subject: [PATCH 036/122] refactor(cabal-install): reduce scope in ProjectPlanning --- .../Distribution/Client/ProjectPlanning.hs | 50 +++++++------------ 1 file changed, 17 insertions(+), 33 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ff768f2b5dc..d54dd0adb32 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1808,40 +1808,26 @@ elaborateInstallPlan , elabPkgOrComp = ElabComponent ( ElaboratedComponent - { compSolverName - , compComponentName - , compLibDependencies - , compLinkedLibDependencies - , compExeDependencies - , compPkgConfigDependencies - , compExeDependencyPaths - , compOrderLibDependencies - , compInstantiatedWith - , compLinkedInstantiatedWith + { compSolverName = CD.ComponentSetup + , compComponentName = Nothing + , compLibDependencies = + [ (configuredId cid, False) + | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep + ] + , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + , compOrderLibDependencies = notImpl "compOrderLibDependencies" + , -- Not supported: + compExeDependencies = mempty + , compExeDependencyPaths = mempty + , compPkgConfigDependencies = mempty + , compInstantiatedWith = mempty + , compLinkedInstantiatedWith = Map.empty } ) } | otherwise = Nothing where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps solverPkgLibDeps - - compLibDependencies = - -- MP: No idea what this function does - map (\cid -> (configuredId cid, False)) dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - - -- Not supported: - compExeDependencies = [] - compExeDependencyPaths = [] - compPkgConfigDependencies = [] - compInstantiatedWith = mempty - compLinkedInstantiatedWith = Map.empty - notImpl f = error $ "Distribution.Client.ProjectPlanning.setupComponent: " @@ -1945,13 +1931,14 @@ elaborateInstallPlan { compSolverName , compComponentName , compLibDependencies - , compLinkedLibDependencies , compExeDependencies , compPkgConfigDependencies , compExeDependencyPaths - , compOrderLibDependencies , compInstantiatedWith = Map.empty , compLinkedInstantiatedWith = Map.empty + , -- filled later (in step 5) + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" } -- 3. Construct a preliminary ElaboratedConfiguredPackage, @@ -2043,9 +2030,6 @@ elaborateInstallPlan return ((cc_map', lc_map', exe_map'), elab) where - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - cname = Cabal.componentName comp compComponentName = Just cname compSolverName = CD.componentNameToComponent cname From dcc3a405e7631425e6446a33b7f377b43be935fc Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 20 May 2025 15:36:13 +0800 Subject: [PATCH 037/122] refactor(cabal-install): readability improvements --- .../Distribution/Client/ProjectPlanning.hs | 196 +++++++++--------- 1 file changed, 96 insertions(+), 100 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d54dd0adb32..09a817f20d4 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1946,7 +1946,7 @@ elaborateInstallPlan -- correctly. let elab1 = elab0 - { elabPkgOrComp = ElabComponent $ elab_comp + { elabPkgOrComp = ElabComponent elab_comp } cid = case elabBuildStyle elab0 of BuildInplaceOnly{} -> @@ -2131,15 +2131,7 @@ elaborateInstallPlan -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent - pkg@( SolverPackage - _stage - _qpn - (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags - _stanzas - _deps0 - _exe_deps0 - ) + pkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} compGraph comps = do -- Knot tying: the final elab includes the @@ -2189,7 +2181,7 @@ elaborateInstallPlan pkgInstalledId | shouldBuildInplaceOnly pkg = - mkComponentId (prettyShow pkgid ++ "-inplace") + mkComponentId (prettyShow srcpkgPackageId ++ "-inplace") | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId @@ -2200,7 +2192,7 @@ elaborateInstallPlan -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. - isExternal confid = confSrcId confid /= pkgid + isExternal confid = confSrcId confid /= srcpkgPackageId isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId pkgLibDependencies = @@ -2248,15 +2240,19 @@ elaborateInstallPlan :: SolverPackage UnresolvedPkgLoc -> ElaboratedConfiguredPackage elaborateSolverToCommon - pkg@( SolverPackage - stage - _qpn - (SourcePackage pkgid gdesc srcloc descOverride) - flags - stanzas - deps0 - _exe_deps0 - ) = + pkg@SolverPackage + { solverPkgStage + , solverPkgSource = + SourcePackage + { srcpkgPackageId + , srcpkgDescription + , srcpkgSource + , srcpkgDescrOverride + } + , solverPkgFlags + , solverPkgStanzas + , solverPkgLibDeps + } = elaboratedPackage where elaboratedPackage = ElaboratedConfiguredPackage{..} @@ -2269,32 +2265,32 @@ elaborateInstallPlan elabModuleShape = error "elaborateSolverToCommon: elabModuleShape" elabIsCanonical = True - elabPkgSourceId = pkgid + elabPkgSourceId = srcpkgPackageId - elabStage = stage - elabCompiler = toolchainCompiler (getStage toolchains stage) - elabPlatform = toolchainPlatform (getStage toolchains stage) - elabProgramDb = toolchainProgramDb (getStage toolchains stage) + elabStage = solverPkgStage + elabCompiler = toolchainCompiler (getStage toolchains solverPkgStage) + elabPlatform = toolchainPlatform (getStage toolchains solverPkgStage) + elabProgramDb = toolchainProgramDb (getStage toolchains solverPkgStage) elabPkgDescription = case PD.finalizePD - flags + solverPkgFlags elabEnabledSpec (const Satisfied) elabPlatform (compilerInfo elabCompiler) [] - gdesc of + srcpkgDescription of Right (desc, _) -> desc Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabFlagAssignment = flags + elabFlagAssignment = solverPkgFlags elabFlagDefaults = PD.mkFlagAssignment [ (PD.flagName flag, PD.flagDefault flag) - | flag <- PD.genPackageFlags gdesc + | flag <- PD.genPackageFlags srcpkgDescription ] - elabEnabledSpec = enableStanzas stanzas - elabStanzasAvailable = stanzas + elabEnabledSpec = enableStanzas solverPkgStanzas + elabStanzasAvailable = solverPkgStanzas elabStanzasRequested :: OptionalStanzaMap (Maybe Bool) elabStanzasRequested = optStanzaTabulate $ \o -> case o of @@ -2308,8 +2304,8 @@ elaborateInstallPlan BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription] where tests, benchmarks :: Maybe Bool - tests = perPkgOptionMaybe pkgid packageConfigTests - benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks + tests = perPkgOptionMaybe srcpkgPackageId packageConfigTests + benchmarks = perPkgOptionMaybe srcpkgPackageId packageConfigBenchmarks -- This is a placeholder which will get updated by 'pruneInstallPlanPass1' -- and 'pruneInstallPlanPass2'. We can't populate it here @@ -2327,7 +2323,7 @@ elaborateInstallPlan elabHaddockTargets = [] elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation + perPkgOptionFlag srcpkgPackageId False packageConfigDocumentation -- `documentation: true` should imply `-haddock` for GHC addHaddockIfDocumentationEnabled :: ConfiguredProgram -> ConfiguredProgram @@ -2336,8 +2332,8 @@ elaborateInstallPlan then cp{programOverrideArgs = "-haddock" : programOverrideArgs} else cp - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabPkgSourceLocation = srcpkgSource + elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes elabLocalToProject = isLocalToProject pkg elabBuildStyle = if shouldBuildInplaceOnly pkg @@ -2353,7 +2349,7 @@ elaborateInstallPlan elabSetupScriptStyle elabPkgDescription libDepGraph - deps0 + solverPkgLibDeps elabSetupPackageDBStack = buildAndRegisterDbs inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)] @@ -2368,49 +2364,49 @@ elaborateInstallPlan | shouldBuildInplaceOnly pkg = inplacePackageDbs | otherwise = corePackageDbs - elabPkgDescriptionOverride = descOverride + elabPkgDescriptionOverride = srcpkgDescrOverride elabBuildOptions = LBC.BuildOptions - { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - , withStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib + { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively + , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary + , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib , withDynExe = - perPkgOptionFlag pkgid False packageConfigDynExe + perPkgOptionFlag srcpkgPackageId False packageConfigDynExe -- We can't produce a dynamic executable if the user -- wants to enable executable profiling but the -- compiler doesn't support prof+dyn. && (okProfDyn || not profExe) - , withFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe - , withGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still - , withProfExe = profExe - , withProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - , withProfLibShared = pkgid `Set.member` pkgsUseProfilingLibraryShared - , exeCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - , libCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - , withOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - , splitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - , splitSections = perPkgOptionFlag pkgid False packageConfigSplitSections - , stripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - , stripExes = perPkgOptionFlag pkgid False packageConfigStripExes - , withDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo - , relocatable = perPkgOptionFlag pkgid False packageConfigRelocatable + , withFullyStaticExe = perPkgOptionFlag srcpkgPackageId False packageConfigFullyStaticExe + , withGHCiLib = perPkgOptionFlag srcpkgPackageId False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still + , withProfExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf + , withProfLib = srcpkgPackageId `Set.member` pkgsUseProfilingLibrary + , withProfLibShared = srcpkgPackageId `Set.member` pkgsUseProfilingLibraryShared + , exeCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage + , libCoverage = perPkgOptionFlag srcpkgPackageId False packageConfigCoverage + , withOptimization = perPkgOptionFlag srcpkgPackageId NormalOptimisation packageConfigOptimization + , splitObjs = perPkgOptionFlag srcpkgPackageId False packageConfigSplitObjs + , splitSections = perPkgOptionFlag srcpkgPackageId False packageConfigSplitSections + , stripLibs = perPkgOptionFlag srcpkgPackageId False packageConfigStripLibs + , stripExes = perPkgOptionFlag srcpkgPackageId False packageConfigStripExes + , withDebugInfo = perPkgOptionFlag srcpkgPackageId NoDebugInfo packageConfigDebugInfo + , relocatable = perPkgOptionFlag srcpkgPackageId False packageConfigRelocatable , withProfLibDetail = elabProfExeDetail , withProfExeDetail = elabProfLibDetail } okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler - profExe = perPkgOptionFlag pkgid False packageConfigProf + profExe = perPkgOptionFlag srcpkgPackageId False packageConfigProf ( elabProfExeDetail , elabProfLibDetail ) = perPkgOptionLibExeFlag - pkgid + srcpkgPackageId ProfDetailDefault packageConfigProfDetail packageConfigProfLibDetail - elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo + elabDumpBuildInfo = perPkgOptionFlag srcpkgPackageId NoDumpBuildInfo packageConfigDumpBuildInfo -- Combine the configured compiler prog settings with the user-supplied -- config. For the compiler progs any user-supplied config was taken @@ -2422,7 +2418,7 @@ elaborateInstallPlan [ (programId prog, programPath prog) | prog <- configuredPrograms elabProgramDb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths + <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths elabProgramArgs = Map.unionWith (++) @@ -2433,46 +2429,46 @@ elaborateInstallPlan , not (null args) ] ) - (perPkgOptionMapMappend pkgid packageConfigProgramArgs) - elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + (perPkgOptionMapMappend srcpkgPackageId packageConfigProgramArgs) + elabProgramPathExtra = perPkgOptionNubList srcpkgPackageId packageConfigProgramPathExtra elabConfiguredPrograms = configuredPrograms elabProgramDb - elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic - elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs - elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage - elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource - elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump - elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents - elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex - elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl - elabHaddockResourcesDir = perPkgOptionMaybe pkgid packageConfigHaddockResourcesDir - elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir - elabHaddockUseUnicode = perPkgOptionFlag pkgid False packageConfigHaddockUseUnicode - - elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog - elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog - elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails - elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix - elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper - elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites - elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions - - elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions + elabConfigureScriptArgs = perPkgOptionList srcpkgPackageId packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirs + elabExtraLibDirsStatic = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirsStatic + elabExtraFrameworkDirs = perPkgOptionList srcpkgPackageId packageConfigExtraFrameworkDirs + elabExtraIncludeDirs = perPkgOptionList srcpkgPackageId packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe srcpkgPackageId packageConfigProgPrefix + elabProgSuffix = perPkgOptionMaybe srcpkgPackageId packageConfigProgSuffix + + elabHaddockHoogle = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHoogle + elabHaddockHtml = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockHtml + elabHaddockHtmlLocation = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHtmlLocation + elabHaddockForeignLibs = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockForeignLibs + elabHaddockForHackage = perPkgOptionFlag srcpkgPackageId Cabal.ForDevelopment packageConfigHaddockForHackage + elabHaddockExecutables = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockCss + elabHaddockLinkedSource = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockQuickJump + elabHaddockHscolourCss = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockContents + elabHaddockIndex = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockIndex + elabHaddockBaseUrl = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockBaseUrl + elabHaddockResourcesDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockResourcesDir + elabHaddockOutputDir = perPkgOptionMaybe srcpkgPackageId packageConfigHaddockOutputDir + elabHaddockUseUnicode = perPkgOptionFlag srcpkgPackageId False packageConfigHaddockUseUnicode + + elabTestMachineLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestMachineLog + elabTestHumanLog = perPkgOptionMaybe srcpkgPackageId packageConfigTestHumanLog + elabTestShowDetails = perPkgOptionMaybe srcpkgPackageId packageConfigTestShowDetails + elabTestKeepTix = perPkgOptionFlag srcpkgPackageId False packageConfigTestKeepTix + elabTestWrapper = perPkgOptionMaybe srcpkgPackageId packageConfigTestWrapper + elabTestFailWhenNoTestSuites = perPkgOptionFlag srcpkgPackageId False packageConfigTestFailWhenNoTestSuites + elabTestTestOptions = perPkgOptionList srcpkgPackageId packageConfigTestTestOptions + + elabBenchmarkOptions = perPkgOptionList srcpkgPackageId packageConfigBenchmarkOptions perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a From 5b8e06bcc4943b2a293da11a6def45c162411e67 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 May 2025 12:26:32 +0800 Subject: [PATCH 038/122] fix(cabal-install): use the correct stage for setup deps --- .../Distribution/Client/ProjectPlanning.hs | 6 +- .../Client/ProjectPlanning/Types.hs | 86 ++++++++++--------- 2 files changed, 50 insertions(+), 42 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 09a817f20d4..bef61cc3534 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -3962,9 +3962,9 @@ setupHsScriptOptions , usePackageDB = elabSetupPackageDBStack , usePackageIndex = Nothing , useDependencies = - [ (uid, srcid) - | (WithStage _ (ConfiguredId srcid (Just (CLibName LMainLibName)) uid), _) <- - elabSetupDependencies elab + [ (confInstId cid, confSrcId cid) + | -- TODO: we should filter for dependencies on libraries but that should be implicit in elabSetupLibDependencies + (WithStage _ cid, _promised) <- elabSetupLibDependencies elab ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 09ae286491b..a4476e513e4 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -24,7 +24,8 @@ module Distribution.Client.ProjectPlanning.Types , elabOrderLibDependencies , elabExeDependencies , elabOrderExeDependencies - , elabSetupDependencies + , elabSetupLibDependencies + , elabSetupExeDependencies , elabPkgConfigDependencies , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration @@ -585,25 +586,28 @@ elabDistDirParams shared elab = -- use 'elabLibDependencies'. This method is the same as -- 'nodeNeighbors'. -- --- NB: this method DOES include setup deps. +-- Note: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = elabOrderLibDependencies elab ++ elabOrderExeDependencies elab --- | Like 'elabOrderDependencies', but only returns dependencies on --- libraries. +-- | The result includes setup dependencies elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> - ordNub - [ WithStage (pkgStage pkg) (newSimpleUnitId (confInstId cid)) - | cid <- CD.flatDeps (map fst <$> pkgLibDependencies pkg) - ] - ElabComponent comp -> - [ WithStage (elabStage elab) c - | c <- compOrderLibDependencies comp - ] + ordNub $ + [ fmap (newSimpleUnitId . confInstId) dep + | (dep, _promised) <- elabLibDependencies elab ++ elabSetupLibDependencies elab + ] + +-- | The result includes setup dependencies +elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] +elabOrderExeDependencies elab = + -- Compare with elabOrderLibDependencies. The setup dependencies here do not need + -- any special attention because the stage is already included in pkgExeDependencies. + map (fmap (newSimpleUnitId . confInstId)) $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.flatDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. @@ -621,20 +625,40 @@ elabLibDependencies elab = | (c, promised) <- compLibDependencies comp ] --- | Like 'elabOrderDependencies', but only returns dependencies on --- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] -elabOrderExeDependencies = - fmap (fmap newSimpleUnitId) . elabExeDependencies +-- | The setup dependencies (the library dependencies of the setup executable; +-- note that it is not legal for setup scripts to have executable +-- dependencies at the moment.) +elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] +elabSetupLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> + ordNub + [ (WithStage (prevStage (pkgStage pkg)) cid, promised) + | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) + ] + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] + +-- | This would not be allowed actually. See comment on elabSetupLibDependencies. +elabSetupExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] +elabSetupExeDependencies elab = + map (fmap confInstId) $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.setupDeps (pkgExeDependencies pkg) + -- TODO: Custom setups not supported for components yet. When + -- they are, need to do this differently + ElabComponent _ -> [] -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke -- the setup script. elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] -elabExeDependencies elab = fmap (fmap confInstId) $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp +elabExeDependencies elab = + map (fmap confInstId) $ + case elabPkgOrComp elab of + ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we -- must add these paths to PATH before invoking the setup script. @@ -646,22 +670,6 @@ elabExeDependencyPaths elab = ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) ElabComponent comp -> map snd (compExeDependencyPaths comp) --- | The setup dependencies (the library dependencies of the setup executable; --- note that it is not legal for setup scripts to have executable --- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] -elabSetupDependencies elab = - case elabPkgOrComp elab of - -- FIXME: this should be wrong. Setup and its dependencies can be on a different stage. Where did that information go? - ElabPackage pkg -> - ordNub - [ (WithStage (pkgStage pkg) cid, promised) - | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) - ] - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] - elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = pkgPkgConfigDependencies pkg From bd63c2bca1d6e5a4876f7ba31660a1beb94e3da6 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 May 2025 13:06:04 +0800 Subject: [PATCH 039/122] refactor(cabal-install): rebuildTargets Isolate the common logic between building and only downloading. _Push the ifs up and the loops down_ --- .../Distribution/Client/ProjectBuilding.hs | 109 +++++++++++------- .../Client/ProjectBuilding/Types.hs | 5 +- 2 files changed, 69 insertions(+), 45 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 98f83b47962..43bf9de0254 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -340,12 +340,57 @@ rebuildTargets -> BuildTimeSettings -> IO BuildOutcomes rebuildTargets + verbosity + projectConfig + distDirLayout + storeDirLayout + installPlan + sharedPackageConfig + pkgsBuildStatus + buildSettings + | buildSettingOnlyDownload buildSettings = do + rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ + \downloadMap _jobControl pkg pkgBuildStatus -> + rebuildTargetOnlyDownload + verbosity + downloadMap + pkg + pkgBuildStatus + | otherwise = do + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ + \downloadMap jobControl pkg pkgBuildStatus -> + rebuildTarget + verbosity + distDirLayout + storeDirLayout + (jobControlSemaphore jobControl) + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + installPlan + pkg + pkgBuildStatus + +rebuildTargets' + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> (AsyncFetchMap -> JobControl IO (Graph.Key (GenericReadyPackage ElaboratedConfiguredPackage), Either BuildFailure BuildResult) -> GenericReadyPackage ElaboratedConfiguredPackage -> BuildStatus -> IO BuildResult) + -> IO BuildOutcomes +rebuildTargets' verbosity ProjectConfig { projectConfigBuildOnly = config } - distDirLayout@DistDirLayout{..} - storeDirLayout + DistDirLayout{..} installPlan sharedPackageConfig pkgsBuildStatus @@ -353,10 +398,9 @@ rebuildTargets { buildSettingNumJobs , buildSettingKeepGoing } + act | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError | otherwise = do - registerLock <- newLock -- serialise registration - cacheLock <- newLock -- serialise access to setup exe cache -- TODO: [code cleanup] eliminate setup exe cache info verbosity $ "Executing install plan " @@ -384,26 +428,13 @@ rebuildTargets InstallPlan.execute jobControl keepGoing - (BuildFailure Nothing . DependentFailed . packageId) + (BuildFailure Nothing . DependentFailed . Graph.nodeKey) installPlan $ \pkg -> -- TODO: review exception handling handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - (jobControlSemaphore jobControl) - buildSettings - downloadMap - registerLock - cacheLock - sharedPackageConfig - installPlan - pkg - pkgBuildStatus + act downloadMap jobControl pkg pkgBuildStatus where keepGoing = buildSettingKeepGoing withRepoCtx = @@ -433,29 +464,6 @@ rebuildTargets _ -> pure () _ -> pure () - -- createPackageDBIfMissing _ _ _ _ = return () - - -- -- all the package dbs we may need to create - -- (Set.toList . Set.fromList) - -- [ pkgdb - -- | InstallPlan.Configured elab <- InstallPlan.toList installPlan - -- , pkgdb <- - -- concat - -- [ elabBuildPackageDBStack elab - -- , elabRegisterPackageDBStack elab - -- , elabSetupPackageDBStack elab - -- ] - -- ] - -- createPackageDBIfMissing - -- verbosity - -- compiler - -- progdb - -- (SpecificPackageDB dbPath) = do - -- exists <- Cabal.doesPackageDBExist dbPath - -- unless exists $ do - -- createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) - -- Cabal.createPackageDB verbosity compiler progdb False dbPath - -- createPackageDBIfMissing _ _ _ _ = return () offlineError :: BuildOutcomes offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload where @@ -624,6 +632,23 @@ rebuildTarget srcdir builddir +rebuildTargetOnlyDownload + :: Verbosity + -> AsyncFetchMap + -> GenericReadyPackage ElaboratedConfiguredPackage + -> BuildStatus + -> IO BuildResult +rebuildTargetOnlyDownload + verbosity + downloadMap + (ReadyPackage pkg) + pkgBuildStatus = do + case pkgBuildStatus of + BuildStatusDownload -> + void $ waitAsyncPackageDownload verbosity downloadMap pkg + _ -> return () + return $ BuildResult DocsNotTried TestsNotTried Nothing + -- TODO: [nice to have] do we need to use a with-style for the temp -- files for downloading http packages, or are we going to cache them -- persistently? diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 3d8b9ff9082..8a54b494f76 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -25,10 +25,9 @@ import Prelude () import Distribution.Client.FileMonitor (MonitorChangedReason (..)) import Distribution.Client.Types (DocsResult, TestsResult) -import Distribution.Client.ProjectPlanning.Types (ElaboratedPlanPackage) +import Distribution.Client.ProjectPlanning.Types (ElaboratedConfiguredPackage, ElaboratedPlanPackage) import qualified Distribution.Compat.Graph as Graph import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Package (PackageId) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -162,7 +161,7 @@ instance Exception BuildFailure -- | Detail on the reason that a package failed to build. data BuildFailureReason - = DependentFailed PackageId + = DependentFailed (Graph.Key ElaboratedConfiguredPackage) | GracefulFailure String | DownloadFailed SomeException | UnpackFailed SomeException From 1fbe93f5dd6c4f4b78bbec0ee2c3eedba8bf88fc Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 May 2025 13:30:38 +0800 Subject: [PATCH 040/122] feat(cabal-install): more logging in buildAndRegisterUnpackedPackage More logging in ProjectBuilding --- .../Distribution/Client/ProjectBuilding.hs | 12 +++++++---- .../Client/ProjectBuilding/UnpackedPackage.hs | 20 ++++++++++++++----- 2 files changed, 23 insertions(+), 9 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 43bf9de0254..e929f4fa32a 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -542,7 +542,8 @@ rebuildTarget void $ waitAsyncPackageDownload verbosity downloadMap pkg _ -> return () return $ BuildResult DocsNotTried TestsNotTried Nothing - | otherwise = + | otherwise = do + info verbosity $ "[rebuildTarget] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " with current status " ++ buildStatusToString pkgBuildStatus -- We rely on the 'BuildStatus' to decide which phase to start from: case pkgBuildStatus of BuildStatusDownload -> downloadPhase @@ -585,7 +586,8 @@ rebuildTarget -- would only start from download or unpack phases. -- rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult - rebuildPhase buildStatus srcdir = + rebuildPhase buildStatus srcdir = do + info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir assert (isInplaceBuildStyle $ elabBuildStyle pkg) buildInplace @@ -600,7 +602,8 @@ rebuildTarget -- TODO: [nice to have] ^^ do this relative stuff better buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildAndInstall srcdir builddir = + buildAndInstall srcdir builddir = do + info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildAndInstallUnpackedPackage verbosity distDirLayout @@ -616,8 +619,9 @@ rebuildTarget builddir buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildInplace buildStatus srcdir builddir = + buildInplace buildStatus srcdir builddir = do -- TODO: [nice to have] use a relative build dir rather than absolute + info verbosity $ "[buildInplace] Building inplace " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildInplaceUnpackedPackage verbosity distDirLayout diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 3d9c1dfea60..c141996fa77 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -116,6 +116,7 @@ import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) import Distribution.Client.ProjectBuilding.PackageFileMonitor +import qualified Distribution.Compat.Graph as Graph import Distribution.System (Platform (..)) -- | Each unpacked package is processed in the following phases: @@ -184,16 +185,19 @@ buildAndRegisterUnpackedPackage builddir mlogFile delegate = do + info verbosity $ "\n\nbuildAndRegisterUnpackedPackage: " ++ prettyShow (Graph.nodeKey pkg) -- Configure phase delegate $ PBConfigurePhase $ - annotateFailure mlogFile ConfigureFailed $ + annotateFailure mlogFile ConfigureFailed $ do + info verbosity $ "--- Configure phase " ++ prettyShow (Graph.nodeKey pkg) setup configureCommand Cabal.configCommonFlags configureFlags configureArgs -- Build phase delegate $ PBBuildPhase $ annotateFailure mlogFile BuildFailed $ do + info verbosity $ "--- Build phase " ++ prettyShow (Graph.nodeKey pkg) setup buildCommand Cabal.buildCommonFlags (return . buildFlags) buildArgs -- Haddock phase @@ -201,16 +205,19 @@ buildAndRegisterUnpackedPackage delegate $ PBHaddockPhase $ annotateFailure mlogFile HaddocksFailed $ do + info verbosity $ "--- Haddock phase " ++ prettyShow (Graph.nodeKey pkg) setup haddockCommand Cabal.haddockCommonFlags (return . haddockFlags) haddockArgs -- Install phase delegate $ PBInstallPhase { runCopy = \destdir -> - annotateFailure mlogFile InstallFailed $ + annotateFailure mlogFile InstallFailed $ do + info verbosity $ "--- Install phase, copy " ++ prettyShow (Graph.nodeKey pkg) setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do + info verbosity $ "--- Install phase, register " ++ prettyShow (Graph.nodeKey pkg) -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what -- the installed package id is, not the build system. @@ -232,21 +239,24 @@ buildAndRegisterUnpackedPackage whenTest $ delegate $ PBTestPhase $ - annotateFailure mlogFile TestsFailed $ + annotateFailure mlogFile TestsFailed $ do + info verbosity $ "--- Test phase " ++ prettyShow (Graph.nodeKey pkg) setup testCommand Cabal.testCommonFlags (return . testFlags) testArgs -- Bench phase whenBench $ delegate $ PBBenchPhase $ - annotateFailure mlogFile BenchFailed $ + annotateFailure mlogFile BenchFailed $ do + info verbosity $ "--- Benchmark phase " ++ prettyShow (Graph.nodeKey pkg) setup benchCommand Cabal.benchmarkCommonFlags (return . benchFlags) benchArgs -- Repl phase whenRepl $ delegate $ PBReplPhase $ - annotateFailure mlogFile ReplFailed $ + annotateFailure mlogFile ReplFailed $ do + info verbosity $ "--- Repl phase " ++ prettyShow (Graph.nodeKey pkg) setupInteractive replCommand Cabal.replCommonFlags replFlags replArgs return () From e9dc00d50da40a3ec53856216df2556226657609 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 25 Jun 2025 16:28:25 +0800 Subject: [PATCH 041/122] fix(cabal-install): use the correct packagedb for setup --- .../Distribution/Client/ProjectPlanning.hs | 38 +++++++++++-------- 1 file changed, 23 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index bef61cc3534..fa09f7328b0 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2255,6 +2255,11 @@ elaborateInstallPlan } = elaboratedPackage where + compilers = fmap toolchainCompiler toolchains + platforms = fmap toolchainPlatform toolchains + programDbs = fmap toolchainProgramDb toolchains + packageDbs = fmap toolchainPackageDBs toolchains + elaboratedPackage = ElaboratedConfiguredPackage{..} -- These get filled in later @@ -2268,9 +2273,9 @@ elaborateInstallPlan elabPkgSourceId = srcpkgPackageId elabStage = solverPkgStage - elabCompiler = toolchainCompiler (getStage toolchains solverPkgStage) - elabPlatform = toolchainPlatform (getStage toolchains solverPkgStage) - elabProgramDb = toolchainProgramDb (getStage toolchains solverPkgStage) + elabCompiler = getStage compilers elabStage + elabPlatform = getStage platforms elabStage + elabProgramDb = getStage programDbs elabStage elabPkgDescription = case PD.finalizePD solverPkgFlags @@ -2339,9 +2344,10 @@ elaborateInstallPlan if shouldBuildInplaceOnly pkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs + + elabPackageDbs = getStage packageDbs elabStage + elabBuildPackageDBStack = buildAndRegisterDbs elabStage + elabRegisterPackageDBStack = buildAndRegisterDbs elabStage elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription elabSetupScriptCliVersion = @@ -2350,19 +2356,21 @@ elaborateInstallPlan elabPkgDescription libDepGraph solverPkgLibDeps - elabSetupPackageDBStack = buildAndRegisterDbs + elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage) - inplacePackageDbs = corePackageDbs ++ [distPackageDB (compilerId elabCompiler)] + -- Same as corePackageDbs but with the addition of the in-place packagedb. + inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory "packagedb" prettyShow stage prettyShow (compilerId (getStage compilers stage)))] - corePackageDbs = Cabal.interpretPackageDbFlags False (projectConfigPackageDBs (projectConfigToolchain sharedPackageConfig)) ++ [storePackageDB storeDirLayout elabCompiler] + -- The project packagedbs (typically the global packagedb but others can be added) followed by the store. + corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout (getStage compilers stage)] - elabInplaceBuildPackageDBStack = inplacePackageDbs - elabInplaceRegisterPackageDBStack = inplacePackageDbs - elabInplaceSetupPackageDBStack = inplacePackageDbs + elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage + elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage + elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = corePackageDbs + buildAndRegisterDbs stage + | shouldBuildInplaceOnly pkg = inplacePackageDbs stage + | otherwise = corePackageDbs stage elabPkgDescriptionOverride = srcpkgDescrOverride From 7a3a7722f8d821558093fff1baa78f5d83115d7d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 May 2025 10:32:52 +0800 Subject: [PATCH 042/122] fix(cabal-install): fix pkgsToBuildInPlaceOnly Determine packages to build in-place by their solver id, not their package id. --- .../src/Distribution/Client/ProjectPlanning.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index fa09f7328b0..c2cb536beb3 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2523,16 +2523,17 @@ elaborateInstallPlan shouldBuildInplaceOnly :: SolverPackage loc -> Bool shouldBuildInplaceOnly pkg = Set.member - (packageId pkg) + (solverId (ResolverPackage.Configured pkg)) pkgsToBuildInplaceOnly - pkgsToBuildInplaceOnly :: Set PackageId + -- The reverse dependencies of solver packages which match a package id in pkgLocalToProject. + pkgsToBuildInplaceOnly :: Set SolverId pkgsToBuildInplaceOnly = Set.fromList - [ packageId pkg - | stage <- stages - , let solverIds = [PlannedId stage pkgId | pkgId <- Set.toList pkgsLocalToProject] - , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan solverIds + [ solverId pkg + | spkg <- SolverInstallPlan.toList solverPlan + , packageId spkg `elem` pkgsLocalToProject + , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan [solverId spkg] ] isLocalToProject :: Package pkg => pkg -> Bool From 4413cf0e07608fc970a41724ba3ff0931ea1e789 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Sat, 26 Jul 2025 09:49:55 +0800 Subject: [PATCH 043/122] refactor(cabal-install): seprate build directories and drop -inplace --- .../src/Distribution/Client/DistDirLayout.hs | 27 ++++--------------- .../Distribution/Client/ProjectPlanning.hs | 14 +++++----- .../Client/ProjectPlanning/Types.hs | 3 ++- .../src/Distribution/Client/ScriptUtils.hs | 3 ++- 4 files changed, 16 insertions(+), 31 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index c5701ac513d..8edebf02d07 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -33,6 +33,7 @@ import Distribution.Client.Config ( defaultLogsDir , defaultStoreDir ) +import Distribution.Client.Toolchain (Stage) import Distribution.Compiler import Distribution.Package ( ComponentId @@ -48,7 +49,6 @@ import Distribution.Simple.Compiler ) import Distribution.System import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained @@ -56,7 +56,8 @@ import Distribution.Types.LibraryName -- and for good reason: we don't want this path to change if -- the user, say, adds a dependency to their project. data DistDirParams = DistDirParams - { distParamUnitId :: UnitId + { distParamStage :: Stage + , distParamUnitId :: UnitId , distParamPackageId :: PackageId , distParamComponentId :: ComponentId , distParamComponentName :: Maybe ComponentName @@ -194,28 +195,10 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distBuildDirectory :: DistDirParams -> FilePath distBuildDirectory params = distBuildRootDirectory + prettyShow (distParamStage params) prettyShow (distParamPlatform params) prettyShow (distParamCompilerId params) - prettyShow (distParamPackageId params) - ( case distParamComponentName params of - Nothing -> "" - Just (CLibName LMainLibName) -> "" - Just (CLibName (LSubLibName name)) -> "l" prettyShow name - Just (CFLibName name) -> "f" prettyShow name - Just (CExeName name) -> "x" prettyShow name - Just (CTestName name) -> "t" prettyShow name - Just (CBenchName name) -> "b" prettyShow name - ) - ( case distParamOptimization params of - NoOptimisation -> "noopt" - NormalOptimisation -> "" - MaximumOptimisation -> "opt" - ) - ( let uid_str = prettyShow (distParamUnitId params) - in if uid_str == prettyShow (distParamComponentId params) - then "" - else uid_str - ) + prettyShow (distParamUnitId params) distUnpackedSrcRootDirectory :: FilePath distUnpackedSrcRootDirectory = distDirectory "src" diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index c2cb536beb3..5116ff61b90 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1948,21 +1948,21 @@ elaborateInstallPlan elab0 { elabPkgOrComp = ElabComponent elab_comp } + + -- This is where the component id is computed. cid = case elabBuildStyle elab0 of BuildInplaceOnly{} -> mkComponentId $ - prettyShow pkgid - ++ "-inplace" - ++ ( case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ prettyShow s - ) + case Cabal.componentNameString cname of + Nothing -> prettyShow pkgid + Just n -> prettyShow pkgid ++ "-" ++ prettyShow n BuildAndInstall -> hashedInstalledPackageId ( packageHashInputs elaboratedSharedConfig elab1 -- knot tied ) + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} infoProgress $ hang (text "configured component:") 4 (dispConfiguredComponent cc) @@ -2181,7 +2181,7 @@ elaborateInstallPlan pkgInstalledId | shouldBuildInplaceOnly pkg = - mkComponentId (prettyShow srcpkgPackageId ++ "-inplace") + mkComponentId (prettyShow srcpkgPackageId) | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index a4476e513e4..c8ff9c9a08c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -565,7 +565,8 @@ elabConfiguredName verbosity elab elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams elabDistDirParams shared elab = DistDirParams - { distParamUnitId = installedUnitId elab + { distParamStage = elabStage elab + , distParamUnitId = installedUnitId elab , distParamComponentId = elabComponentId elab , distParamPackageId = elabPkgSourceId elab , distParamComponentName = case elabPkgOrComp elab of diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 60930c45cb7..8c54f093007 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -431,7 +431,8 @@ scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams scriptDistDirParams scriptPath ctx compiler platform = DistDirParams - { distParamUnitId = newSimpleUnitId cid + { distParamStage = Host + , distParamUnitId = newSimpleUnitId cid , distParamPackageId = fakePackageId , distParamComponentId = cid , distParamComponentName = Just $ CExeName cn From 72f79fcb3b2f8a06f98e9e237cbbfdfea72fc1a4 Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Thu, 22 May 2025 11:07:51 +0000 Subject: [PATCH 044/122] fix(Cabal): do not use GHC to configure LD Cabal uses a peculiar c program to check if LD supports and should use -x. To do this, it shells out to GHC to compiler the C file. This however requires that GHC will not bail out, yet cabal does not pass --package-db flags to this GHC invocation, and as such we can run into situations where GHC bails out, especially during GHC bootstrap phases where not all boot packages are available. We however do not need GHC to compiler a c program, and can rely on the C compiler. Fundamentally cabal does not allow modelling program dependencies in the program db, as such we must configure gcc first before using it. We make a small change to lib:Cabal (specifically the GHC module, and it's Internal companion) to allow it to configure gcc first, before trying to configure ld, and thus having gcc in scope while configuring ld. This removes the need for the awkward ghc invocation to compiler the test program. --- Cabal/src/Distribution/Simple/GHC.hs | 11 +-- Cabal/src/Distribution/Simple/GHC/Internal.hs | 84 +++++++++++-------- 2 files changed, 49 insertions(+), 46 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 593bf4e9119..4878fd984a3 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -312,15 +312,8 @@ compilerProgramDb verbosity comp progdb1 hcPkgPath = do addKnownProgram hpcProgram' $ addKnownProgram runghcProgram' progdb2 - -- configure gcc, ld, ar etc... based on the paths stored - -- in the GHC settings file - progdb4 = - Internal.configureToolchain - (ghcVersionImplInfo ghcVersion) - ghcProg - (compilerProperties comp) - progdb3 - return progdb4 + -- configure gcc, ld, ar etc... based on the paths stored in the GHC settings file + Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb3 -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index cc8649fb814..ee6878228b2 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -104,37 +104,48 @@ targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo -- | Adjust the way we find and configure gcc and ld configureToolchain - :: GhcImplInfo + :: Verbosity + -> GhcImplInfo -> ConfiguredProgram -> Map String String -> ProgramDb - -> ProgramDb -configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram - gccProgram - { programFindLocation = findProg gccProgramName extraGccPath - , programPostConf = configureGcc - } - . addKnownProgram - gppProgram - { programFindLocation = findProg gppProgramName extraGppPath - , programPostConf = configureGpp - } - . addKnownProgram - ldProgram - { programFindLocation = findProg ldProgramName extraLdPath - , programPostConf = \v cp -> - -- Call any existing configuration first and then add any new configuration - configureLd v =<< programPostConf ldProgram v cp - } - . addKnownProgram - arProgram - { programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram - stripProgram - { programFindLocation = findProg stripProgramName extraStripPath - } + -> IO ProgramDb +configureToolchain verbosity _implInfo ghcProg ghcInfo db = do + -- this is a bit of a hack. We have a dependency of ld on gcc. + -- ld needs to compiler a c program, to check an ld feature. + -- we _could_ use ghc as a c frontend, but we do not pass all + -- db stack appropriately, and thus we can run into situations + -- where GHC will fail if it's stricter in it's wired-in-unit + -- selction and has the wrong db stack. However we don't need + -- ghc to compile a _test_ c program. So we configure `gcc` + -- first and then use `gcc` (the generic c compiler in cabal + -- terminology) to compile the test program. + let db' = + flip addKnownProgram db $ + gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + (gccProg, db'') <- requireProgram verbosity gccProgram db' + return $ + flip addKnownPrograms db'' $ + [ gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + , ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd gccProg v =<< programPostConf ldProgram v cp + } + , arProgram + { programFindLocation = findProg arProgramName extraArPath + } + , stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } + ] where compilerDir, base_dir, mingwBinDir :: FilePath compilerDir = takeDirectory (programPath ghcProg) @@ -234,27 +245,26 @@ configureToolchain _implInfo ghcProg ghcInfo = ++ cxxFlags } - configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd v ldProg = do - ldProg' <- configureLd' v ldProg + configureLd :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd gccProg v ldProg = do + ldProg' <- configureLd' gccProg v ldProg return ldProg' { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags } -- we need to find out if ld supports the -x flag - configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd' verbosity ldProg = do + configureLd' :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' gccProg v ldProg = do ldx <- withTempFile ".c" $ \testcfile testchnd -> withTempFile ".o" $ \testofile testohnd -> do hPutStrLn testchnd "int foo() { return 0; }" hClose testchnd hClose testohnd runProgram - verbosity - ghcProg - [ "-hide-all-packages" - , "-c" + v + gccProg + [ "-c" , testcfile , "-o" , testofile From eba3a6138f000d07d8a5d61517b392db155b8fb7 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 10 Jul 2025 16:52:55 +0800 Subject: [PATCH 045/122] feat(cabal-install): add parser for UserQualExe --- cabal-install/src/Distribution/Client/Targets.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 8dba648d264..f065a5bb1e4 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -723,9 +723,10 @@ instance Parsec UserConstraint where withColon :: PackageName -> m UserConstraintQualifier withColon pn = - UserQualified (UserQualSetup pn) - <$ P.string "setup." - <*> parsec + P.choice + [ UserQualified (UserQualSetup pn) <$> (P.string "setup." *> parsec) + , UserQualified . UserQualExe pn <$> (P.string "exe:" *> parsec) <*> (P.char '.' *> parsec) + ] -- >>> eitherParsec "foo > 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) @@ -747,3 +748,6 @@ instance Parsec UserConstraint where -- -- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled) +-- +-- >>> eitherParsec "foo:exe:bar.baz > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "baz"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) From da951b8cb17b0124aa1e7f263b82ee7d2e62627a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 10 Jul 2025 16:52:55 +0800 Subject: [PATCH 046/122] feat(cabal-install): add ScopeAnyExeQualifier and UserAnyExeQualifier --- .../Solver/Types/PackageConstraint.hs | 30 +++++++++++-------- .../src/Distribution/Client/Targets.hs | 26 +++++++++++----- 2 files changed, 36 insertions(+), 20 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index 9bdd6615824..4b60d2ebc66 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -57,11 +57,11 @@ data ConstraintQualifier = ScopeTarget PackageName -- | The package with the specified name and qualifier. | ScopeQualified Qualifier PackageName - -- | The package with the specified name when it has a - -- setup qualifier. + -- | The package with the specified name when it has a setup qualifier. | ScopeAnySetupQualifier PackageName - -- | The package with the specified name regardless of - -- qualifier. + -- | The package with the specified name when it has an exe qualifier. + | ScopeAnyExeQualifier PackageName + -- | The package with the specified name regardless of qualifier. | ScopeAnyQualifier PackageName deriving (Eq, Show) @@ -76,6 +76,7 @@ scopeToPackageName :: ConstraintScope -> PackageName scopeToPackageName (ConstraintScope _stage (ScopeTarget pn)) = pn scopeToPackageName (ConstraintScope _stage (ScopeQualified _ pn)) = pn scopeToPackageName (ConstraintScope _stage (ScopeAnySetupQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (ScopeAnyExeQualifier pn)) = pn scopeToPackageName (ConstraintScope _stage (ScopeAnyQualifier pn)) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool @@ -83,15 +84,17 @@ constraintScopeMatches (ConstraintScope mstage qualifier) (Q (PackagePath stage' maybe True (== stage') mstage && constraintQualifierMatches qualifier q pn' constraintQualifierMatches :: ConstraintQualifier -> Qualifier -> PackageName -> Bool -constraintQualifierMatches (ScopeTarget pn) q pn' = - q == QualToplevel && pn == pn' -constraintQualifierMatches (ScopeQualified q pn) q' pn' = - q == q' && pn == pn' -constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = - pn == pn' -constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = - pn == pn' -constraintQualifierMatches _ _ _ = False +constraintQualifierMatches (ScopeTarget pn) QualToplevel pn' = pn == pn' +constraintQualifierMatches (ScopeTarget _) (QualSetup _) _ = False +constraintQualifierMatches (ScopeTarget _) (QualExe _ _) _ = False +constraintQualifierMatches (ScopeQualified q pn) q' pn' = q == q' && pn == pn' +constraintQualifierMatches (ScopeAnySetupQualifier _) QualToplevel _ = False +constraintQualifierMatches (ScopeAnySetupQualifier _) (QualExe _ _) _ = False +constraintQualifierMatches (ScopeAnySetupQualifier pn) (QualSetup _) pn' = pn == pn' +constraintQualifierMatches (ScopeAnyExeQualifier pn) (QualExe _ _) pn' = pn == pn' +constraintQualifierMatches (ScopeAnyExeQualifier _) QualToplevel _ = False +constraintQualifierMatches (ScopeAnyExeQualifier _) (QualSetup _) _compile = False +constraintQualifierMatches (ScopeAnyQualifier pn) _ pn' = pn == pn' instance Pretty ConstraintScope where pretty (ConstraintScope mstage qualifier) = @@ -101,6 +104,7 @@ instance Pretty ConstraintQualifier where pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn + pretty (ScopeAnyExeQualifier pn) = Disp.text "exe." <<>> pretty pn pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index f065a5bb1e4..6891b567b24 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -627,6 +627,8 @@ data UserConstraintQualifier UserQualified UserQualifier PackageName | -- | Scope that applies to the package when it has a setup qualifier. UserAnySetupQualifier PackageName + | -- | Scope that applies to the package when it has a setup qualifier. + UserAnyExeQualifier PackageName | -- | Scope that applies to the package when it has any qualifier. UserAnyQualifier PackageName deriving (Eq, Show, Generic) @@ -644,6 +646,8 @@ fromUserConstraintScope (UserConstraintScope mstage (UserQualified q pn)) = ConstraintScope mstage (ScopeQualified (fromUserQualifier q) pn) fromUserConstraintScope (UserConstraintScope mstage (UserAnySetupQualifier pn)) = ConstraintScope mstage (ScopeAnySetupQualifier pn) +fromUserConstraintScope (UserConstraintScope mstage (UserAnyExeQualifier pn)) = + ConstraintScope mstage (ScopeAnyExeQualifier pn) fromUserConstraintScope (UserConstraintScope mstage (UserAnyQualifier pn)) = ConstraintScope mstage (ScopeAnyQualifier pn) @@ -668,6 +672,7 @@ userConstraintPackageName (UserConstraintX (UserConstraintScope _stage qualifier scopePN (UserQualified _ pn) = pn scopePN (UserAnyQualifier pn) = pn scopePN (UserAnySetupQualifier pn) = pn + scopePN (UserAnyExeQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint userToPackageConstraint (UserConstraintX scope prop) = @@ -719,6 +724,7 @@ instance Parsec UserConstraint where withDot pn | pn == mkPackageName "any" = UserAnyQualifier <$> parsec | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec + | pn == mkPackageName "exe" = UserAnyExeQualifier <$> parsec | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn withColon :: PackageName -> m UserConstraintQualifier @@ -734,20 +740,26 @@ instance Parsec UserConstraint where -- >>> eitherParsec "foo ^>= 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified UserQualToplevel (PackageName "foo"))) (PackagePropertyVersion (MajorBoundVersion (mkVersion [1,2,3,4])))) -- +-- >>> eitherParsec "any.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "setup.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- +-- >>> eitherParsec "exe.bar > 1.2.3.4" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnyExeQualifier (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) +-- -- >>> eitherParsec "foo:setup.bar > 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualSetup (PackageName "foo")) (PackageName "bar"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) -- --- >>> eitherParsec "setup.any source" :: Either String UserConstraint --- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertySource) --- -- >>> eitherParsec "build:rts source" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource) -- --- >>> eitherParsec "setup.any installed" :: Either String UserConstraint --- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "any"))) PackagePropertyInstalled) +-- >>> eitherParsec "build:any.rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserAnyQualifier (PackageName "rts"))) PackagePropertySource) -- --- >>> eitherParsec "build:ghc-internal installed" :: Either String UserConstraint --- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "ghc-internal"))) PackagePropertyInstalled) +-- >>> eitherParsec "setup.ghc-internal installed" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope Nothing (UserAnySetupQualifier (PackageName "ghc-internal"))) PackagePropertyInstalled) -- -- >>> eitherParsec "foo:exe:bar.baz > 1.2.3.4" :: Either String UserConstraint -- Right (UserConstraintX (UserConstraintScope Nothing (UserQualified (UserQualExe (PackageName "foo") (PackageName "bar")) (PackageName "baz"))) (PackagePropertyVersion (LaterVersion (mkVersion [1,2,3,4])))) From 4be303fa549f6aa8715f0275758a53a2a3c11ecd Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 5 Jun 2025 16:51:41 +0800 Subject: [PATCH 047/122] feature(cabal-install): automatically copy executables into build directory after build --- .../Client/ProjectOrchestration.hs | 37 +++++++++++++++++-- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 650a2a1e190..8ff734fd31c 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -158,6 +158,7 @@ import Distribution.Types.ComponentName import Distribution.Types.UnqualComponentName ( UnqualComponentName , packageNameToUnqualComponentName + , unUnqualComponentName ) import Distribution.PackageDescription.Configuration @@ -190,6 +191,8 @@ import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , debugNoWrap , dieWithException + , infoNoWrap + , installExecutableFile , notice , noticeNoWrap , ordNub @@ -203,7 +206,7 @@ import Distribution.Types.Flag import Distribution.Utils.NubList ( fromNubList ) -import Distribution.Utils.Path (makeSymbolicPath) +import Distribution.Utils.Path (makeSymbolicPath, ()) import Distribution.Verbosity #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) @@ -467,8 +470,8 @@ runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ return () runProjectPostBuildPhase verbosity - ProjectBaseContext{..} - ProjectBuildContext{..} + baseCtx@ProjectBaseContext{..} + buildCtx@ProjectBuildContext{..} buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: @@ -485,6 +488,8 @@ runProjectPostBuildPhase pkgsBuildStatus buildOutcomes + installExecutables verbosity baseCtx buildCtx postBuildStatus + -- Write the .ghc.environment file (if allowed by the env file write policy). let writeGhcEnvFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared $ @@ -515,6 +520,32 @@ runProjectPostBuildPhase -- an exception to terminate the program dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes +installExecutables :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> PostBuildProjectStatus -> IO () +installExecutables + verbosity + ProjectBaseContext{distDirLayout} + ProjectBuildContext{elaboratedPlanOriginal, elaboratedShared, targetsMap} + postBuildStatus = + unless (null srcdst) $ do + infoNoWrap verbosity $ "Copying executables to " <> bindir + -- Create the bin directory if it does not exist + createDirectoryIfMissingVerbose verbosity True bindir + -- Install the executables + for_ srcdst $ \(exe, src) -> do + installExecutableFile verbosity src (bindir exe) + where + bindir = distBinDirectory distDirLayout + srcdst = + [ (exe, dir exe) + | (pkg, targets) <- Map.toList targetsMap + , stageOf pkg == Host + , pkg `Set.member` packagesDefinitelyUpToDate postBuildStatus + , Just (InstallPlan.Configured elab) <- [InstallPlan.lookup elaboratedPlanOriginal pkg] + , (ComponentTarget (CExeName cname) _subtarget, _targetSelectors) <- targets + , let exe = unUnqualComponentName cname + , let dir = binDirectoryFor distDirLayout elaboratedShared elab exe + ] + -- Note that it is a deliberate design choice that the 'buildTargets' is -- not passed to phase 1, and the various bits of input config is not -- passed to phase 2. From 070731ea7ab33667c6d6479455acbdb1f118cb9f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 28 Jul 2025 12:10:29 +0800 Subject: [PATCH 048/122] refactor(cabal-install): refactor InstallPlan.problems Split the function into multiple ones. --- .../src/Distribution/Client/InstallPlan.hs | 78 ++++++++++++++----- 1 file changed, 59 insertions(+), 19 deletions(-) diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index d60557c86ab..4a93c8cda51 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1044,11 +1044,19 @@ valid loc graph = ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) data PlanProblem ipkg srcpkg - = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [GraphKey ipkg srcpkg] - | PackageCycle [GenericPlanPackage ipkg srcpkg] + = PackageMissingDeps + (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is missing dependencies + [GraphKey ipkg srcpkg] + -- ^ The missing dependencies + | -- | The packages involved in a dependency cycle + PackageCycle + [GenericPlanPackage ipkg srcpkg] | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is in an invalid state (GenericPlanPackage ipkg srcpkg) + -- ^ The package that it depends on which is in an invalid state showPlanProblem :: ( IsGraph ipkg srcpkg @@ -1083,6 +1091,18 @@ problems => Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg] problems graph = + concat + [ checkForMissingDeps graph + , checkForCycles graph + , -- , checkForDependencyInconsistencies graph + checkForPackageStateInconsistencies graph + ] + +checkForMissingDeps + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForMissingDeps graph = [ PackageMissingDeps pkg ( mapMaybe @@ -1091,23 +1111,43 @@ problems graph = ) | (pkg, missingDeps) <- Graph.broken graph ] - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles graph - ] - {- - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- - dependencyInconsistencies indepGoals graph ] - --TODO: consider re-enabling this one, see SolverInstallPlan - -} - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Foldable.toList graph - , Just pkg' <- - map - (flip Graph.lookup graph) - (nodeNeighbors pkg) - , not (stateDependencyRelation pkg pkg') - ] + +checkForCycles + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForCycles graph = + [PackageCycle cycleGroup | cycleGroup <- Graph.cycles graph] + +-- TODO: consider re-enabling this one, see SolverInstallPlan +-- +-- checkForDependencyInconsistencies +-- :: ( IsGraph ipkg srcpkg +-- , Pretty (GraphKey ipkg srcpkg) +-- , Key srcpkg ~ PlanProblem ipkg srcpkg +-- , Key ipkg ~ GraphKey ipkg srcpkg +-- ) +-- => Graph (GenericPlanPackage ipkg srcpkg) +-- -> [PlanProblem ipkg srcpkg] +-- checkForDependencyInconsistencies graph = +-- [ PackageInconsistency name inconsistencies +-- | (name, inconsistencies) <- +-- dependencyInconsistencies indepGoals graph +-- ] + +checkForPackageStateInconsistencies + :: IsGraph ipkg srcpkg + => Graph (GenericPlanPackage ipkg srcpkg) + -> [PlanProblem ipkg srcpkg] +checkForPackageStateInconsistencies graph = + [ PackageStateInvalid pkg pkg' + | pkg <- Foldable.toList graph + , Just pkg' <- + map + (flip Graph.lookup graph) + (nodeNeighbors pkg) + , not (stateDependencyRelation pkg pkg') + ] -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on From e9552922777021c465db30757d4e8574cbf2e988 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 1 Aug 2025 14:37:46 +0800 Subject: [PATCH 049/122] refactor(cabal-install): use LogProgress in InstallPlan --- Cabal/src/Distribution/Utils/LogProgress.hs | 5 + .../src/Distribution/Client/CmdBench.hs | 15 +- .../src/Distribution/Client/CmdBuild.hs | 26 ++- .../src/Distribution/Client/CmdGenBounds.hs | 12 +- .../src/Distribution/Client/CmdHaddock.hs | 13 +- .../Distribution/Client/CmdHaddockProject.hs | 12 +- .../src/Distribution/Client/CmdInstall.hs | 20 +- .../src/Distribution/Client/CmdListBin.hs | 13 +- .../src/Distribution/Client/CmdRepl.hs | 10 +- .../src/Distribution/Client/CmdRun.hs | 13 +- .../src/Distribution/Client/CmdTest.hs | 13 +- .../src/Distribution/Client/InstallPlan.hs | 172 ++++++++++-------- .../Client/ProjectOrchestration.hs | 5 +- .../Distribution/Client/ProjectPlanning.hs | 41 ++--- .../Client/ProjectPlanning/Types.hs | 2 +- cabal-install/tests/IntegrationTests2.hs | 11 +- .../Distribution/Client/InstallPlan.hs | 41 +++-- 17 files changed, 246 insertions(+), 178 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index b1a3e7168f0..8cc2ae527e9 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -9,6 +9,7 @@ module Distribution.Utils.LogProgress , infoProgress , dieProgress , addProgressCtx + , eitherToLogProgress , ErrMsg ) where @@ -100,3 +101,7 @@ formatMsg ctx doc = doc $$ vcat ctx addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env -> m env{le_context = s : le_context env} + +eitherToLogProgress :: Either Doc a -> LogProgress a +eitherToLogProgress (Left err) = dieProgress err +eitherToLogProgress (Right a) = return a diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index f9adc80432b..177b8263a1a 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -50,6 +50,9 @@ import Distribution.Simple.Utils , warn , wrapText ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( normal ) @@ -133,11 +136,13 @@ benchAction flags targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBench - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBench + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 7314187b815..b8ca8a3dfd2 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | cabal-install CLI command: build module Distribution.Client.CmdBuild ( -- * The @build@ CLI and action @@ -26,6 +28,7 @@ import Distribution.Client.TargetProblem import qualified Data.Map as Map import Distribution.Client.Errors +import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) , cfgVerbosity @@ -52,6 +55,7 @@ import Distribution.Simple.Utils ( dieWithException , wrapText ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity ( normal ) @@ -161,18 +165,20 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags} targetStrings globalFla Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - targetAction - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + targetAction + targets + elaboratedPlan + elaboratedPlan'' <- if buildSettingOnlyDeps (buildSettings baseCtx) - then - either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies - (Map.keysSet targets) - elaboratedPlan' + then case pruneInstallPlanToDependencies (Map.keysSet targets) elaboratedPlan' of + Left err -> + reportCannotPruneDependencies verbosity err + Right elaboratedPlan'' -> + runLogProgress verbosity $ InstallPlan.new' elaboratedPlan'' else return elaboratedPlan' return (elaboratedPlan'', targets) diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 5989fb55e23..6188ef3d46a 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -27,6 +27,7 @@ import Distribution.Simple.Utils import Distribution.Version import Distribution.Client.Setup (GlobalFlags (..)) +import Distribution.Utils.LogProgress (runLogProgress) -- Project orchestration imports @@ -114,11 +115,12 @@ genBoundsAction flags targetStrings globalFlags = targetSelectors -- Step 3: Prune the install plan to the targets. - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan let -- Step 4a: Find the local packages from the install plan. These are the diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index a3cc048e210..d741211f286 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -75,6 +75,7 @@ import Distribution.Verbosity ) import Distribution.Client.Errors +import Distribution.Utils.LogProgress (runLogProgress) import qualified System.Exit (exitSuccess) newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool} @@ -189,11 +190,13 @@ haddockAction relFlags targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionHaddock - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionHaddock + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index d6f31a27e72..e929f3c1956 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -98,6 +98,7 @@ import Distribution.Types.PackageDescription (PackageDescription (benchmarks, su import Distribution.Types.PackageId (pkgName) import Distribution.Types.PackageName (unPackageName) import Distribution.Types.UnitId (unUnitId) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity as Verbosity ( normal ) @@ -147,11 +148,12 @@ haddockProjectAction flags _extraArgs globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan return (elaboratedPlan', targets) let elaboratedPlan :: ElaboratedInstallPlan diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 08562fce6d3..e20df89abb6 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -219,6 +219,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( writeFileAtomic ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , normal @@ -900,15 +903,18 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do Nothing targetSelectors - let prunedToTargetsElaboratedPlan = - pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedToTargetsElaboratedPlan <- + runLogProgress verbosity $ + pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan + prunedElaboratedPlan <- if buildSettingOnlyDeps (buildSettings baseCtx) - then - either (reportCannotPruneDependencies verbosity) return $ - pruneInstallPlanToDependencies - (Map.keysSet targets) - prunedToTargetsElaboratedPlan + then do + case pruneInstallPlanToDependencies (Map.keysSet targets) prunedToTargetsElaboratedPlan of + Left err -> + reportCannotPruneDependencies verbosity err + Right elaboratedPlan'' -> + runLogProgress verbosity $ InstallPlan.new' elaboratedPlan'' else return prunedToTargetsElaboratedPlan return (prunedElaboratedPlan, targets) diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index d1c6a824295..ecce6fcb6e5 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -60,6 +60,7 @@ import Distribution.Client.Errors import qualified Distribution.Client.InstallPlan as IP import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Utils.LogProgress (runLogProgress) ------------------------------------------------------------------------------- -- Command @@ -127,11 +128,13 @@ listbinAction flags args globalFlags = do ) targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index f91574df105..655f5a3fa9c 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -157,6 +157,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( safeHead ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , normal @@ -394,13 +397,14 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- Recalculate with updated project. targets <- validatedTargets (projectConfigShared projectConfig) toolchainCompiler elaboratedPlan targetSelectors - let - elaboratedPlan' = + elaboratedPlan' <- + runLogProgress verbosity $ pruneInstallPlanToTargets TargetActionRepl targets elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) + + let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) pkgsBuildStatus <- rebuildTargetsDryRun diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 8dd2ac0e2e9..bbc2eeff44b 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -126,6 +126,7 @@ import Distribution.Types.UnqualComponentName ( UnqualComponentName , unUnqualComponentName ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Utils.NubList ( fromNubList ) @@ -247,11 +248,13 @@ runAction flags targetAndArgs globalFlags = ) targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) (selectedUnitId, selectedComponent) <- diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index 14b4b8a8d7d..563cea4c64d 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -67,6 +67,7 @@ import Distribution.Verbosity import qualified System.Exit (exitSuccess) import Distribution.Client.Errors +import Distribution.Utils.LogProgress (runLogProgress) import GHC.Environment ( getFullArgs ) @@ -151,11 +152,13 @@ testAction flags@NixStyleFlags{..} targetStrings globalFlags = do Nothing targetSelectors - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionTest - targets - elaboratedPlan + elaboratedPlan' <- + runLogProgress verbosity $ + pruneInstallPlanToTargets + TargetActionTest + targets + elaboratedPlan + return (elaboratedPlan', targets) printPlan verbosity baseCtx buildCtx diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 4a93c8cda51..e7382a71592 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -28,9 +28,11 @@ module Distribution.Client.InstallPlan , PlanPackage , GenericPlanPackage (..) , foldPlanPackage + , renderPlanPackageTag -- * Operations on 'InstallPlan's , new + , new' , toGraph , toList , toMap @@ -61,11 +63,13 @@ module Distribution.Client.InstallPlan , failed -- * Display - , showPlanGraph + , renderPlanGraph , ShowPlanNode (..) , showInstallPlan , showInstallPlan_gen - , showPlanPackageTag + , PlanProblem + , renderPlanProblem + , renderPlanProblems -- * Graph-like operations , dependencyClosure @@ -94,7 +98,6 @@ import Distribution.Package , HasUnitId (..) , Package (..) ) -import Distribution.Pretty (defaultStyle) import Distribution.Solver.Types.SolverPackage import Text.PrettyPrint @@ -115,6 +118,7 @@ import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import qualified Data.Foldable as Foldable (all, toList) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Compat.Graph (Graph, IsNode (..)) @@ -286,21 +290,6 @@ type InstallPlan = InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) --- | Smart constructor that deals with caching the 'Graph' representation. -mkInstallPlan - :: ( IsGraph ipkg srcpkg - , Pretty (GraphKey ipkg srcpkg) - ) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph = - assert - (valid loc graph) - GenericInstallPlan - { planGraph = graph - } - internalError :: WithCallStack (String -> String -> a) internalError loc msg = error $ @@ -334,22 +323,24 @@ instance put p = put (planGraph p) get = do - graph <- get - return $! mkInstallPlan "(instance Binary)" graph + graph <- mkInstallPlan <$> get + return $! either (const (error "Deserialised invalid GenericInstallPlan")) id graph data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc , showPlanNeighbours :: [Doc] } -showPlanGraph :: [ShowPlanNode] -> String -showPlanGraph graph = - renderStyle defaultStyle $ - vcat (map dispPlanPackage graph) +renderPlanGraph :: [ShowPlanNode] -> Doc +renderPlanGraph graph = + vcat (map dispPlanPackage graph) where dispPlanPackage (ShowPlanNode herald neighbours) = hang herald 2 (vcat neighbours) +showPlanGraph :: [ShowPlanNode] -> String +showPlanGraph = render . renderPlanGraph + -- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information showInstallPlan_gen :: forall ipkg srcpkg @@ -373,26 +364,59 @@ showInstallPlan = showInstallPlan_gen toShow toShow p = ShowPlanNode ( hsep - [ text (showPlanPackageTag p) + [ renderPlanPackageTag p , pretty (packageId p) , parens (pretty (nodeKey p)) ] ) (map pretty (nodeNeighbors p)) -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String -showPlanPackageTag (PreExisting _) = "PreExisting" -showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Installed _) = "Installed" +renderPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> Doc +renderPlanPackageTag (PreExisting _) = text "pre-existing" +renderPlanPackageTag (Configured _) = text "configured" +renderPlanPackageTag (Installed _) = text "installed" + +-- | Smart constructor that deals with caching the 'Graph' representation. +mkInstallPlan + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> Either Doc (GenericInstallPlan ipkg srcpkg) +mkInstallPlan graph = + case NE.nonEmpty (problems graph) of + Just problems' -> Left $ renderPlanProblems (NE.toList problems') + Nothing -> Right $ GenericInstallPlan{planGraph = graph} --- | Build an installation plan from a valid set of resolved packages. +mkInstallPlan' + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => Graph (GenericPlanPackage ipkg srcpkg) + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan ipkg srcpkg) +mkInstallPlan' graph = + case NE.nonEmpty (problems graph) of + Just problems' -> Left problems' + Nothing -> Right $ GenericInstallPlan{planGraph = graph} + +-- | Build an installation plan from a set of packages. new + :: ( IsGraph ipkg srcpkg + , Show (GraphKey ipkg srcpkg) + , Pretty (GraphKey ipkg srcpkg) + ) + => [GenericPlanPackage ipkg srcpkg] + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new = eitherToLogProgress . mkInstallPlan . Graph.fromDistinctList + +-- | Build an installation plan from a graph of packages. +new' :: ( IsGraph ipkg srcpkg , Pretty (GraphKey ipkg srcpkg) ) => Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -new = mkInstallPlan "new" + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new' = eitherToLogProgress . mkInstallPlan toGraph :: GenericInstallPlan ipkg srcpkg @@ -427,13 +451,9 @@ remove ) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg - -> GenericInstallPlan ipkg srcpkg + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan' (Key srcpkg) ipkg srcpkg) remove shouldRemove plan = - mkInstallPlan "remove" newGraph - where - newGraph = - Graph.fromDistinctList $ - filter (not . shouldRemove) (toList plan) + mkInstallPlan' $ Graph.fromDistinctList $ filter (not . shouldRemove) (toList plan) -- | Change a number of packages in the 'Configured' state to the 'Installed' -- state. @@ -593,10 +613,7 @@ fromSolverInstallPlanWithProgress f plan = do f' (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) - return $ - mkInstallPlan - "fromSolverInstallPlanWithProgress" - (Graph.fromDistinctList pkgs'') + new' (Graph.fromDistinctList pkgs'') where f' (pMap, pkgs) pkg = do pkgs' <- f (mapDep pMap) pkg @@ -1027,22 +1044,6 @@ execute jobCtl keepGoing depFailure plan installPkg = -- ------------------------------------------------------------ --- | A valid installation plan is a set of packages that is closed, acyclic --- and respects the package state relation. --- --- * if the result is @False@ use 'problems' to get a detailed list. -valid - :: ( IsGraph ipkg srcpkg - , Pretty (GraphKey ipkg srcpkg) - ) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> Bool -valid loc graph = - case problems graph of - [] -> True - ps -> internalError loc ('\n' : unlines (map showPlanProblem ps)) - data PlanProblem ipkg srcpkg = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) @@ -1058,30 +1059,45 @@ data PlanProblem ipkg srcpkg (GenericPlanPackage ipkg srcpkg) -- ^ The package that it depends on which is in an invalid state -showPlanProblem +renderPlanProblems + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + ) + => [PlanProblem ipkg srcpkg] + -> Doc +renderPlanProblems = + vcat . map renderPlanProblem + +renderPlanProblem :: ( IsGraph ipkg srcpkg , Pretty (GraphKey ipkg srcpkg) ) => PlanProblem ipkg srcpkg - -> String -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " - ++ prettyShow (nodeKey pkg) - ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup) -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " - ++ prettyShow (nodeKey pkg) - ++ " is in the " - ++ showPlanPackageTag pkg - ++ " state but it depends on package " - ++ prettyShow (nodeKey pkg') - ++ " which is in the " - ++ showPlanPackageTag pkg' - ++ " state" + -> Doc +renderPlanProblem (PackageMissingDeps pkg missingDeps) = + fsep + [ text "Package" + , pretty (nodeKey pkg) + , text "depends on the following packages which are missing from the plan:" + , fsep (punctuate comma (map pretty missingDeps)) + ] +renderPlanProblem (PackageCycle cycleGroup) = + fsep + [ text "The following packages are involved in a dependency cycle:" + , fsep (punctuate comma (map (pretty . nodeKey) cycleGroup)) + ] +renderPlanProblem (PackageStateInvalid pkg pkg') = + fsep + [ text "Package" + , pretty (nodeKey pkg) + , text "is in the" + , renderPlanPackageTag pkg + , text "state but it depends on package" + , pretty (nodeKey pkg') + , text "which is in the" + , renderPlanPackageTag pkg' + , text "state" + ] -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 8ff734fd31c..233347544e7 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -203,6 +203,9 @@ import Distribution.Types.Flag , diffFlagAssignment , showFlagAssignment ) +import Distribution.Utils.LogProgress + ( LogProgress + ) import Distribution.Utils.NubList ( fromNubList ) @@ -1072,7 +1075,7 @@ pruneInstallPlanToTargets :: TargetAction -> TargetsMapS -> ElaboratedInstallPlan - -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = assert (Map.size targetsMap > 0) $ ProjectPlanning.pruneInstallPlanToTargets diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 5116ff61b90..262d81b61e6 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -993,10 +993,9 @@ rebuildInstallPlan defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t) return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - (elaboratedPlan, elaboratedShared) <- - liftIO - . runLogProgress verbosity - $ elaborateInstallPlan + liftIO $ runLogProgress verbosity $ do + (elaboratedPlan, elaboratedShared) <- + elaborateInstallPlan verbosity toolchains pkgConfigDB @@ -1010,14 +1009,17 @@ rebuildInstallPlan projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage) - let instantiatedPlan = - instantiateInstallPlan - cabalStoreDirLayout - installDirs - elaboratedShared - elaboratedPlan - liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan) - return (instantiatedPlan, elaboratedShared) + + instantiatedPlan <- + instantiateInstallPlan + cabalStoreDirLayout + installDirs + elaboratedShared + elaboratedPlan + + infoProgress $ text "Elaborated install plan:" $$ text (showElaboratedInstallPlan instantiatedPlan) + + return (instantiatedPlan, elaboratedShared) where withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -2857,10 +2859,9 @@ instantiateInstallPlan -> Staged InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan - -> ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = - InstallPlan.new - (Graph.fromDistinctList (Map.elems ready_map)) + -> LogProgress ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = do + InstallPlan.new (Map.elems ready_map) where pkgs = InstallPlan.toList plan @@ -3423,10 +3424,9 @@ pruneInstallPlanToTargets => TargetAction -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> ElaboratedInstallPlan - -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = InstallPlan.new - . Graph.fromDistinctList -- We have to do the pruning in two passes . pruneInstallPlanPass2 . pruneInstallPlanPass1 @@ -3874,15 +3874,14 @@ pruneInstallPlanToDependencies -> ElaboratedInstallPlan -> Either CannotPruneDependencies - ElaboratedInstallPlan + (Graph.Graph ElaboratedPlanPackage) pruneInstallPlanToDependencies pkgTargets installPlan = assert ( all (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets) ) - $ fmap InstallPlan.new - . checkBrokenDeps + $ checkBrokenDeps . Graph.fromDistinctList . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets) . InstallPlan.toList diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index c8ff9c9a08c..5b81862c8de 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -190,7 +190,7 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode where herald = ( hsep - [ text (InstallPlan.showPlanPackageTag pkg) + [ InstallPlan.renderPlanPackageTag pkg , InstallPlan.foldPlanPackage (const mempty) in_mem pkg , pretty (packageId pkg) , parens (pretty (nodeKey pkg)) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index e19e096b600..c2c72684d48 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -72,6 +72,7 @@ import qualified Distribution.Simple.Flag as Flag import Distribution.Simple.Setup (CommonSetupFlags (..), HaddockFlags (..), HaddockProjectFlags (..), defaultCommonSetupFlags, defaultHaddockFlags, defaultHaddockProjectFlags, toFlag) import Distribution.System import Distribution.Text +import Distribution.Utils.LogProgress import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath) import Distribution.Version import IntegrationTests2.CPP @@ -2253,10 +2254,12 @@ executePlan ts ] elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + either (error . show) id $ + runLogProgress' $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan pkgsBuildStatus <- rebuildTargetsDryRun diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index aff2318dab7..636703be3ae 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -30,6 +30,7 @@ import qualified Data.Set as Set import System.Random import Test.QuickCheck +import Distribution.Utils.LogProgress import Test.Tasty import Test.Tasty.QuickCheck @@ -255,24 +256,28 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do , let isRoot = n == 0 ] - ipkgs <- - sequenceA - [ mkIPkg pkgv depvs - | pkgv <- ipkgvs - , let depvs = graph ! pkgv - ] - srcpkgs <- - sequenceA - [ mkSrcPkg pkgv depvs - | pkgv <- srcpkgvs - , let depvs = graph ! pkgv - ] - let index = - Graph.fromDistinctList - ( map InstallPlan.PreExisting ipkgs - ++ map InstallPlan.Configured srcpkgs - ) - return $ InstallPlan.new index + let gen_plan :: Gen (Either ErrMsg (InstallPlan.GenericInstallPlan ipkg srcpkg)) + gen_plan = do + ipkgs <- + sequenceA + [ mkIPkg pkgv depvs + | pkgv <- ipkgvs + , let depvs = graph ! pkgv + ] + srcpkgs <- + sequenceA + [ mkSrcPkg pkgv depvs + | pkgv <- srcpkgvs + , let depvs = graph ! pkgv + ] + let index = + Graph.fromDistinctList + ( map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs + ) + return $ runLogProgress' $ InstallPlan.new' index + + gen_plan `suchThatMap` either (const Nothing) Just -- | Generate a random directed acyclic graph, based on the algorithm presented -- here From 6c35ee406fe7cda84f11c2b5f0678c3d1f9c5dba Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 1 Aug 2025 16:32:00 +0800 Subject: [PATCH 050/122] feat(cabal-install): implicilty monitor our own executable to burst stale cache --- cabal-install/src/Distribution/Client/RebuildMonad.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs index e6450addabc..96a238dc8f6 100644 --- a/cabal-install/src/Distribution/Client/RebuildMonad.hs +++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs @@ -76,6 +76,7 @@ import Control.Monad import Control.Monad.Reader as Reader import Control.Monad.State as State import qualified Data.Map.Strict as Map +import Distribution.Client.Compat.ExecutablePath (getExecutablePath) import System.Directory import System.FilePath @@ -134,6 +135,13 @@ rerunIfChanged verbosity monitor key action = do [x] -> return x _ -> error "rerunIfChanged: impossible!" +-- | Monitor our current executable file for changes. This is useful to prevent +-- stale cache when upgrading the cabal executable itself or while developing. +monitorOurselves :: Rebuild () +monitorOurselves = do + self <- liftIO getExecutablePath + monitorFiles [monitorFile self] + -- | Like '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. @@ -144,6 +152,8 @@ rerunConcurrentlyIfChanged -> [(FileMonitor a b, a, Rebuild b)] -> Rebuild [b] rerunConcurrentlyIfChanged verbosity mkJobControl triples = do + -- Implicitly add a monitor on our own executable file + monitorOurselves rootDir <- askRoot dacts <- forM triples $ \(monitor, key, action) -> do let monitorName = takeFileName (fileMonitorCacheFile monitor) From 861e292fffe40f4d0b676aad90d8bfd099443728 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 4 Aug 2025 15:17:47 +0800 Subject: [PATCH 051/122] refactor(Cabal-syntax): Improve Graph.broken If a node has dangling edges, then the list of missing neighbours cannot be empty. --- Cabal-syntax/src/Distribution/Compat/Graph.hs | 27 ++++++++++++------- Cabal/src/Distribution/Backpack/Configure.hs | 4 +-- .../Distribution/Client/CmdErrorMessages.hs | 2 +- .../src/Distribution/Client/Install.hs | 2 +- .../src/Distribution/Client/InstallPlan.hs | 9 +++---- .../Distribution/Client/ProjectPlanning.hs | 4 +-- .../Distribution/Client/SolverInstallPlan.hs | 14 +++++----- 7 files changed, 35 insertions(+), 27 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index 5d7dfcf5d56..26c5f71680a 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -100,10 +100,10 @@ import Distribution.Utils.Structured (Structure (..), Structured (..)) import qualified Data.Array as Array import qualified Data.Foldable as Foldable import qualified Data.Graph as G +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Tree as Tree -import qualified Distribution.Compat.Prelude as Prelude import GHC.Stack (HasCallStack) -- | A graph of nodes @a@. The nodes are expected to have instance @@ -115,7 +115,7 @@ data Graph a = Graph , graphAdjoint :: G.Graph , graphVertexToNode :: G.Vertex -> a , graphKeyToVertex :: Key a -> Maybe G.Vertex - , graphBroken :: [(a, [Key a])] + , graphBroken :: [(a, NonEmpty (Key a))] } -- NB: Not a Functor! (or Traversable), because you need @@ -285,7 +285,7 @@ cycles g = [vs | CyclicSCC vs <- stronglyConnComp g] -- | /O(1)/. Return a list of nodes paired with their broken -- neighbors (i.e., neighbor keys which are not in the graph). -- Requires amortized construction of graph. -broken :: Graph a -> [(a, [Key a])] +broken :: Graph a -> [(a, NonEmpty (Key a))] broken g = graphBroken g -- | Lookup the immediate neighbors from a key in the graph. @@ -344,7 +344,7 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) -- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ -- instead. The values of the map are assumed to already -- be in WHNF. -fromMap :: IsNode a => Map (Key a) a -> Graph a +fromMap :: forall a. (IsNode a, Eq (Key a)) => Map (Key a) a -> Graph a fromMap m = Graph { graphMap = m @@ -353,17 +353,26 @@ fromMap m = , graphAdjoint = G.transposeG g , graphVertexToNode = vertex_to_node , graphKeyToVertex = key_to_vertex - , graphBroken = broke + , graphBroken = + map (\ns'' -> (fst (NE.head ns''), NE.map snd ns'')) $ + NE.groupWith (nodeKey . fst) $ + brokenEdges' } where - try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) + brokenEdges' :: [(a, Key a)] + brokenEdges' = concat brokenEdges + brokenEdges :: [[(a, Key a)]] (brokenEdges, edges) = - unzip $ - [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) + unzip + [ partitionEithers + [ case key_to_vertex n' of + Just v -> Right v + Nothing -> Left (n, n') + | n' <- nodeNeighbors n + ] | n <- ns ] - broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) g = Array.listArray bounds edges diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index aec217ebd22..611537a7828 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -283,14 +283,14 @@ toComponentLocalBuildInfos [ "installed package " ++ prettyShow (packageId pkg) ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) + ++ intercalate ", " (map prettyShow $ toList deps) | (Left pkg, deps) <- broken ] ++ unlines [ "planned package " ++ prettyShow (packageId pkg) ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) + ++ intercalate ", " (map prettyShow $ toList deps) | (Right pkg, deps) <- broken ] diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs index 7eece5701f5..8f9bf63c1ba 100644 --- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs @@ -501,7 +501,7 @@ renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) = where -- throw away the details and just list the deps that are needed pkgids :: [PackageId] - pkgids = nub . map packageId . concatMap snd $ brokenPackages + pkgids = nub . map packageId . concatMap (NE.toList . snd) $ brokenPackages {- ++ "Syntax:\n" diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index f0c9c1e4837..9ec38fe0412 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -715,7 +715,7 @@ pruneInstallPlan pkgSpecifiers = nub [ depid | SolverInstallPlan.PackageMissingDeps _ depids <- problems - , depid <- depids + , depid <- toList depids , packageName depid `elem` targetnames ] diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index e7382a71592..66534cdc1d2 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -1048,7 +1048,7 @@ data PlanProblem ipkg srcpkg = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) -- ^ The package that is missing dependencies - [GraphKey ipkg srcpkg] + (NonEmpty (GraphKey ipkg srcpkg)) -- ^ The missing dependencies | -- | The packages involved in a dependency cycle PackageCycle @@ -1079,7 +1079,7 @@ renderPlanProblem (PackageMissingDeps pkg missingDeps) = [ text "Package" , pretty (nodeKey pkg) , text "depends on the following packages which are missing from the plan:" - , fsep (punctuate comma (map pretty missingDeps)) + , fsep (punctuate comma (map pretty $ NE.toList missingDeps)) ] renderPlanProblem (PackageCycle cycleGroup) = fsep @@ -1121,10 +1121,7 @@ checkForMissingDeps checkForMissingDeps graph = [ PackageMissingDeps pkg - ( mapMaybe - (fmap nodeKey . flip Graph.lookup graph) - missingDeps - ) + missingDeps | (pkg, missingDeps) <- Graph.broken graph ] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 262d81b61e6..1d6ad475762 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -3903,7 +3903,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = CannotPruneDependencies [ (pkg, missingDeps) | (pkg, missingDepIds) <- brokenPackages - , let missingDeps = mapMaybe lookupDep missingDepIds + , let missingDeps = NE.map (fromMaybe (error "should not happen") . lookupDep) missingDepIds ] where -- lookup in the original unpruned graph @@ -3918,7 +3918,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = newtype CannotPruneDependencies = CannotPruneDependencies [ ( ElaboratedPlanPackage - , [ElaboratedPlanPackage] + , NonEmpty ElaboratedPlanPackage ) ] deriving (Show) diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 69ae14704ed..b621838969c 100644 --- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs @@ -73,6 +73,7 @@ import Distribution.Solver.Types.SolverPackage import Data.Array ((!)) import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Distribution.Compat.Graph (Graph, IsNode (..)) import qualified Distribution.Compat.Graph as Graph @@ -183,7 +184,7 @@ valid = null . problems data SolverPlanProblem = PackageMissingDeps SolverPlanPackage - [PackageIdentifier] + (NE.NonEmpty PackageIdentifier) | PackageCycle [SolverPlanPackage] | PackageInconsistency QPN [(SolverId, SolverId)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage @@ -193,7 +194,7 @@ showPlanProblem (PackageMissingDeps pkg missingDeps) = "Package " ++ prettyShow (packageId pkg) ++ " depends on the following packages which are missing from the plan: " - ++ intercalate ", " (map prettyShow missingDeps) + ++ intercalate ", " (map prettyShow (NE.toList missingDeps)) showPlanProblem (PackageCycle cycleGroup) = "The following packages are involved in a dependency cycle " ++ intercalate ", " (map (prettyShow . packageId) cycleGroup) @@ -232,10 +233,11 @@ problems problems index = [ PackageMissingDeps pkg - ( mapMaybe - (fmap packageId . flip Graph.lookup index) - missingDeps - ) + -- ( mapMaybe + -- (fmap packageId . flip Graph.lookup index) + -- missingDeps + -- ) + (NE.map (packageId . fromMaybe (error "should not happen") . flip Graph.lookup index) missingDeps) | (pkg, missingDeps) <- Graph.broken index ] ++ [ PackageCycle cycleGroup From a052ff489a68d98d166038fb838b1173cbc1716d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 4 Aug 2025 15:17:47 +0800 Subject: [PATCH 052/122] refactor(cabal-install): harmonise various dependency functions --- .../Distribution/Client/ProjectPlanning.hs | 7 +- .../Client/ProjectPlanning/Types.hs | 150 ++++++++++-------- 2 files changed, 86 insertions(+), 71 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 1d6ad475762..fc40d71fa49 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1910,7 +1910,7 @@ elaborateInstallPlan compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] compExeDependencyPaths = -- External - [ (WithStage solverPkgStage confId, path) + [ (WithStage (stageOf pkg) confId, path) | pkg <- external_exe_dep_pkgs , let confId = configuredId pkg , confSrcId confId /= pkgid @@ -1967,8 +1967,6 @@ elaborateInstallPlan cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - infoProgress $ hang (text "configured component:") 4 (dispConfiguredComponent cc) - -- 4. Perform mix-in linking let lookup_uid def_uid = case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of @@ -1989,7 +1987,6 @@ elaborateInstallPlan cc -- \^ configured component - infoProgress $ hang (text "linked component:") 4 (dispLinkedComponent lc) -- NB: elab is setup to be the correct form for an -- indefinite library, or a definite library with no holes. -- We will modify it in 'instantiateInstallPlan' to handle @@ -3972,7 +3969,7 @@ setupHsScriptOptions , useDependencies = [ (confInstId cid, confSrcId cid) | -- TODO: we should filter for dependencies on libraries but that should be implicit in elabSetupLibDependencies - (WithStage _ cid, _promised) <- elabSetupLibDependencies elab + (WithStage _ cid) <- elabSetupLibDependencies elab ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 5b81862c8de..ea19684a7cc 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -25,7 +25,6 @@ module Distribution.Client.ProjectPlanning.Types , elabExeDependencies , elabOrderExeDependencies , elabSetupLibDependencies - , elabSetupExeDependencies , elabPkgConfigDependencies , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration @@ -579,6 +578,15 @@ elabDistDirParams shared elab = where Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab) +-- +-- Order dependencies +-- +-- Order dependencies are identified by their 'UnitId' and only used to define the +-- dependency relationships in the build graph. In particular they do not provide +-- any other information needed to build the component or package. We can consider +-- UnitId as a opaque identifier. +-- + -- | The full set of dependencies which dictate what order we -- need to build things in the install plan: "order dependencies" -- balls everything together. This is mostly only useful for @@ -590,66 +598,68 @@ elabDistDirParams shared elab = -- Note: this method DOES include setup deps. elabOrderDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderDependencies elab = - elabOrderLibDependencies elab ++ elabOrderExeDependencies elab + elabOrderLibDependencies elab <> elabOrderExeDependencies elab -- | The result includes setup dependencies elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderLibDependencies elab = - ordNub $ - [ fmap (newSimpleUnitId . confInstId) dep - | (dep, _promised) <- elabLibDependencies elab ++ elabSetupLibDependencies elab - ] + case elabPkgOrComp elab of + ElabPackage pkg -> + -- Note: flatDeps include the setup dependencies too + ordNub $ CD.flatDeps (pkgOrderLibDependencies pkg) + ElabComponent comp -> + map (WithStage (elabStage elab)) (compOrderLibDependencies comp) -- | The result includes setup dependencies elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [WithStage UnitId] elabOrderExeDependencies elab = - -- Compare with elabOrderLibDependencies. The setup dependencies here do not need - -- any special attention because the stage is already included in pkgExeDependencies. - map (fmap (newSimpleUnitId . confInstId)) $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.flatDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp - --- | The library dependencies (i.e., the libraries we depend on, NOT --- the dependencies of the library), NOT including setup dependencies. --- These are passed to the @Setup@ script via @--dependency@ or @--promised-dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] -elabLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> - ordNub - [ (WithStage (pkgStage pkg) cid, promised) - | (cid, promised) <- CD.nonSetupDeps (pkgLibDependencies pkg) - ] + ordNub $ CD.flatDeps (pkgOrderExeDependencies pkg) ElabComponent comp -> - [ (WithStage (elabStage elab) c, promised) - | (c, promised) <- compLibDependencies comp - ] - --- | The setup dependencies (the library dependencies of the setup executable; --- note that it is not legal for setup scripts to have executable --- dependencies at the moment.) -elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] -elabSetupLibDependencies elab = - case elabPkgOrComp elab of - ElabPackage pkg -> - ordNub - [ (WithStage (prevStage (pkgStage pkg)) cid, promised) - | (cid, promised) <- CD.setupDeps (pkgLibDependencies pkg) - ] - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] + map (fmap fromConfiguredId) (compExeDependencies comp) --- | This would not be allowed actually. See comment on elabSetupLibDependencies. -elabSetupExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] -elabSetupExeDependencies elab = - map (fmap confInstId) $ +-- | See 'elabOrderDependencies'. This gives the unflattened version, +-- which can be useful in some circumstances. +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderDependencies pkg = + pkgOrderLibDependencies pkg <> pkgOrderExeDependencies pkg + +pkgOrderLibDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderLibDependencies pkg = + CD.fromList + [ (comp, map (WithStage stage . fromConfiguredId . fst) deps) + | (comp, deps) <- CD.toList (pkgLibDependencies pkg) + , let stage = + if comp == CD.ComponentSetup + then prevStage (pkgStage pkg) + else pkgStage pkg + ] + +pkgOrderExeDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] +pkgOrderExeDependencies pkg = + fmap (map (fmap fromConfiguredId)) $ + pkgExeDependencies pkg + +fromConfiguredId :: ConfiguredId -> UnitId +fromConfiguredId = newSimpleUnitId . confInstId + +--- | Library dependencies. +--- +--- These are identified by their 'ConfiguredId' and are passed to the @Setup@ +--- script via @--dependency@ or @--promised-dependency@. +--- Note that setup dependencies (meaning the library dependencies of the setup +-- script) are not included here, they are handled separately. +elabLibDependencies :: ElaboratedConfiguredPackage -> [(WithStage ConfiguredId, Bool)] +elabLibDependencies elab = + -- Library dependencies are always in the same stage as the component/package we are + -- building. + map (\(cid, promised) -> (WithStage (elabStage elab) cid, promised)) $ case elabPkgOrComp elab of - ElabPackage pkg -> CD.setupDeps (pkgExeDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently - ElabComponent _ -> [] + ElabPackage pkg -> + ordNub $ CD.nonSetupDeps (pkgLibDependencies pkg) + ElabComponent comp -> + compLibDependencies comp -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke @@ -658,7 +668,7 @@ elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] elabExeDependencies elab = map (fmap confInstId) $ case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) + ElabPackage pkg -> ordNub $ CD.nonSetupDeps (pkgExeDependencies pkg) ElabComponent comp -> compExeDependencies comp -- | This returns the paths of all the executables we depend on; we @@ -668,14 +678,33 @@ elabExeDependencies elab = elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = case elabPkgOrComp elab of - ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabPackage pkg -> ordNub $ map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) ElabComponent comp -> map snd (compExeDependencyPaths comp) elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = - pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = - compPkgConfigDependencies comp +elabPkgConfigDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> pkgPkgConfigDependencies pkg + ElabComponent comp -> compPkgConfigDependencies comp + +-- | The setup dependencies (i.e. the library dependencies of the setup executable) +-- Note that it is not legal for setup scripts to have executable dependencies. +-- TODO: In that case we should probably not have this function at all, and +-- only use pkgSetupLibDependencies +elabSetupLibDependencies :: ElaboratedConfiguredPackage -> [WithStage ConfiguredId] +elabSetupLibDependencies elab = + case elabPkgOrComp elab of + ElabPackage pkg -> pkgSetupLibDependencies pkg + -- Custom setups not supported for components. + ElabComponent _ -> [] + +pkgSetupLibDependencies :: ElaboratedPackage -> [WithStage ConfiguredId] +pkgSetupLibDependencies pkg = + map (WithStage stage . fst) $ + ordNub $ + CD.setupDeps (pkgLibDependencies pkg) + where + stage = prevStage (pkgStage pkg) -- | The cache files of all our inplace dependencies which, -- when updated, require us to rebuild. See #4202 for @@ -750,7 +779,7 @@ data ElaboratedComponent = ElaboratedComponent , compOrderLibDependencies :: [UnitId] -- ^ The UnitIds of the libraries (identifying elaborated packages/ -- components) that must be built before this project. This - -- is used purely for ordering purposes. It can contain both + -- is used purely for ordering purposes. It can contain both -- references to definite and indefinite packages; an indefinite -- UnitId indicates that we must typecheck that indefinite package -- before we can build this one. @@ -833,17 +862,6 @@ whyNotPerComponent = \case CuzNoBuildableComponents -> "there are no buildable components" CuzDisablePerComponent -> "you passed --disable-per-component" --- | See 'elabOrderDependencies'. This gives the unflattened version, --- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [WithStage UnitId] -pkgOrderDependencies pkg = - fmap - (map (\(cid, _) -> WithStage (pkgStage pkg) (newSimpleUnitId $ confInstId cid))) - (pkgLibDependencies pkg) - <> fmap - (map (fmap (newSimpleUnitId . confInstId))) - (pkgExeDependencies pkg) - -- | This is used in the install plan to indicate how the package will be -- built. data BuildStyle From 6a603fa48caa68ca6d3070fe71ef7d5756f27667 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Aug 2025 10:36:56 +0800 Subject: [PATCH 053/122] refactor(cabal-install): rename, format and comment --- .../Distribution/Client/ProjectPlanning.hs | 854 +++++++++--------- 1 file changed, 437 insertions(+), 417 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index fc40d71fa49..3a298726e2a 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1703,383 +1703,396 @@ elaborateInstallPlan => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents mapDep spkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = - case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do - let src_comps = componentsGraphToList g - infoProgress $ - hang - (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured spkg))) - 4 - (dispComponentsWithDeps src_comps) - (_, comps) <- - mapAccumM - buildComponent - (Map.empty, Map.empty, Map.empty) - (map fst src_comps) - let whyNotPerComp = why_not_per_component src_comps - case NE.nonEmpty whyNotPerComp of - Nothing -> - return comps - Just notPerCompReasons -> do - checkPerPackageOk comps notPerCompReasons - pkgComp <- - elaborateSolverToPackage - notPerCompReasons - spkg - g - (comps ++ maybeToList setupComponent) - return [pkgComp] - Left cns -> - dieProgress $ - hang - (text "Dependency cycle between the following components:") - 4 - (vcat (map (text . componentNameStanza) cns)) - where - bt = PD.buildType (elabPkgDescription elab0) - -- You are eligible to per-component build if this list is empty - why_not_per_component g = - cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag - where - -- Custom and Hooks are not implemented. Implementing - -- per-component builds with Custom would require us to create a - -- new 'ElabSetup' type, and teach all of the code paths how to - -- handle it. - -- Once you've implemented this, swap it for the code below. - cuz_buildtype = - case bt of - PD.Configure -> [] - -- Configure is supported, but we only support configuring the - -- main library in cabal. Other components will need to depend - -- on the main library for configured data. - PD.Custom -> [CuzBuildType CuzCustomBuildType] - PD.Hooks -> [CuzBuildType CuzHooksBuildType] - PD.Make -> [CuzBuildType CuzMakeBuildType] - PD.Simple -> [] - -- cabal-format versions prior to 1.8 have different build-depends semantics - -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 - -- see, https://github.com/haskell/cabal/issues/4121 - cuz_spec - | PD.specVersion pd >= CabalSpecV1_8 = [] - | otherwise = [CuzCabalSpecVersion] - -- In the odd corner case that a package has no components at all - -- then keep it as a whole package, since otherwise it turns into - -- 0 component graph nodes and effectively vanishes. We want to - -- keep it around at least for error reporting purposes. - cuz_length - | length g > 0 = [] - | otherwise = [CuzNoBuildableComponents] - -- For ease of testing, we let per-component builds be toggled - -- at the top level - cuz_flag - | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = - [] - | otherwise = [CuzDisablePerComponent] - - -- \| Sometimes a package may make use of features which are only - -- supported in per-package mode. If this is the case, we should - -- give an error when this occurs. - checkPerPackageOk comps reasons = do - let is_sublib (CLibName (LSubLibName _)) = True - is_sublib _ = False - when (any (matchElabPkg is_sublib) comps) $ + elaborateSolverToComponents + mapDep + solverPkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = + case mkComponentsGraph (elabEnabledSpec elab0) pd of + Left cns -> dieProgress $ - text "Internal libraries only supported with per-component builds." - $$ text "Per-component builds were disabled because" - <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) - -- TODO: Maybe exclude Backpack too - - elab0 = elaborateSolverToCommon spkg - pkgid = elabPkgSourceId elab0 - pd = elabPkgDescription elab0 - - -- TODO: This is just a skeleton to get elaborateSolverToPackage - -- working correctly - -- TODO: When we actually support building these components, we - -- have to add dependencies on this from all other components - setupComponent :: Maybe ElaboratedConfiguredPackage - setupComponent - | bt `elem` [PD.Custom, PD.Hooks] = - Just - elab0 - { elabModuleShape = emptyModuleShape - , elabUnitId = notImpl "elabUnitId" - , elabComponentId = notImpl "elabComponentId" - , elabInstallDirs = notImpl "elabInstallDirs" - , elabPkgOrComp = - ElabComponent - ( ElaboratedComponent - { compSolverName = CD.ComponentSetup - , compComponentName = Nothing - , compLibDependencies = - [ (configuredId cid, False) - | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep - ] - , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - , compOrderLibDependencies = notImpl "compOrderLibDependencies" - , -- Not supported: - compExeDependencies = mempty - , compExeDependencyPaths = mempty - , compPkgConfigDependencies = mempty - , compInstantiatedWith = mempty - , compLinkedInstantiatedWith = Map.empty - } - ) - } - | otherwise = - Nothing - where - notImpl f = - error $ - "Distribution.Client.ProjectPlanning.setupComponent: " - ++ f - ++ " not implemented yet" - - -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) - buildComponent - :: HasCallStack - => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) - , Map ComponentId (OpenUnitId, ModuleShape) - , Map ComponentId FilePath - ) - -> Cabal.Component - -> LogProgress - ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) - , Map ComponentId (OpenUnitId, ModuleShape) - , Map ComponentId FilePath + hang + (text "Dependency cycle between the following components:") + 4 + (vcat (map (text . componentNameStanza) cns)) + Right g -> do + let src_comps = componentsGraphToList g + + infoProgress $ + hang + (text "Component graph for" <+> pretty (solverId (ResolverPackage.Configured solverPkg))) + 4 + (dispComponentsWithDeps src_comps) + + (_, comps) <- + mapAccumM + buildComponent + (Map.empty, Map.empty, Map.empty) + (map fst src_comps) + + let whyNotPerComp = why_not_per_component src_comps + + case NE.nonEmpty whyNotPerComp of + Nothing -> + return comps + Just notPerCompReasons -> do + checkPerPackageOk comps notPerCompReasons + pkgComp <- + elaborateSolverToPackage + notPerCompReasons + solverPkg + g + (comps ++ maybeToList setupComponent) + return [pkgComp] + where + bt = PD.buildType (elabPkgDescription elab0) + + -- You are eligible to per-component build if this list is empty + why_not_per_component g = + cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag + where + -- Custom and Hooks are not implemented. Implementing + -- per-component builds with Custom would require us to create a + -- new 'ElabSetup' type, and teach all of the code paths how to + -- handle it. + -- Once you've implemented this, swap it for the code below. + cuz_buildtype = + case bt of + PD.Configure -> [] + -- Configure is supported, but we only support configuring the + -- main library in cabal. Other components will need to depend + -- on the main library for configured data. + PD.Custom -> [CuzBuildType CuzCustomBuildType] + PD.Hooks -> [CuzBuildType CuzHooksBuildType] + PD.Make -> [CuzBuildType CuzMakeBuildType] + PD.Simple -> [] + -- cabal-format versions prior to 1.8 have different build-depends semantics + -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8 + -- see, https://github.com/haskell/cabal/issues/4121 + cuz_spec + | PD.specVersion pd >= CabalSpecV1_8 = [] + | otherwise = [CuzCabalSpecVersion] + -- In the odd corner case that a package has no components at all + -- then keep it as a whole package, since otherwise it turns into + -- 0 component graph nodes and effectively vanishes. We want to + -- keep it around at least for error reporting purposes. + cuz_length + | length g > 0 = [] + | otherwise = [CuzNoBuildableComponents] + -- For ease of testing, we let per-component builds be toggled + -- at the top level + cuz_flag + | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) = + [] + | otherwise = [CuzDisablePerComponent] + + -- \| Sometimes a package may make use of features which are only + -- supported in per-package mode. If this is the case, we should + -- give an error when this occurs. + checkPerPackageOk comps reasons = do + let is_sublib (CLibName (LSubLibName _)) = True + is_sublib _ = False + when (any (matchElabPkg is_sublib) comps) $ + dieProgress $ + text "Internal libraries only supported with per-component builds." + $$ text "Per-component builds were disabled because" + <+> fsep (punctuate comma $ map (text . whyNotPerComponent) $ toList reasons) + -- TODO: Maybe exclude Backpack too + + elab0 = elaborateSolverToCommon solverPkg + pkgid = elabPkgSourceId elab0 + pd = elabPkgDescription elab0 + + -- TODO: This is just a skeleton to get elaborateSolverToPackage + -- working correctly + -- TODO: When we actually support building these components, we + -- have to add dependencies on this from all other components + setupComponent :: Maybe ElaboratedConfiguredPackage + setupComponent + | bt `elem` [PD.Custom, PD.Hooks] = + Just + elab0 + { elabModuleShape = emptyModuleShape + , elabUnitId = notImpl "elabUnitId" + , elabComponentId = notImpl "elabComponentId" + , elabInstallDirs = notImpl "elabInstallDirs" + , elabPkgOrComp = + ElabComponent + ( ElaboratedComponent + { compSolverName = CD.ComponentSetup + , compComponentName = Nothing + , compLibDependencies = + [ (configuredId cid, False) + | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep + ] + , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" + , compOrderLibDependencies = notImpl "compOrderLibDependencies" + , -- Not supported: + compExeDependencies = mempty + , compExeDependencyPaths = mempty + , compPkgConfigDependencies = mempty + , compInstantiatedWith = mempty + , compLinkedInstantiatedWith = Map.empty + } + ) + } + | otherwise = + Nothing + where + notImpl f = + error $ + "Distribution.Client.ProjectPlanning.setupComponent: " + ++ f + ++ " not implemented yet" + + -- Note: this function is used to configure the components in a single package (`elab`, defined in the outer scope) + buildComponent + :: HasCallStack + => ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) + , Map ComponentId FilePath + ) + -> Cabal.Component + -> LogProgress + ( ( Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + , Map ComponentId (OpenUnitId, ModuleShape) + , Map ComponentId FilePath + ) + , ElaboratedConfiguredPackage ) - , ElaboratedConfiguredPackage + buildComponent (cc_map, lc_map, exe_map) comp = + addProgressCtx + ( text "In the stanza" + <+> quotes (text (componentNameStanza cname)) ) - buildComponent (cc_map, lc_map, exe_map) comp = - addProgressCtx - ( text "In the stanza" - <+> quotes (text (componentNameStanza cname)) - ) - $ do - let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map - -- TODO: is cc_map correct here? - exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map - - -- 1. Configure the component, but with a place holder ComponentId. - infoProgress $ - hang (text "configuring component" <+> pretty cname) 4 $ - vcat - [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) - , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) - ] - cc0 <- - toConfiguredComponent - pd - (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - lib_dep_map - exe_dep_map - comp - - let do_ cid = - let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid - in (cid', False) -- filled in later in pruneInstallPlanPhase2) - - -- 2. Read out the dependencies from the ConfiguredComponent cc0 - let compLibDependencies = - -- Nub because includes can show up multiple times - ordNub - ( map - (\cid -> do_ cid) - (cc_includes cc0) - ) - - compExeDependencies :: [WithStage ConfiguredId] - compExeDependencies = - -- External - [ WithStage (stageOf pkg) confId - | pkg <- external_exe_dep_pkgs - , let confId = configuredId pkg - , -- only executables - Just (CExeName _) <- [confCompName confId] - , confSrcId confId /= pkgid - ] - <> - -- Internal, assume the same stage - [ WithStage solverPkgStage confId - | aid <- cc_exe_deps cc0 - , let confId = annotatedIdToConfiguredId aid - , confSrcId confId == pkgid + $ do + let lib_dep_map = Map.unionWith Map.union external_lib_cc_map cc_map + -- TODO: is cc_map correct here? + exe_dep_map = Map.unionWith Map.union external_exe_cc_map cc_map + + -- 1. Configure the component, but with a place holder ComponentId. + infoProgress $ + hang (text "configuring component" <+> pretty cname) 4 $ + vcat + [ text "lib_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys lib_dep_map)) + , text "exe_dep_map:" <+> Disp.hsep (punctuate comma $ map pretty (Map.keys exe_dep_map)) ] - compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] - compExeDependencyPaths = - -- External - [ (WithStage (stageOf pkg) confId, path) - | pkg <- external_exe_dep_pkgs - , let confId = configuredId pkg - , confSrcId confId /= pkgid - , -- only executables - Just (CExeName _) <- [confCompName confId] - , path <- planPackageExePaths pkg - ] - <> - -- Internal, assume the same stage - [ (WithStage solverPkgStage confId, path) - | aid <- cc_exe_deps cc0 - , let confId = annotatedIdToConfiguredId aid - , confSrcId confId == pkgid - , Just paths <- [Map.lookup (ann_id aid) exe_map1] - , path <- paths - ] - - elab_comp = - ElaboratedComponent - { compSolverName - , compComponentName - , compLibDependencies - , compExeDependencies - , compPkgConfigDependencies - , compExeDependencyPaths - , compInstantiatedWith = Map.empty - , compLinkedInstantiatedWith = Map.empty - , -- filled later (in step 5) - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - } + cc0 <- + toConfiguredComponent + pd + (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") + lib_dep_map + exe_dep_map + comp + + let do_ cid = + let cid' = annotatedIdToConfiguredId . ci_ann_id $ cid + in (cid', False) -- filled in later in pruneInstallPlanPhase2) + + -- 2. Read out the dependencies from the ConfiguredComponent cc0 + let compLibDependencies = + -- Nub because includes can show up multiple times + ordNub + ( map + (\cid -> do_ cid) + (cc_includes cc0) + ) - -- 3. Construct a preliminary ElaboratedConfiguredPackage, - -- and use this to compute the component ID. Fix up cc_id - -- correctly. - let elab1 = - elab0 - { elabPkgOrComp = ElabComponent elab_comp + compExeDependencies :: [WithStage ConfiguredId] + compExeDependencies = + -- External + [ WithStage (stageOf pkg) confId + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , -- only executables + Just (CExeName _) <- [confCompName confId] + , confSrcId confId /= pkgid + ] + <> + -- Internal, assume the same stage + [ WithStage solverPkgStage confId + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + ] + + compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] + compExeDependencyPaths = + -- External + [ (WithStage (stageOf pkg) confId, path) + | pkg <- external_exe_dep_pkgs + , let confId = configuredId pkg + , confSrcId confId /= pkgid + , -- only executables + Just (CExeName _) <- [confCompName confId] + , path <- planPackageExePaths pkg + ] + <> + -- Internal, assume the same stage + [ (WithStage solverPkgStage confId, path) + | aid <- cc_exe_deps cc0 + , let confId = annotatedIdToConfiguredId aid + , confSrcId confId == pkgid + , Just paths <- [Map.lookup (ann_id aid) exe_map1] + , path <- paths + ] + + elab_comp = + ElaboratedComponent + { compSolverName + , compComponentName + , compLibDependencies + , compExeDependencies + , compPkgConfigDependencies + , compExeDependencyPaths + , compInstantiatedWith = Map.empty + , compLinkedInstantiatedWith = Map.empty + , -- filled later (in step 5) + compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" + , compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" + } + + -- 3. Construct a preliminary ElaboratedConfiguredPackage, + -- and use this to compute the component ID. Fix up cc_id + -- correctly. + let elab1 = + elab0 + { elabPkgOrComp = ElabComponent elab_comp + } + + -- This is where the component id is computed. + cid = case elabBuildStyle elab0 of + BuildInplaceOnly{} -> + mkComponentId $ + case Cabal.componentNameString cname of + Nothing -> prettyShow pkgid + Just n -> prettyShow pkgid ++ "-" ++ prettyShow n + BuildAndInstall -> + hashedInstalledPackageId + ( packageHashInputs + elaboratedSharedConfig + elab1 -- knot tied + ) + + cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} + + -- 4. Perform mix-in linking + let lookup_uid def_uid = + case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of + Just full -> full + Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) + lc_dep_map = Map.union external_lc_map lc_map + lc <- + toLinkedComponent + verbosity + False + -- \^ whether there are any "promised" package dependencies which we won't find already installed + lookup_uid + -- \^ full db + (elabPkgSourceId elab0) + -- \^ the source package id + lc_dep_map + -- \^ linked component map + cc + -- \^ configured component + + -- NB: elab is setup to be the correct form for an + -- indefinite library, or a definite library with no holes. + -- We will modify it in 'instantiateInstallPlan' to handle + -- instantiated packages. + + -- 5. Construct the final ElaboratedConfiguredPackage + let + elab2 = + elab1 + { elabModuleShape = lc_shape lc + , elabUnitId = abstractUnitId (lc_uid lc) + , elabComponentId = lc_cid lc + , elabPkgOrComp = + ElabComponent $ + elab_comp + { compLinkedLibDependencies = + ordNub (map ci_id (lc_includes lc)) + , compOrderLibDependencies = + ordNub + ( map + (abstractUnitId . ci_id) + (lc_includes lc ++ lc_sig_includes lc) + ) + , compLinkedInstantiatedWith = + Map.fromList (lc_insts lc) + } } - - -- This is where the component id is computed. - cid = case elabBuildStyle elab0 of - BuildInplaceOnly{} -> - mkComponentId $ - case Cabal.componentNameString cname of - Nothing -> prettyShow pkgid - Just n -> prettyShow pkgid ++ "-" ++ prettyShow n - BuildAndInstall -> - hashedInstalledPackageId - ( packageHashInputs + elab = + elab2 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs elaboratedSharedConfig - elab1 -- knot tied - ) + elab2 + } - cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - - -- 4. Perform mix-in linking - let lookup_uid def_uid = - case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of - Just full -> full - Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc_dep_map = Map.union external_lc_map lc_map - lc <- - toLinkedComponent - verbosity - False - -- \^ whether there are any "promised" package dependencies which we won't find already installed - lookup_uid - -- \^ full db - (elabPkgSourceId elab0) - -- \^ the source package id - lc_dep_map - -- \^ linked component map - cc - -- \^ configured component - - -- NB: elab is setup to be the correct form for an - -- indefinite library, or a definite library with no holes. - -- We will modify it in 'instantiateInstallPlan' to handle - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = - elab1 - { elabModuleShape = lc_shape lc - , elabUnitId = abstractUnitId (lc_uid lc) - , elabComponentId = lc_cid lc - , elabPkgOrComp = - ElabComponent $ - elab_comp - { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)) - , compOrderLibDependencies = - ordNub - ( map - (abstractUnitId . ci_id) - (lc_includes lc ++ lc_sig_includes lc) - ) - , compLinkedInstantiatedWith = Map.fromList (lc_insts lc) - } - } - elab = - elab2 - { elabInstallDirs = - computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } + -- 6. Construct the updated local maps + let cc_map' = extendConfiguredComponentMap cc cc_map + lc_map' = extendLinkedComponentMap lc lc_map + exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map - -- 6. Construct the updated local maps - let cc_map' = extendConfiguredComponentMap cc cc_map - lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + return ((cc_map', lc_map', exe_map'), elab) + where + cname = Cabal.componentName comp + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname - return ((cc_map', lc_map', exe_map'), elab) - where - cname = Cabal.componentName comp - compComponentName = Just cname - compSolverName = CD.componentNameToComponent cname + -- External dependencies. I.e. dependencies of the component on components of other packages. + external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps - -- External dependencies. I.e. dependencies of the component on components of other packages. - external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps + external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps - external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps + external_exe_map = + Map.fromList $ + [ (getComponentId pkg, planPackageExePaths pkg) + | pkg <- external_exe_dep_pkgs + ] - external_exe_map = - Map.fromList $ - [ (getComponentId pkg, planPackageExePaths pkg) - | pkg <- external_exe_dep_pkgs + exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map + + external_lib_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_lib_dep_pkgs + + external_exe_cc_map = + Map.fromListWith Map.union $ + map mkCCMapping external_exe_dep_pkgs + + external_lc_map = + Map.fromList $ + map mkShapeMapping $ + external_lib_dep_pkgs ++ external_exe_dep_pkgs + + compPkgConfigDependencies = + [ ( pn + , fromMaybe + ( error $ + "compPkgConfigDependencies: impossible! " + ++ prettyShow pn + ++ " from " + ++ prettyShow (elabPkgSourceId elab0) + ) + (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) + ) + | PkgconfigDependency pn _ <- + PD.pkgconfigDepends + (Cabal.componentBuildInfo comp) ] - exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map - - external_lib_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_lib_dep_pkgs - external_exe_cc_map = - Map.fromListWith Map.union $ - map mkCCMapping external_exe_dep_pkgs - external_lc_map = - Map.fromList $ - map mkShapeMapping $ - external_lib_dep_pkgs ++ external_exe_dep_pkgs - - compPkgConfigDependencies = - [ ( pn - , fromMaybe - ( error $ - "compPkgConfigDependencies: impossible! " - ++ prettyShow pn - ++ " from " - ++ prettyShow (elabPkgSourceId elab0) - ) - (getStage pkgConfigDB (elabStage elab0) >>= \db -> pkgConfigDbPkgVersion db pn) - ) - | PkgconfigDependency pn _ <- - PD.pkgconfigDepends - (Cabal.componentBuildInfo comp) - ] - inplace_bin_dir elab = - binDirectoryFor - distDirLayout - elaboratedSharedConfig - elab - $ case Cabal.componentNameString cname of - Just n -> prettyShow n - Nothing -> "" + inplace_bin_dir elab = + binDirectoryFor + distDirLayout + elaboratedSharedConfig + elab + $ case Cabal.componentNameString cname of + Just n -> prettyShow n + Nothing -> "" -- \| Given a 'SolverId' referencing a dependency on a library, return -- the 'ElaboratedPlanPackage' corresponding to the library. This @@ -2130,7 +2143,7 @@ elaborateInstallPlan -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent - pkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} + solverPkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} compGraph comps = do -- Knot tying: the final elab includes the @@ -2142,25 +2155,13 @@ elaborateInstallPlan { elabPkgSourceHash , elabStanzasRequested , elabStage - } = elaborateSolverToCommon pkg + } = elaborateSolverToCommon solverPkg elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabPkgOrComp = - ElabPackage $ - ElaboratedPackage - { pkgStage = elabStage - , pkgInstalledId - , pkgLibDependencies - , pkgDependsOnSelfLib - , pkgExeDependencies - , pkgExeDependencyPaths - , pkgPkgConfigDependencies - , pkgStanzasEnabled - , pkgWhyNotPerComponent - } + , elabPkgOrComp = ElabPackage elabPkg , elabModuleShape = modShape } @@ -2179,7 +2180,7 @@ elaborateInstallPlan Just e -> Ty.elabModuleShape e pkgInstalledId - | shouldBuildInplaceOnly pkg = + | shouldBuildInplaceOnly solverPkg = mkComponentId (prettyShow srcpkgPackageId) | otherwise = assert (isJust elabPkgSourceHash) $ @@ -2194,19 +2195,32 @@ elaborateInstallPlan isExternal confid = confSrcId confid /= srcpkgPackageId isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId - pkgLibDependencies = - buildComponentDeps (filter (isExternal . fst) . compLibDependencies) - - pkgExeDependencies = - buildComponentDeps (filter isExternal' . compExeDependencies) - - pkgExeDependencyPaths = - buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) - - -- TODO: Why is this flat? - pkgPkgConfigDependencies = - CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + elabPkg = + ElaboratedPackage + { pkgStage = elabStage + , pkgInstalledId + , pkgLibDependencies = buildComponentDeps (filter (isExternal . fst) . compLibDependencies) + , pkgDependsOnSelfLib + , pkgExeDependencies = buildComponentDeps (filter isExternal' . compExeDependencies) + , pkgExeDependencyPaths = buildComponentDeps (filter (isExternal' . fst) . compExeDependencyPaths) + , -- Why is this flat? + pkgPkgConfigDependencies = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + , -- NB: This is not the final setting of 'pkgStanzasEnabled'. + -- See [Sticky enabled testsuites]; we may enable some extra + -- stanzas opportunistically when it is cheap to do so. + -- + -- However, we start off by enabling everything that was + -- requested, so that we can maintain an invariant that + -- pkgStanzasEnabled is a superset of elabStanzasRequested + pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested + , pkgWhyNotPerComponent + } + -- This tells us which components depend on the main library of this package. + -- Note: the sublib case should not occur, because sub-libraries are not + -- supported without per-component builds. + -- TODO: Add a check somewhere that this is the case. + pkgDependsOnSelfLib :: CD.ComponentDeps [()] pkgDependsOnSelfLib = CD.fromList [ (CD.componentNameToComponent cn, [()]) @@ -2226,20 +2240,11 @@ elaborateInstallPlan | ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} <- comps ] - -- NB: This is not the final setting of 'pkgStanzasEnabled'. - -- See [Sticky enabled testsuites]; we may enable some extra - -- stanzas opportunistically when it is cheap to do so. - -- - -- However, we start off by enabling everything that was - -- requested, so that we can maintain an invariant that - -- pkgStanzasEnabled is a superset of elabStanzasRequested - pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> ElaboratedConfiguredPackage elaborateSolverToCommon - pkg@SolverPackage + solverPkg@SolverPackage { solverPkgStage , solverPkgSource = SourcePackage @@ -2276,17 +2281,20 @@ elaborateInstallPlan elabPlatform = getStage platforms elabStage elabProgramDb = getStage programDbs elabStage - elabPkgDescription = case PD.finalizePD - solverPkgFlags - elabEnabledSpec - (const Satisfied) - elabPlatform - (compilerInfo elabCompiler) - [] - srcpkgDescription of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabPkgDescription = + case PD.finalizePD + solverPkgFlags + elabEnabledSpec + (const Satisfied) + elabPlatform + (compilerInfo elabCompiler) + [] + srcpkgDescription of + Right (desc, _) -> desc + Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" + elabFlagAssignment = solverPkgFlags + elabFlagDefaults = PD.mkFlagAssignment [ (PD.flagName flag, PD.flagDefault flag) @@ -2337,10 +2345,13 @@ elaborateInstallPlan else cp elabPkgSourceLocation = srcpkgSource + elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes - elabLocalToProject = isLocalToProject pkg + + elabLocalToProject = isLocalToProject solverPkg + elabBuildStyle = - if shouldBuildInplaceOnly pkg + if shouldBuildInplaceOnly solverPkg then BuildInplaceOnly OnDisk else BuildAndInstall @@ -2349,12 +2360,14 @@ elaborateInstallPlan elabRegisterPackageDBStack = buildAndRegisterDbs elabStage elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = packageSetupScriptSpecVersion elabSetupScriptStyle elabPkgDescription libDepGraph solverPkgLibDeps + elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage) -- Same as corePackageDbs but with the addition of the in-place packagedb. @@ -2368,7 +2381,7 @@ elaborateInstallPlan elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) buildAndRegisterDbs stage - | shouldBuildInplaceOnly pkg = inplacePackageDbs stage + | shouldBuildInplaceOnly solverPkg = inplacePackageDbs stage | otherwise = corePackageDbs stage elabPkgDescriptionOverride = srcpkgDescrOverride @@ -2426,6 +2439,7 @@ elaborateInstallPlan | prog <- configuredPrograms elabProgramDb ] <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths + elabProgramArgs = Map.unionWith (++) @@ -2437,13 +2451,16 @@ elaborateInstallPlan ] ) (perPkgOptionMapMappend srcpkgPackageId packageConfigProgramArgs) + elabProgramPathExtra = perPkgOptionNubList srcpkgPackageId packageConfigProgramPathExtra elabConfiguredPrograms = configuredPrograms elabProgramDb elabConfigureScriptArgs = perPkgOptionList srcpkgPackageId packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirs elabExtraLibDirsStatic = perPkgOptionList srcpkgPackageId packageConfigExtraLibDirsStatic elabExtraFrameworkDirs = perPkgOptionList srcpkgPackageId packageConfigExtraFrameworkDirs elabExtraIncludeDirs = perPkgOptionList srcpkgPackageId packageConfigExtraIncludeDirs + elabProgPrefix = perPkgOptionMaybe srcpkgPackageId packageConfigProgPrefix elabProgSuffix = perPkgOptionMaybe srcpkgPackageId packageConfigProgSuffix @@ -2492,7 +2509,6 @@ elaborateInstallPlan where exe = fromFlagOrDefault def bothflag lib = fromFlagOrDefault def (bothflag <> libflag) - bothflag = lookupPerPkgOption pkgid fboth libflag = lookupPerPkgOption pkgid flib @@ -2627,6 +2643,7 @@ elaborateInstallPlan NonSetupLibDepSolverPlanPackage (SolverInstallPlan.toList solverPlan) + packagesWithLibDepsDownwardClosedProperty :: (PackageIdentifier -> Bool) -> Set PackageIdentifier packagesWithLibDepsDownwardClosedProperty property = Set.fromList . map packageId @@ -2651,12 +2668,15 @@ elaborateInstallPlan -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing -shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of - LocalUnpackedPackage _ -> Just (packageId pkg) - _ -> Nothing +shouldBeLocal (NamedPackage _ _) = + Nothing +shouldBeLocal (SpecificSourcePackage pkg) = + case srcpkgSource pkg of + LocalUnpackedPackage _ -> Just (packageId pkg) + _ -> Nothing -- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'. +-- TODO: check the role of stage here. matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool matchPlanPkg p = InstallPlan.foldPlanPackage (\(WithStage _stage ipkg) -> p (ipiComponentName ipkg)) (matchElabPkg p) From 89c5019a00920ecb6f2401f90aedf15679e2d46d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Aug 2025 11:13:40 +0800 Subject: [PATCH 054/122] refactor(cabal-install): pkgDependsOnSelfLib should not hide failures Exceptions are not nice but this is an obvious invariant. Graph should provide a better API to make this unnecessary. --- .../src/Distribution/Client/ProjectPlanning.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 3a298726e2a..11690ebfc8d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -2224,14 +2224,12 @@ elaborateInstallPlan pkgDependsOnSelfLib = CD.fromList [ (CD.componentNameToComponent cn, [()]) - | Graph.N _ cn _ <- fromMaybe [] mb_closure + | Graph.N _ cn _ <- closure ] where - mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k] - -- NB: the sublib case should not occur, because sub-libraries - -- are not supported without per-component builds - is_lib (CLibName _) = True - is_lib _ = False + closure = + fromMaybe (error "elaborateSolverToPackage: internal error, no closure for main lib") $ + Graph.revClosure compGraph [k | k@(CLibName LMainLibName) <- Graph.keys compGraph] buildComponentDeps :: Monoid a => (ElaboratedComponent -> a) -> CD.ComponentDeps a buildComponentDeps f = From d326ad43aa269dc374151841fd9078b27260a894 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 6 Aug 2025 13:11:51 +0800 Subject: [PATCH 055/122] fix(Cabal): do not print finalized package description, it loops Not really a fix. I do not know why this happens. --- Cabal/src/Distribution/Simple/Configure.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 80faf3edae0..86f17478720 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -79,7 +79,6 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.PrettyPrint import Distribution.Simple.BuildTarget import Distribution.Simple.BuildToolDepends import Distribution.Simple.BuildWay @@ -931,9 +930,10 @@ configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 pac , extraCoverageFor = [] } - debug verbosity $ - "Finalized package description:\n" - ++ showPackageDescription pkg_descr2 + -- FIXME: Printing the package description loops indefinitely. + -- debug verbosity $ + -- "Finalized package description:\n" + -- ++ showPackageDescription pkg_descr2 return (lbc, pbd) From 7a53354144b0fa2bd21dc3caeadd839d74ba99d4 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 6 Aug 2025 12:37:31 +0800 Subject: [PATCH 056/122] feature(cabal-install): improve logging of setup arguments --- cabal-install/src/Distribution/Client/SetupWrapper.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 641bae5d1ac..87301412b7b 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -550,7 +550,7 @@ internalSetupMethod verbosity options bt args = do "Using internal setup method with build-type " ++ show bt ++ " and args:\n " - ++ show args + ++ unwords args -- NB: we do not set the working directory of the process here, because -- we will instead pass the -working-dir flag when invoking the Setup script. -- Note that the Setup script is guaranteed to support this flag, because @@ -623,7 +623,7 @@ selfExecSetupMethod verbosity options bt args0 = do "Using self-exec internal setup method with build-type " ++ show bt ++ " and args:\n " - ++ show args + ++ unwords args path <- getExecutablePath invoke verbosity path args options From ed6d1445dcf4dbda499067b5f94166cfd5255f7b Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 17:03:53 +0800 Subject: [PATCH 057/122] fix(Cabal): fix abi tag in case ghc's unit-id is the same as the compiler id --- Cabal/src/Distribution/Simple/GHC.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 4878fd984a3..9ed735b28ec 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -237,12 +237,13 @@ configureCompiler verbosity hcPath conf0 = do -- In this example, @AbiTag@ is "inplace". compilerAbiTag :: AbiTag compilerAbiTag = - maybe - NoAbiTag - AbiTag - ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId) - <$> Map.lookup "Project Unit Id" ghcInfoMap - ) + case Map.lookup "Project Unit Id" ghcInfoMap of + Nothing -> NoAbiTag + Just "" -> NoAbiTag + Just projectUnitId -> + case dropWhile (== '-') $ stripCommonPrefix (prettyShow compilerId) projectUnitId of + "" -> NoAbiTag + tag -> AbiTag tag let comp = Compiler From 70576b37f70ed024c288dd4607b54f111976ded9 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 30 Jul 2025 14:03:35 +0800 Subject: [PATCH 058/122] fix(Cabal): disable logging of the response file It is duplicate information since we write the program invocation right after. --- Cabal/src/Distribution/Simple/Program/ResponseFile.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index 51b0d3b4131..eaf53ab5a5b 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -19,7 +19,7 @@ import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude () import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) +import Distribution.Simple.Utils (TempFileOptions, withTempFileEx) import Distribution.Utils.Path import Distribution.Verbosity @@ -34,7 +34,7 @@ withResponseFile -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a -withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = +withResponseFile _verbosity tmpFileOpts fileNameTemplate encoding arguments f = withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding @@ -44,9 +44,6 @@ withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = arguments hPutStr hf responseContents hClose hf - debug verbosity $ responseFileName ++ " contents: <<<" - debug verbosity responseContents - debug verbosity $ ">>> " ++ responseFileName f responseFileName -- Support a gcc-like response file syntax. Each separate From ffda13792678753cd87668c92f2fb262531d8e6e Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Tue, 26 Aug 2025 12:52:41 +0900 Subject: [PATCH 059/122] fixup! fix(Cabal): do not use GHC to configure LD --- Cabal/src/Distribution/Simple/GHC/Internal.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index ee6878228b2..1a6e878c226 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -120,13 +120,12 @@ configureToolchain verbosity _implInfo ghcProg ghcInfo db = do -- ghc to compile a _test_ c program. So we configure `gcc` -- first and then use `gcc` (the generic c compiler in cabal -- terminology) to compile the test program. - let db' = - flip addKnownProgram db $ - gccProgram - { programFindLocation = findProg gccProgramName extraGccPath - , programPostConf = configureGcc - } - (gccProg, db'') <- requireProgram verbosity gccProgram db' + let gccProgram' = gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + let db' = flip addKnownProgram db $ gccProgram' + (gccProg, db'') <- requireProgram verbosity gccProgram' db' return $ flip addKnownPrograms db'' $ [ gppProgram From acd159d745dbbe319f96689cd5fbfa405da84850 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 14 Nov 2025 14:48:20 +0800 Subject: [PATCH 060/122] fix: add platform-specific executable extension to build output paths MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit • Import exeExtension from Distribution.Simple.BuildPaths to determine correct executable naming by platform • Extract platform information from toolchain configuration during build orchestration • Apply platform-specific file extension (e.g., .exe on Windows) when constructing executable paths in build output • Refactor variable naming for clarity (exe → exeName) to distinguish filename base from full executable path • Normalize import formatting for consistency --- .../src/Distribution/Client/ProjectOrchestration.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 233347544e7..d5146f66e04 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -209,12 +209,12 @@ import Distribution.Utils.LogProgress import Distribution.Utils.NubList ( fromNubList ) -import Distribution.Utils.Path (makeSymbolicPath, ()) +import Distribution.Utils.Path (makeSymbolicPath, (), (<.>)) import Distribution.Verbosity #ifdef MIN_VERSION_unix -import System.Posix.Signals (sigKILL, sigSEGV) - +import System.Posix.Signals (sigKILL, sigSEGV) #endif +import Distribution.Simple.BuildPaths (exeExtension) -- | Tracks what command is being executed, because we need to hide this somewhere -- for cases that need special handling (usually for error reporting). @@ -545,9 +545,12 @@ installExecutables , pkg `Set.member` packagesDefinitelyUpToDate postBuildStatus , Just (InstallPlan.Configured elab) <- [InstallPlan.lookup elaboratedPlanOriginal pkg] , (ComponentTarget (CExeName cname) _subtarget, _targetSelectors) <- targets - , let exe = unUnqualComponentName cname - , let dir = binDirectoryFor distDirLayout elaboratedShared elab exe + , let platform = toolchainPlatform (getStage toolchains (elabStage elab)) + , let exeName = unUnqualComponentName cname + , let dir = binDirectoryFor distDirLayout elaboratedShared elab exeName + , let exe = exeName <.> exeExtension platform ] + toolchains = pkgConfigToolchains elaboratedShared -- Note that it is a deliberate design choice that the 'buildTargets' is -- not passed to phase 1, and the various bits of input config is not From 74ff1c3c849b7bab28636efc1c3093fd11ac2eb0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 10 Dec 2025 17:24:55 +0800 Subject: [PATCH 061/122] Fix compilation with TH This is a partial revert of f47840db585dd53d0229c515c786f4f667ea6fd5 GHC toggles -dyanmic-too for TH and now we're missing shared interface files. --- .../Distribution/Client/ProjectPlanning.hs | 32 ++++++++++++++----- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 11690ebfc8d..684ea49fa53 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -184,6 +184,7 @@ import Distribution.Simple.LocalBuildInfo , pkgComponents ) +import Distribution.Simple.BuildWay import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program import Distribution.Simple.Program.Db @@ -219,6 +220,8 @@ import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import qualified Distribution.Simple.Configure as Cabal +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.LocalBuildInfo as Cabal import qualified Distribution.Simple.Setup as Cabal @@ -2387,7 +2390,7 @@ elaborateInstallPlan elabBuildOptions = LBC.BuildOptions { withVanillaLib = perPkgOptionFlag srcpkgPackageId True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary + , withSharedLib = srcpkgPackageId `Set.member` pkgsUseSharedLibrary elabCompiler , withStaticLib = perPkgOptionFlag srcpkgPackageId False packageConfigStaticLib , withDynExe = perPkgOptionFlag srcpkgPackageId False packageConfigDynExe @@ -2561,15 +2564,13 @@ elaborateInstallPlan -- TODO: localPackages is a misnomer, it's all project packages -- here is where we decide which ones will be local! - pkgsUseSharedLibrary :: Set PackageId - pkgsUseSharedLibrary = - packagesWithLibDepsDownwardClosedProperty needsSharedLib + pkgsUseSharedLibrary :: Compiler -> Set PackageId + pkgsUseSharedLibrary compiler = + packagesWithLibDepsDownwardClosedProperty (needsSharedLib compiler) - needsSharedLib pkgid = + needsSharedLib compiler pkgid = fromMaybe - -- FIXME - -- compilerShouldUseSharedLibByDefault - False + compilerShouldUseSharedLibByDefault -- Case 1: --enable-shared or --disable-shared is passed explicitly, honour that. ( case pkgSharedLib of Just v -> Just v @@ -2592,6 +2593,21 @@ elaborateInstallPlan pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe pkgProf = perPkgOptionMaybe pkgid packageConfigProf + compilerShouldUseSharedLibByDefault = + case compilerFlavor compiler of + GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs + GHCJS -> GHCJS.isDynamic compiler + _ -> False + + canBuildWayLibs predicate = case predicate compiler of + Just can_build -> can_build + -- If we don't know for certain, just assume we can + -- which matches behaviour in previous cabal releases + Nothing -> True + + canBuildSharedLibs = canBuildWayLibs dynamicSupported + + pkgsUseProfilingLibrary :: Set PackageId pkgsUseProfilingLibrary = packagesWithLibDepsDownwardClosedProperty needsProfilingLib From 37aba60257919857365143cdf24713f2539ffe0f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 8 Dec 2025 17:31:10 +0800 Subject: [PATCH 062/122] CI: build portable binaries This reduces linux binary flavors to two: - glibc (dynamic) - musl (fully static) 'gmp' and 'zlib' are always statically linked. --- .github/scripts/{build.bash => build.sh} | 0 .github/scripts/{test.bash => test.sh} | 2 +- .github/workflows/reusable-release.yml | 232 ++++++++++------------- 3 files changed, 98 insertions(+), 136 deletions(-) rename .github/scripts/{build.bash => build.sh} (100%) mode change 100644 => 100755 rename .github/scripts/{test.bash => test.sh} (89%) mode change 100644 => 100755 diff --git a/.github/scripts/build.bash b/.github/scripts/build.sh old mode 100644 new mode 100755 similarity index 100% rename from .github/scripts/build.bash rename to .github/scripts/build.sh diff --git a/.github/scripts/test.bash b/.github/scripts/test.sh old mode 100644 new mode 100755 similarity index 89% rename from .github/scripts/test.bash rename to .github/scripts/test.sh index 9c83dbb32d7..997d0375eac --- a/.github/scripts/test.bash +++ b/.github/scripts/test.sh @@ -25,7 +25,7 @@ cabal update # TODO: we want to avoid building here... we should just # be using the previously built 'cabal-tests' binary # Also see https://github.com/haskell/cabal/issues/11048 -cabal run -w "ghc-${GHC_TEST_VERSION}" ${ADD_CABAL_ARGS} cabal-testsuite:cabal-tests -- \ +cabal run ${ADD_CABAL_ARGS} cabal-testsuite:cabal-tests -- \ --with-cabal "$(pwd)/out/cabal" \ --intree-cabal-lib "$(pwd)" \ --test-tmp "$(pwd)/testdb" \ diff --git a/.github/workflows/reusable-release.yml b/.github/workflows/reusable-release.yml index 9c2e738ab9c..8a40c1ad8ba 100644 --- a/.github/workflows/reusable-release.yml +++ b/.github/workflows/reusable-release.yml @@ -8,12 +8,15 @@ on: type: string ghc: type: string - default: 9.10.2 + default: 9.6.7 # speed up installation by skipping docs # starting with GHC 9.10.x, we also need to pass the 'install_extra' target ghc_targets: type: string - default: "install_bin install_lib update_package_db install_extra" + default: "install_bin install_lib update_package_db" + gmp: + type: string + default: 6.3.0 cabal: type: string default: 3.14.2.0 @@ -24,12 +27,9 @@ on: env: GHC_VERSION: ${{ inputs.ghc }} GHC_TARGETS: ${{ inputs.ghc_targets }} - # This shouldn't be necessary, but cabal developers - # want to build with 9.10.2, which causes test failures - # when used as runtime GHC version as well. - GHC_TEST_VERSION: 9.6.7 - GHC_TEST_TARGETS: "install_bin install_lib update_package_db" CABAL_VERSION: ${{ inputs.cabal }} + GMP_VERSION: ${{ inputs.gmp }} + GMP_URL: "https://ftp.gnu.org/gnu/gmp/" BOOTSTRAP_HASKELL_NONINTERACTIVE: 1 BOOTSTRAP_HASKELL_MINIMAL: 1 DEBIAN_FRONTEND: noninteractive @@ -70,89 +70,19 @@ jobs: fail-fast: false matrix: branch: ${{ fromJSON(inputs.branches) }} - platform: [ { image: "debian:11" - , installCmd: "apt-get update && apt-get install -y" - , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" - , DISTRO: "Debian" - , ARTIFACT: "x86_64-linux-deb11" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "debian:12" - , installCmd: "apt-get update && apt-get install -y" - , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" - , DISTRO: "Debian" - , ARTIFACT: "x86_64-linux-deb12" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "ubuntu:20.04" - , installCmd: "apt-get update && apt-get install -y" - , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" - , DISTRO: "Ubuntu" - , ARTIFACT: "x86_64-linux-ubuntu20.04" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "ubuntu:22.04" - , installCmd: "apt-get update && apt-get install -y" - , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" - , DISTRO: "Ubuntu" - , ARTIFACT: "x86_64-linux-ubuntu22.04" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "ubuntu:24.04" - , installCmd: "apt-get update && apt-get install -y" - , toolRequirements: "${{ needs.tool-output.outputs.apt_tools_ncurses6 }}" - , DISTRO: "Ubuntu" - , ARTIFACT: "x86_64-linux-ubuntu24.04" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "fedora:33" - , installCmd: "dnf install -y" - , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" - , DISTRO: "Fedora" - , ARTIFACT: "x86_64-linux-fedora33" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "fedora:36" - , installCmd: "dnf install -y" - , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" - , DISTRO: "Fedora" - , ARTIFACT: "x86_64-linux-fedora36" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "fedora:38" - , installCmd: "dnf install -y" - , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" - , DISTRO: "Fedora" - , ARTIFACT: "x86_64-linux-fedora38" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "rockylinux:8" + platform: [ { image: "rockylinux:8" , installCmd: "yum -y install epel-release && yum install -y --allowerasing" , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-rocky8" + , DISTRO: "Rockylinux" + , ARTIFACT: "x86_64-linux-glibc" , ADD_CABAL_ARGS: "--enable-split-sections" }, { image: "alpine:3.20" , installCmd: "apk update && apk add" , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-unknown" + , DISTRO: "Alpine" + , ARTIFACT: "x86_64-linux-musl-static" , ADD_CABAL_ARGS: "--enable-split-sections --enable-executable-static" - }, - { image: "alpine:3.12" - , installCmd: "apk update && apk add" - , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-alpine312" - , ADD_CABAL_ARGS: "--enable-split-sections" - }, - { image: "alpine:3.20" - , installCmd: "apk update && apk add" - , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-alpine320" - , ADD_CABAL_ARGS: "--enable-split-sections" } ] container: @@ -172,15 +102,35 @@ jobs: with: ref: ${{ matrix.branch }} - - name: Run build + - name: install GMP + if: matrix.platform.DISTRO == 'Rockylinux' run: | - bash .github/scripts/build.bash + set -eux + curl -O -L ${{ env.GMP_URL }}/gmp-${{ env.GMP_VERSION }}.tar.xz + tar xf gmp-${{ env.GMP_VERSION }}.tar.xz + cd gmp-${{ env.GMP_VERSION }} + CFLAGS="-fPIC" ./configure --prefix=$HOME/.local/ --disable-shared --host=x86_64-pc-linux-gnu --build=x86_64-pc-linux-gnu + make install + cd .. + echo "extra-lib-dirs: $HOME/.local/lib/" >> cabal.release.project.local + + - name: Run build + run: | + bash .github/scripts/build.sh env: ARTIFACT: ${{ matrix.platform.ARTIFACT }} DISTRO: ${{ matrix.platform.DISTRO }} ADD_CABAL_ARGS: ${{ matrix.platform.ADD_CABAL_ARGS }} + - name: check linking + if: matrix.platform.DISTRO == 'Rockylinux' + run: | + cd out + tar xf *.${TARBALL_EXT} + ldd cabal | grep --quiet gmp && exit 1 + rm cabal plan.json + - if: always() name: Upload artifact uses: ./.github/actions/upload @@ -214,7 +164,7 @@ jobs: - name: Run build (32 bit linux) uses: docker://i386/alpine:3.20 with: - args: sh -c "apk update && apk add curl bash git ${{ needs.tool-output.outputs.apk_tools }} && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.bash" + args: sh -c "apk update && apk add curl bash git ${{ needs.tool-output.outputs.apk_tools }} && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.sh" - if: always() name: Upload artifact @@ -240,11 +190,11 @@ jobs: branch: ${{ fromJSON(inputs.branches) }} platform: [ { ARCH: "ARM64" , DISTRO: "Debian" - , ARTIFACT: "aarch64-linux-deb11" + , ARTIFACT: "aarch64-linux-deb10" }, { ARCH: "ARM64" , DISTRO: "Alpine" - , ARTIFACT: "aarch64-linux-unknown" + , ARTIFACT: "aarch64-linux-alpine" } ] steps: @@ -256,7 +206,7 @@ jobs: uses: docker://arm64v8/debian:11 name: Run build (aarch64 linux) with: - args: sh -c "apt-get update && apt-get install -y curl bash git ${{ needs.tool-output.outputs.apt_tools }} && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.bash" + args: sh -c "apt-get update && apt-get install -y curl bash git ${{ needs.tool-output.outputs.apt_tools }} && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.sh" env: ARTIFACT: ${{ matrix.platform.ARTIFACT }} DISTRO: ${{ matrix.platform.DISTRO }} @@ -266,7 +216,7 @@ jobs: uses: docker://arm64v8/alpine:3.20 name: Run build (aarch64 linux alpine) with: - args: sh -c "apk update && apk add curl bash git ${{ needs.tool-output.outputs.apk_tools }} && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.bash" + args: sh -c "apk update && apk add curl bash git ${{ needs.tool-output.outputs.apk_tools }} && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.sh" env: ARTIFACT: ${{ matrix.platform.ARTIFACT }} DISTRO: ${{ matrix.platform.DISTRO }} @@ -308,7 +258,8 @@ jobs: - name: Run build run: | - bash .github/scripts/build.bash + brew install coreutils tree + bash .github/scripts/build.sh - if: always() name: Upload artifact @@ -348,7 +299,8 @@ jobs: - name: Run build run: | - bash .github/scripts/build.bash + brew install git coreutils autoconf automake tree + bash .github/scripts/build.sh - if: always() name: Upload artifact @@ -383,7 +335,6 @@ jobs: - name: install windows deps shell: pwsh run: | - # https://www.msys2.org/docs/updating/ C:\msys64\usr\bin\bash -lc "pacman --disable-download-timeout --noconfirm -Syuu" C:\msys64\usr\bin\bash -lc "pacman --disable-download-timeout --noconfirm -Syuu" C:\msys64\usr\bin\bash -lc "pacman --disable-download-timeout --noconfirm -S make mingw-w64-x86_64-clang curl autoconf mingw-w64-x86_64-pkgconf ca-certificates base-devel gettext autoconf make libtool automake python p7zip patch unzip zip git" @@ -399,7 +350,7 @@ jobs: $env:CHERE_INVOKING = 1 $env:MSYS2_PATH_TYPE = "inherit" $ErrorActionPreference = "Stop" - C:\msys64\usr\bin\bash -lc "bash .github/scripts/build.bash" + C:\msys64\usr\bin\bash -lc "bash .github/scripts/build.sh" shell: pwsh - if: always() @@ -441,10 +392,10 @@ jobs: - name: Run build run: | sudo sed -i.bak -e 's/quarterly/latest/' /etc/pkg/FreeBSD.conf - sudo pkg install -y curl gcc gmp gmake ncurses perl5 pkgconf libffi libiconv git bash misc/compat10x misc/compat11x misc/compat12x + sudo pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake llvm14 libiconv sudo tzsetup Etc/GMT sudo adjkerntz -a - bash .github/scripts/build.bash + bash .github/scripts/build.sh - if: always() name: Upload artifact @@ -473,73 +424,91 @@ jobs: , installCmd: "apt-get update && apt-get install -y" , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" , DISTRO: "Debian" - , ARTIFACT: "x86_64-linux-deb11" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "debian:12" , installCmd: "apt-get update && apt-get install -y" , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" , DISTRO: "Debian" - , ARTIFACT: "x86_64-linux-deb12" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "ubuntu:20.04" , installCmd: "apt-get update && apt-get install -y" , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" , DISTRO: "Ubuntu" - , ARTIFACT: "x86_64-linux-ubuntu20.04" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "ubuntu:22.04" , installCmd: "apt-get update && apt-get install -y" , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" , DISTRO: "Ubuntu" - , ARTIFACT: "x86_64-linux-ubuntu22.04" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "ubuntu:24.04" , installCmd: "apt-get update && apt-get install -y" , toolRequirements: "${{ needs.tool-output.outputs.apt_tools_ncurses6 }}" , DISTRO: "Ubuntu" - , ARTIFACT: "x86_64-linux-ubuntu24.04" + , ARTIFACT: "x86_64-linux-glibc" + }, + { image: "linuxmintd/mint20.3-amd64" + , installCmd: "apt-get update && apt-get install -y" + , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" + , DISTRO: "Mint" + , ARTIFACT: "x86_64-linux-glibc" + }, + { image: "linuxmintd/mint21.3-amd64" + , installCmd: "apt-get update && apt-get install -y" + , toolRequirements: "${{ needs.tool-output.outputs.apt_tools }}" + , DISTRO: "Mint" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "fedora:33" , installCmd: "dnf install -y" , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" , DISTRO: "Fedora" - , ARTIFACT: "x86_64-linux-fedora33" + , ARTIFACT: "x86_64-linux-glibc" }, - { image: "fedora:36" + { image: "fedora:37" , installCmd: "dnf install -y" , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" , DISTRO: "Fedora" - , ARTIFACT: "x86_64-linux-fedora36" + , ARTIFACT: "x86_64-linux-glibc" }, - { image: "fedora:38" + { image: "fedora:42" , installCmd: "dnf install -y" , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" , DISTRO: "Fedora" - , ARTIFACT: "x86_64-linux-fedora38" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "rockylinux:8" , installCmd: "yum -y install epel-release && yum install -y --allowerasing" , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-rocky8" + , DISTRO: "Rockylinux" + , ARTIFACT: "x86_64-linux-glibc" + }, + { image: "rockylinux:9" + , installCmd: "yum -y install epel-release && yum install -y --allowerasing" + , toolRequirements: "${{ needs.tool-output.outputs.rpm_tools }}" + , DISTRO: "Rockylinux" + , ARTIFACT: "x86_64-linux-glibc" }, { image: "alpine:3.20" , installCmd: "apk update && apk add" , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-unknown" + , DISTRO: "Alpine" + , ARTIFACT: "x86_64-linux-musl-static" }, { image: "alpine:3.12" , installCmd: "apk update && apk add" , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" - , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-alpine312" + , DISTRO: "Alpine" + , ARTIFACT: "x86_64-linux-musl-static" }, - { image: "alpine:3.20" - , installCmd: "apk update && apk add" - , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" + { image: "ghcr.io/void-linux/void-glibc:latest" + , installCmd: "xbps-install -Suy xbps && xbps-install -Sy" + , toolRequirements: "${{ needs.tool-output.outputs.xbps_tools }}" , DISTRO: "Unknown" - , ARTIFACT: "x86_64-linux-alpine320" + , ARTIFACT: "x86_64-linux-musl-static" } ] container: @@ -554,9 +523,6 @@ jobs: with: ref: ${{ matrix.branch }} - # Test suite uses 'git' to find the test files. That appears - # to cause problems in CI. A similar hack is employed in the validate - # pipeline. - name: git clone fix run: git config --system --add safe.directory $GITHUB_WORKSPACE @@ -572,13 +538,12 @@ jobs: - name: Run test run: | - bash .github/scripts/test.bash + bash .github/scripts/test.sh env: ARTIFACT: ${{ matrix.platform.ARTIFACT }} DISTRO: ${{ matrix.platform.DISTRO }} ADD_CABAL_ARGS: ${{ matrix.platform.ADD_CABAL_ARGS }} -# TODO: https://github.com/haskell/cabal/issues/11049 # test-linux-32bit: # name: Test linux binaries (32bit) # runs-on: ubuntu-latest @@ -607,7 +572,7 @@ jobs: # - name: Run build (32 bit linux) # uses: docker://i386/alpine:3.20 # with: -# args: sh -c "apk update && apk add curl bash git ${{ needs.tool-output.outputs.apk_tools }} groff && git config --system --add safe.directory $GITHUB_WORKSPACE && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.bash" +# args: sh -c "apk update && apk add curl bash git ${{ needs.tool-output.outputs.apk_tools }} groff && git config --system --add safe.directory $GITHUB_WORKSPACE && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/build.sh" test-arm: name: Test ARM binary @@ -624,11 +589,11 @@ jobs: branch: ${{ fromJSON(inputs.branches) }} platform: [ { ARCH: "ARM64" , DISTRO: "Debian" - , ARTIFACT: "aarch64-linux-deb11" + , ARTIFACT: "aarch64-linux-deb10" }, { ARCH: "ARM64" , DISTRO: "Alpine" - , ARTIFACT: "aarch64-linux-unknown" + , ARTIFACT: "aarch64-linux-alpine" } ] steps: @@ -645,7 +610,7 @@ jobs: uses: docker://arm64v8/debian:11 name: Run build (aarch64 linux) with: - args: sh -c "apt-get update && apt-get install -y curl bash git groff-base ${{ needs.tool-output.outputs.apt_tools }} && git config --system --add safe.directory $GITHUB_WORKSPACE && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/test.bash" + args: sh -c "apt-get update && apt-get install -y curl bash git groff-base ${{ needs.tool-output.outputs.apt_tools }} && git config --system --add safe.directory $GITHUB_WORKSPACE && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/test.sh" env: ARTIFACT: ${{ matrix.platform.ARTIFACT }} DISTRO: ${{ matrix.platform.DISTRO }} @@ -654,7 +619,7 @@ jobs: uses: docker://arm64v8/alpine:3.20 name: Run build (aarch64 linux alpine) with: - args: sh -c "apk update && apk add curl bash git groff ${{ needs.tool-output.outputs.apk_tools }} && git config --system --add safe.directory $GITHUB_WORKSPACE && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/test.bash" + args: sh -c "apk update && apk add curl bash git groff ${{ needs.tool-output.outputs.apk_tools }} && git config --system --add safe.directory $GITHUB_WORKSPACE && export PATH=$HOME/.ghcup/bin:$PATH && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh && ghcup install cabal ${{ env.CABAL_VERSION }} && bash .github/scripts/test.sh" env: ARTIFACT: ${{ matrix.platform.ARTIFACT }} DISTRO: ${{ matrix.platform.DISTRO }} @@ -692,11 +657,8 @@ jobs: - name: Run test run: | - # cabal-testsuite/PackageTests/Configure/cabal.test.hs needs it - # and it doesn't appear pre-installed here - brew install autoconf automake - - bash .github/scripts/test.bash + brew install git coreutils autoconf automake tree + bash .github/scripts/test.sh test-mac-aarch64: name: Test binary (Mac aarch64) @@ -733,7 +695,8 @@ jobs: - name: Run test run: | - bash .github/scripts/test.bash + brew install git coreutils autoconf automake tree + bash .github/scripts/test.sh test-win: name: Test binary (Win) @@ -780,7 +743,7 @@ jobs: $env:CHERE_INVOKING = 1 $env:MSYS2_PATH_TYPE = "inherit" $ErrorActionPreference = "Stop" - C:\msys64\usr\bin\bash -lc "bash .github/scripts/test.bash" + C:\msys64\usr\bin\bash -lc "bash .github/scripts/test.sh" shell: pwsh test-freebsd-x86_64: @@ -819,8 +782,7 @@ jobs: - name: Run test run: | sudo sed -i.bak -e 's/quarterly/latest/' /etc/pkg/FreeBSD.conf - sudo pkg install -y curl gcc gmp gmake ncurses perl5 pkgconf libffi libiconv git bash misc/compat10x misc/compat11x misc/compat12x groff autoconf automake + sudo pkg install -y ghc hs-cabal-install git bash misc/compat10x misc/compat11x misc/compat12x gmake llvm14 libiconv groff autoconf automake sudo tzsetup Etc/GMT sudo adjkerntz -a - bash .github/scripts/test.bash - + bash .github/scripts/test.sh From 26579bba2bdd61448189cab40cd2fab564ae1477 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 10 Dec 2025 17:40:25 +0800 Subject: [PATCH 063/122] Disable tests in release CI --- .github/workflows/release.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 1a7343ba760..2333df65b1a 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -51,6 +51,7 @@ jobs: uses: ./.github/workflows/reusable-release.yml with: branches: '["${{ github.ref }}"]' + test: false release: name: release From 38ac7ce2d848c4f1c97118288224ff0e2cc6cb11 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 10 Dec 2025 21:22:56 +0800 Subject: [PATCH 064/122] Bump mac x86_64 --- .github/workflows/reusable-release.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/reusable-release.yml b/.github/workflows/reusable-release.yml index 8a40c1ad8ba..d8f88292e21 100644 --- a/.github/workflows/reusable-release.yml +++ b/.github/workflows/reusable-release.yml @@ -234,7 +234,7 @@ jobs: build-mac-x86_64: name: Build binary (Mac x86_64) - runs-on: macOS-13 + runs-on: macOS-15-intel env: MACOSX_DEPLOYMENT_TARGET: 10.13 ADD_CABAL_ARGS: "" @@ -626,7 +626,7 @@ jobs: test-mac-x86_64: name: Test binary (Mac x86_64) - runs-on: macOS-13 + runs-on: macOS-15-intel needs: ["build-mac-x86_64"] if: ${{ inputs.test }} env: From 601bd23403657353f2270c87eff6b0d56af78982 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 10 Dec 2025 22:35:45 +0800 Subject: [PATCH 065/122] Fix release creation --- .github/workflows/release.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 2333df65b1a..acc7cbf46b9 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -15,6 +15,7 @@ on: permissions: pull-requests: read + contents: write env: BUILD_LABEL: "run release build" From 82d4c8f625d598f2581871b901e02a198d88edf6 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 11 Dec 2025 14:58:38 +0800 Subject: [PATCH 066/122] Fix stdout tidiness --- cabal-install/src/Distribution/Client/ProjectPlanning.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 684ea49fa53..37fc870947d 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -804,9 +804,9 @@ rebuildInstallPlan phaseConfigureToolchains projectConfig = do toolchains <- configureToolchains verbosity distDirLayout projectConfig liftIO $ do - putStrLn "Toolchains:" + notice verbosity "Toolchains:" for_ stages $ \s -> - print $ Disp.hsep [Disp.text "-" <+> pretty s <+> Disp.text "compiler" <+> pretty (compilerId (toolchainCompiler (getStage toolchains s)))] + notice verbosity $ show $ Disp.hsep [Disp.text "-" <+> pretty s <+> Disp.text "compiler" <+> pretty (compilerId (toolchainCompiler (getStage toolchains s)))] return toolchains -- Configuring other programs. From fdbfbbee8d0b9d50654f742313cacbefa6ad400f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 11 Dec 2025 14:59:57 +0800 Subject: [PATCH 067/122] Bump to 3.17.0.1 --- Cabal/Cabal.cabal | 2 +- cabal-install/cabal-install.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 8ec6542bd47..8b26b829e37 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -1,6 +1,6 @@ cabal-version: 3.6 name: Cabal -version: 3.17.0.0 +version: 3.17.0.1 copyright: 2003-2025, Cabal Development Team (see AUTHORS file) license: BSD-3-Clause license-file: LICENSE diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index e21b063050f..3dddb14bb50 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -1,7 +1,7 @@ Cabal-Version: 3.6 Name: cabal-install -Version: 3.17.0.0 +Version: 3.17.0.1 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing From eb375e895f6f4bfed2e4bcc1a70823e4499437ca Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 12:02:04 +0800 Subject: [PATCH 068/122] refactor(cabal-install): add more HasCallstack --- .../src/Distribution/Client/ProjectPlanning.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 37fc870947d..4d17c8821ae 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -364,7 +364,8 @@ sanityCheckElaboratedPackage -- | Return the up-to-date project config and information about the local -- packages within the project. rebuildProjectConfig - :: Verbosity + :: HasCallStack + => Verbosity -> HttpTransport -> DistDirLayout -> ProjectConfig @@ -709,7 +710,8 @@ See #9840 for more information about the problems surrounding the lossy -- dependencies of executables and setup scripts. -- rebuildInstallPlan - :: Verbosity + :: HasCallStack + => Verbosity -> DistDirLayout -> CabalDirLayout -> ProjectConfig @@ -961,7 +963,8 @@ rebuildInstallPlan -- version of the plan has the final nix-style hashed ids. -- phaseElaboratePlan - :: ProjectConfig + :: HasCallStack + => ProjectConfig -> Staged Toolchain -> Staged (Maybe PkgConfigDb) -> SolverInstallPlan @@ -1628,7 +1631,8 @@ planPackages -- In theory should be able to make an elaborated install plan with a policy -- matching that of the classic @cabal install --user@ or @--global@ elaborateInstallPlan - :: Verbosity + :: HasCallStack + => Verbosity -> Staged Toolchain -> Staged (Maybe PkgConfigDb) -> DistDirLayout @@ -1681,7 +1685,7 @@ elaborateInstallPlan ) f _ = Nothing - elaboratedInstallPlan :: LogProgress ElaboratedInstallPlan + elaboratedInstallPlan :: HasCallStack => LogProgress ElaboratedInstallPlan elaboratedInstallPlan = flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg -> case planpkg of From 9e7b9a9221f20591d4e9c8b7449a5adcbd41f896 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 7 Aug 2025 12:02:04 +0800 Subject: [PATCH 069/122] refactor(Cabal): add a stack trace to dieProgress --- Cabal/src/Distribution/Utils/LogProgress.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 8cc2ae527e9..b5d74b31b54 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -19,6 +19,7 @@ import Prelude () import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity +import GHC.Stack (HasCallStack, callStack, prettyCallStack) import Text.PrettyPrint type CtxMsg = Doc @@ -88,10 +89,14 @@ infoProgress s = LogProgress $ \env -> stepProgress s -- | Fail the computation with an error message. -dieProgress :: Doc -> LogProgress a +dieProgress :: HasCallStack => Doc -> LogProgress a dieProgress s = LogProgress $ \env -> failProgress $ - hang (text "Error:") 4 (formatMsg (le_context env) s) + hang (text "Error:") 4 $ + vcat + [ formatMsg (le_context env) s + , text (prettyCallStack callStack) + ] -- | Format a message with context. (Something simple for now.) formatMsg :: [CtxMsg] -> Doc -> Doc From f0a82235b3f880a9e1f081bda193c33125eaa1f7 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 5 Aug 2025 10:30:30 +0800 Subject: [PATCH 070/122] debug: log why not registering --- .../Distribution/Client/ProjectBuilding/UnpackedPackage.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index c141996fa77..63270d85448 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -631,9 +631,11 @@ buildInplaceUnpackedPackage BuildStatusBuild (Just _) _ -> info verbosity "whenReRegister: previously registered" -- There is nothing to register - _ + BuildStatusBuild Nothing _ -> + info verbosity "whenReRegister: nothing to register, we know it!" + BuildStatusConfigure _reason | null (elabBuildTargets pkg) -> - info verbosity "whenReRegister: nothing to register" + info verbosity "whenReRegister: nothing to register, it seems ..." | otherwise -> action -------------------------------------------------------------------------------- From 7823e302f8220bfa84f8f6b2439748bd1d6c6056 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 25 Sep 2025 17:49:05 +0800 Subject: [PATCH 071/122] Fix statically linking executables wrt #11224 By supporting GHCs '-static-external' --- .../src/Distribution/Simple/GHC/Build/Link.hs | 31 ++++++++++--------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index bba36bb3809..7dbdea229d0 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -120,17 +120,17 @@ linkOrLoadComponent -- for foreign libs in the three cases where we use `withFullyStaticExe` below? linkerOpts rpaths = mempty - { ghcOptLinkOptions = - PD.ldOptions bi - ++ [ "-static" - | withFullyStaticExe lbi - ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe - [] - programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)) + { ghcOptExtraDefault = + [ "-static-external" + | withFullyStaticExe lbi + ] + , ghcOptLinkOptions = + -- Pass extra `ld-options` given + -- through to GHC's linker. + maybe + [] + programOverrideArgs + (lookupProgram ldProgram (withPrograms lbi)) , ghcOptLinkLibs = if withFullyStaticExe lbi then extraLibsStatic bi @@ -226,7 +226,7 @@ linkOrLoadComponent CLib lib -> do let libWays = wantedLibWays isIndef rpaths <- get_rpaths (Set.fromList libWays) - linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths libWays + linkLibrary buildTargetDir cleanedExtraLibDirs cleanedExtraLibDirsStatic pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths libWays CFLib flib -> do let flib_way = wantedFLibWay (withDynFLib flib) rpaths <- get_rpaths (Set.singleton flib_way) @@ -241,6 +241,8 @@ linkLibrary -- ^ The library target build directory -> [SymbolicPath Pkg (Dir Lib)] -- ^ The list of extra lib dirs that exist (aka "cleaned") + -> [SymbolicPath Pkg (Dir Lib)] + -- ^ The list of extra static lib dirs that exist (aka "cleaned") -> PackageDescription -- ^ The package description containing this library -> Verbosity @@ -256,7 +258,7 @@ linkLibrary -> [BuildWay] -- ^ Wanted build ways and corresponding build options -> IO () -linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do +linkLibrary buildTargetDir cleanedExtraLibDirs cleanedExtraLibDirsStatic pkg_descr verbosity runGhcProg lib lbi clbi extraSources rpaths wantedWays = do let common = configCommonFlags $ configFlags lbi mbWorkDir = flagToMaybe $ setupWorkingDir common @@ -432,8 +434,7 @@ linkLibrary buildTargetDir cleanedExtraLibDirs pkg_descr verbosity runGhcProg li , ghcOptInputFiles = toNubListR $ map coerceSymbolicPath staticObjectFiles , ghcOptOutputFile = toFlag staticLibFilePath , ghcOptLinkLibs = extraLibs libBi - , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead? - ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs + , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirsStatic } staticObjectFiles <- getObjFiles StaticWay From d923cafc7af3e51c6d8e44f2c5d8bae1f4b52c5e Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 1 Sep 2022 11:39:46 +0200 Subject: [PATCH 072/122] refactor: remove support for UHC --- Cabal-syntax/src/Distribution/Compiler.hs | 3 +- .../src/Language/Haskell/Extension.hs | 2 +- Cabal/Cabal.cabal | 1 - Cabal/src/Distribution/Simple/Build.hs | 4 - Cabal/src/Distribution/Simple/Configure.hs | 4 - Cabal/src/Distribution/Simple/Install.hs | 3 - Cabal/src/Distribution/Simple/InstallDirs.hs | 9 +- Cabal/src/Distribution/Simple/Program.hs | 1 - .../Distribution/Simple/Program/Builtin.hs | 8 - Cabal/src/Distribution/Simple/Register.hs | 23 +- Cabal/src/Distribution/Simple/Setup/Config.hs | 1 - Cabal/src/Distribution/Simple/UHC.hs | 377 ------------------ cabal-install/tests/IntegrationTests2.hs | 2 - .../IntegrationTests2/nix-config/nix-false | 4 +- .../IntegrationTests2/nix-config/nix-true | 4 +- doc/cabal-interface-stability.rst | 2 +- doc/cabal-package-description-file.rst | 2 +- doc/cabal-project-description-file.rst | 2 +- doc/config.rst | 2 - doc/setup-commands.rst | 1 - test/IntegrationTests2/config/default-config | 2 - .../nix-config/default-config | 2 - tests/IntegrationTests2/config/default-config | 2 - .../nix-config/default-config | 2 - 24 files changed, 16 insertions(+), 447 deletions(-) delete mode 100644 Cabal/src/Distribution/Simple/UHC.hs diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 5e0f9e84d77..406cbcb55f0 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -71,7 +71,6 @@ data CompilerFlavor | Helium | JHC | LHC - | UHC | Eta | -- | @since 3.12.1.0 -- MicroHS, see https://github.com/augustss/MicroHs @@ -85,7 +84,7 @@ instance NFData CompilerFlavor where rnf = genericRnf knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC, Eta, MHS] + [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, Eta, MHS] instance Pretty CompilerFlavor where pretty (OtherCompiler name) = Disp.text name diff --git a/Cabal-syntax/src/Language/Haskell/Extension.hs b/Cabal-syntax/src/Language/Haskell/Extension.hs index 26cd45edac8..7b33a399356 100644 --- a/Cabal-syntax/src/Language/Haskell/Extension.hs +++ b/Cabal-syntax/src/Language/Haskell/Extension.hs @@ -98,7 +98,7 @@ classifyLanguage = \str -> case lookup str langTable of -- * also add it to the Distribution.Simple.X.compilerExtensions lists --- (where X is each compiler: GHC, UHC) +-- (where X is each compiler: GHC, etc) -- -- | This represents language extensions beyond a base 'Language' definition diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 8b26b829e37..fb7ffedebb0 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -159,7 +159,6 @@ library Distribution.Simple.Test.ExeV10 Distribution.Simple.Test.LibV09 Distribution.Simple.Test.Log - Distribution.Simple.UHC Distribution.Simple.UserHooks Distribution.Simple.SetupHooks.Errors Distribution.Simple.SetupHooks.Internal diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 825f3e1425d..413002adcab 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -73,7 +73,6 @@ import Distribution.Package import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.PackageIndex as Index -import qualified Distribution.Simple.UHC as UHC import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule) @@ -314,7 +313,6 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do flavorToProgram :: CompilerFlavor -> Maybe Program flavorToProgram GHC = Just ghcProgram flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram flavorToProgram JHC = Just jhcProgram flavorToProgram _ = Nothing @@ -973,7 +971,6 @@ buildLib flags numJobs pkg_descr lbi lib clbi = in case compilerFlavor (compiler lbi) of GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi - UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler -- | Build a foreign library @@ -1005,7 +1002,6 @@ buildExe verbosity numJobs pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler replLib diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 86f17478720..26874a6da2c 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -120,7 +120,6 @@ import Distribution.Version import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC import Control.Exception ( try @@ -2071,7 +2070,6 @@ getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do case compilerFlavor comp of GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb - UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb flv -> dieWithException verbosity $ HowToFindInstalledPackages flv where @@ -2504,7 +2502,6 @@ configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do (comp, maybePlatform, programDb) <- case hcFlavor of GHC -> GHC.configure verbosity hcPath hcPkg progdb GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath progdb _ -> dieWithException verbosity UnknownCompilerException return (comp, fromMaybe buildPlatform maybePlatform, programDb) @@ -2524,7 +2521,6 @@ configCompiler mbFlavor hcPath progdb verbosity = do case hcFlavor of GHC -> GHC.configureCompiler verbosity hcPath progdb GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb - UHC -> UHC.configure verbosity hcPath progdb _ -> dieWithException verbosity UnknownCompilerException return (comp, fromMaybe buildPlatform maybePlatform, programDb) diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs index 50cef3e099c..36452b57c56 100644 --- a/Cabal/src/Distribution/Simple/Install.hs +++ b/Cabal/src/Distribution/Simple/Install.hs @@ -75,7 +75,6 @@ import Distribution.Simple.Errors import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import Distribution.Simple.Setup.Common -import qualified Distribution.Simple.UHC as UHC import System.Directory ( doesDirectoryExist @@ -247,7 +246,6 @@ copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do case compilerFlavor (compiler lbi) of GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do @@ -295,7 +293,6 @@ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do case compilerFlavor (compiler lbi) of GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - UHC -> return () _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index 818b9273bfd..274e6466834 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -221,13 +221,8 @@ defaultInstallDirs' False comp userInstall _hasLibs = do { prefix = installPrefix , bindir = "$prefix" "bin" , libdir = installLibDir - , libsubdir = case comp of - UHC -> "$pkgid" - _other -> "$abi" "$libname" - , dynlibdir = - "$libdir" case comp of - UHC -> "$pkgid" - _other -> "$abi" + , libsubdir = "$abi" "$libname" + , dynlibdir = "$abi" , libexecsubdir = "$abi" "$pkgid" , flibdir = "$libdir" , libexecdir = case buildOS of diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index b84dd8d505f..c5c410a8589 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -112,7 +112,6 @@ module Distribution.Simple.Program , ghcjsProgram , ghcjsPkgProgram , jhcProgram - , uhcProgram , gccProgram , gppProgram , arProgram diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs index 8a42aa661de..e58a8348ea1 100644 --- a/Cabal/src/Distribution/Simple/Program/Builtin.hs +++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs @@ -21,7 +21,6 @@ module Distribution.Simple.Program.Builtin , ghcjsProgram , ghcjsPkgProgram , jhcProgram - , uhcProgram , gccProgram , gppProgram , arProgram @@ -72,7 +71,6 @@ builtinPrograms = , ghcjsProgram , ghcjsPkgProgram , jhcProgram - , uhcProgram , hpcProgram , -- preprocessors hscolourProgram @@ -187,12 +185,6 @@ jhcProgram = _ -> "" } -uhcProgram :: Program -uhcProgram = - (simpleProgram "uhc") - { programFindVersion = findProgramVersion "--version-dotted" id - } - hpcProgram :: Program hpcProgram = (simpleProgram "hpc") diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index 48962782728..d02112171a5 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -60,7 +60,6 @@ import Distribution.Simple.LocalBuildInfo import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.PackageIndex as Index -import qualified Distribution.Simple.UHC as UHC import Distribution.Backpack.DescribeUnitId import Distribution.Compat.Graph (IsNode (nodeKey)) @@ -241,15 +240,12 @@ registerAll pkg lbi regFlags ipis = (IPI.showInstalledPackageInfo installedPkgInfo) writeRegisterScript = - case compilerFlavor (compiler lbi) of - UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> - withHcPkg - verbosity - "Registration scripts are not implemented for this compiler" - (compiler lbi) - (withPrograms lbi) - (writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs) + withHcPkg + verbosity + "Registration scripts are not implemented for this compiler" + (compiler lbi) + (withPrograms lbi) + (writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs) generateRegistrationInfo :: Verbosity @@ -369,7 +365,6 @@ createPackageDB verbosity comp progdb preferCompat dbPath = case compilerFlavor comp of GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath - UHC -> return () _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool @@ -437,7 +432,6 @@ registerPackage verbosity comp progdb mbWorkDir packageDbs installedPkgInfo regi _ | HcPkg.registerMultiInstance registerOptions -> dieWithException verbosity RegisMultiplePkgNotSupported - UHC -> UHC.registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo _ -> dieWithException verbosity RegisteringNotImplemented writeHcPkgRegisterScript @@ -749,7 +743,4 @@ unregScriptFileName = case buildOS of _ -> "unregister.sh" internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB) -internalPackageDBPath lbi distPref = - case compilerFlavor (compiler lbi) of - UHC -> UHC.inplacePackageDbPath lbi - _ -> distPref makeRelativePathEx "package.conf.inplace" +internalPackageDBPath lbi distPref = distPref makeRelativePathEx "package.conf.inplace" diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 67945bd4d43..37a0fa4b084 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -437,7 +437,6 @@ configureOptions showOrParseArgs = ( choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS") - , (Flag UHC, ([], ["uhc"]), "compile with UHC") ] ) , option diff --git a/Cabal/src/Distribution/Simple/UHC.hs b/Cabal/src/Distribution/Simple/UHC.hs deleted file mode 100644 index 0016c93d4a8..00000000000 --- a/Cabal/src/Distribution/Simple/UHC.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ - --- | --- Module : Distribution.Simple.UHC --- Copyright : Andres Loeh 2009 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains most of the UHC-specific code for configuring, building --- and installing packages. --- --- Thanks to the authors of the other implementation-specific files, in --- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for --- inspiration on how to design this module. -module Distribution.Simple.UHC - ( configure - , getInstalledPackages - , buildLib - , buildExe - , installLib - , registerPackage - , inplacePackageDbPath - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.InstalledPackageInfo -import Distribution.Package hiding (installedUnitId) -import Distribution.PackageDescription -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.MungedPackageId -import Distribution.Utils.Path -import Distribution.Verbosity -import Distribution.Version -import Language.Haskell.Extension - -import qualified Data.Map as Map (empty) -import System.Directory -import System.FilePath (pathSeparator) - --- ----------------------------------------------------------------------------- --- Configuring - -configure - :: Verbosity - -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath progdb = do - (_uhcProg, uhcVersion, progdb') <- - requireProgramVersion - verbosity - uhcProgram - (orLaterVersion (mkVersion [1, 0, 2])) - (userMaybeSpecifyPath "uhc" hcPath progdb) - - let comp = - Compiler - { compilerId = CompilerId UHC uhcVersion - , compilerAbiTag = NoAbiTag - , compilerCompat = [] - , compilerLanguages = uhcLanguages - , compilerExtensions = uhcLanguageExtensions - , compilerProperties = Map.empty - } - compPlatform = Nothing - return (comp, compPlatform, progdb') - -uhcLanguages :: [(Language, CompilerFlag)] -uhcLanguages = [(Haskell98, "")] - --- | The flags for the supported extensions. -uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] -uhcLanguageExtensions = - let doFlag (f, (enable, disable)) = - [ (EnableExtension f, enable) - , (DisableExtension f, disable) - ] - alwaysOn = (Nothing, Nothing {- wrong -}) - in concatMap - doFlag - [ (CPP, (Just "--cpp", Nothing {- wrong -})) - , (PolymorphicComponents, alwaysOn) - , (ExistentialQuantification, alwaysOn) - , (ForeignFunctionInterface, alwaysOn) - , (UndecidableInstances, alwaysOn) - , (MultiParamTypeClasses, alwaysOn) - , (Rank2Types, alwaysOn) - , (PatternSignatures, alwaysOn) - , (EmptyDataDecls, alwaysOn) - , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -})) - , (TypeOperators, alwaysOn) - , (OverlappingInstances, alwaysOn) - , (FlexibleInstances, alwaysOn) - ] - -getInstalledPackages - :: Verbosity - -> Compiler - -> Maybe (SymbolicPath CWD (Dir from)) - -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do - let compilerid = compilerId comp - systemPkgDir <- getGlobalPackageDir verbosity progdb - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs) - -- putStrLn $ "pkgdirs: " ++ show pkgDirs - pkgs <- - liftM (map addBuiltinVersions . concat) $ - traverse - (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) - pkgDirs - -- putStrLn $ "pkgs: " ++ show pkgs - let iPkgs = - map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs - -- putStrLn $ "installed pkgs: " ++ show iPkgs - return (fromList iPkgs) - -getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath -getGlobalPackageDir verbosity progdb = do - output <- - getDbProgramOutput - verbosity - uhcProgram - progdb - ["--meta-pkgdir-system"] - -- we need to trim because pkgdir contains an extra newline at the end - let pkgdir = trimEnd output - return pkgdir - where - trimEnd = dropWhileEnd isSpace - -getUserPackageDir :: IO FilePath -getUserPackageDir = do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way - -packageDbPaths - :: FilePath - -> FilePath - -> Maybe (SymbolicPath CWD (Dir from)) - -> PackageDBX (SymbolicPath from (Dir PkgDB)) - -> [FilePath] -packageDbPaths user system mbWorkDir db = - case db of - GlobalPackageDB -> [system] - UserPackageDB -> [user] - SpecificPackageDB path -> [interpretSymbolicPath mbWorkDir path] - --- | Hack to add version numbers to UHC-built-in packages. This should sooner or --- later be fixed on the UHC side. -addBuiltinVersions :: String -> String -{- -addBuiltinVersions "uhcbase" = "uhcbase-1.0" -addBuiltinVersions "base" = "base-3.0" -addBuiltinVersions "array" = "array-0.2" --} -addBuiltinVersions xs = xs - --- | Name of the installed package config file. -installedPkgConfig :: String -installedPkgConfig = "installed-pkg-config" - --- | Check if a certain dir contains a valid package. Currently, we are --- looking only for the presence of an installed package configuration. --- TODO: Actually make use of the information provided in the file. -isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) - -parsePackage :: String -> [PackageId] -parsePackage = toList . simpleParsec - --- | Create a trivial package info from a directory name. -mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = - emptyInstalledPackageInfo - { installedUnitId = mkLegacyUnitId p - , sourcePackageId = p - } - --- ----------------------------------------------------------------------------- --- Building - -buildLib - :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir - let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) - let uhcArgs = - -- set package name - ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine - userPkgDir - systemPkgDir - lbi - (libBuildInfo lib) - clbi - (buildDir lbi) - verbosity - -- source files - -- suboptimal: UHC does not understand module names, so - -- we replace periods by path separators - ++ map - (map (\c -> if c == '.' then pathSeparator else c)) - (map prettyShow (allLibModules lib clbi)) - - runUhcProg uhcArgs - - return () - -buildExe - :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO () -buildExe verbosity _pkg_descr lbi exe clbi = do - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir - let mbWorkDir = mbWorkDirLBI lbi - srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs $ buildInfo exe) (modulePath exe) - let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) - u = interpretSymbolicPathCWD - uhcArgs = - -- common flags lib/exe - constructUHCCmdLine - userPkgDir - systemPkgDir - lbi - (buildInfo exe) - clbi - (buildDir lbi) - verbosity - -- output file - ++ ["--output", u $ buildDir lbi makeRelativePathEx (prettyShow (exeName exe))] - -- main source module - ++ [u $ srcMainPath] - runUhcProg uhcArgs - -constructUHCCmdLine - :: FilePath - -> FilePath - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir Build) - -> Verbosity - -> [String] -constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - ( if verbosity >= deafening - then ["-v4"] - else - if verbosity >= normal - then [] - else ["-v0"] - ) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] - -- search paths - ++ ["-i" ++ u odir] - ++ ["-i" ++ u l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)] - ++ ["-i" ++ u (autogenPackageModulesDir lbi)] - -- cpp options - ++ ["--optP=" ++ opt | opt <- cppOptions bi] - -- output path - ++ ["--odir=" ++ u odir] - -- optimization - ++ ( case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"] - ) - where - u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path - -uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = - map - (\x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system Nothing) db) - --- ----------------------------------------------------------------------------- --- Installation - -installLib - :: Verbosity - -> LocalBuildInfo - -> FilePath - -> FilePath - -> FilePath - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir - --- currently hard-coded UHC code generator and variant to use -uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" -uhcTargetVariant = "plain" - --- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> Maybe (SymbolicPath CWD (Dir from)) - -> Compiler - -> ProgramDb - -> PackageDBStackS from - -> InstalledPackageInfo - -> IO () -registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo = do - dbdir <- case registrationPackageDB packageDbs of - GlobalPackageDB -> getGlobalPackageDir verbosity progdb - UserPackageDB -> getUserPackageDir - SpecificPackageDB dir -> return (interpretSymbolicPath mbWorkDir dir) - let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File - (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) - where - pkgid = sourcePackageId installedPkgInfo - compilerid = compilerId comp - -inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB) -inplacePackageDbPath lbi = coerceSymbolicPath $ buildDir lbi diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index c2c72684d48..f9395500d22 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -2749,7 +2749,6 @@ testConfigOptionComments = do " -- runghc-location" `assertHasCommentLine` "runghc-location" " -- strip-location" `assertHasCommentLine` "strip-location" " -- tar-location" `assertHasCommentLine` "tar-location" - " -- uhc-location" `assertHasCommentLine` "uhc-location" " -- alex-options" `assertHasCommentLine` "alex-options" " -- ar-options" `assertHasCommentLine` "ar-options" @@ -2772,7 +2771,6 @@ testConfigOptionComments = do " -- runghc-options" `assertHasCommentLine` "runghc-options" " -- strip-options" `assertHasCommentLine` "strip-options" " -- tar-options" `assertHasCommentLine` "tar-options" - " -- uhc-options" `assertHasCommentLine` "uhc-options" testIgnoreProjectFlag :: Assertion testIgnoreProjectFlag = do diff --git a/cabal-install/tests/IntegrationTests2/nix-config/nix-false b/cabal-install/tests/IntegrationTests2/nix-config/nix-false index 44d315dead6..b860a403e3c 100644 --- a/cabal-install/tests/IntegrationTests2/nix-config/nix-false +++ b/cabal-install/tests/IntegrationTests2/nix-config/nix-false @@ -196,7 +196,6 @@ program-locations -- runghc-location: -- strip-location: -- tar-location: - -- uhc-location: program-default-options -- alex-options: @@ -220,5 +219,4 @@ program-default-options -- pkg-config-options: -- runghc-options: -- strip-options: - -- tar-options: - -- uhc-options: \ No newline at end of file + -- tar-options: \ No newline at end of file diff --git a/cabal-install/tests/IntegrationTests2/nix-config/nix-true b/cabal-install/tests/IntegrationTests2/nix-config/nix-true index 20f307d4323..9085198f3fc 100644 --- a/cabal-install/tests/IntegrationTests2/nix-config/nix-true +++ b/cabal-install/tests/IntegrationTests2/nix-config/nix-true @@ -196,7 +196,6 @@ program-locations -- runghc-location: -- strip-location: -- tar-location: - -- uhc-location: program-default-options -- alex-options: @@ -220,5 +219,4 @@ program-default-options -- pkg-config-options: -- runghc-options: -- strip-options: - -- tar-options: - -- uhc-options: \ No newline at end of file + -- tar-options: \ No newline at end of file diff --git a/doc/cabal-interface-stability.rst b/doc/cabal-interface-stability.rst index 2993f8ab0ff..8451a0bfbde 100644 --- a/doc/cabal-interface-stability.rst +++ b/doc/cabal-interface-stability.rst @@ -26,7 +26,7 @@ Very Stable Command-line interfaces - ``./setup configure`` - ``--prefix`` - ``--user`` -- ``--ghc``, ``--uhc`` +- ``--ghc`` - ``--verbose`` - ``--prefix`` diff --git a/doc/cabal-package-description-file.rst b/doc/cabal-package-description-file.rst index 7359670242d..1193f546a05 100644 --- a/doc/cabal-package-description-file.rst +++ b/doc/cabal-package-description-file.rst @@ -264,7 +264,7 @@ The syntax of the value depends on the field. Field types include: *identifier* A letter followed by zero or more alphanumerics or underscores. *compiler* - A compiler flavor (one of: ``GHC``, ``UHC`` or ``LHC``) + A compiler flavor (``GHC`` or ``LHC``) followed by a version range. For example, ``GHC ==6.10.3``, or ``LHC >=0.6 && <0.8``. diff --git a/doc/cabal-project-description-file.rst b/doc/cabal-project-description-file.rst index adae4514b14..fa238535870 100644 --- a/doc/cabal-project-description-file.rst +++ b/doc/cabal-project-description-file.rst @@ -983,7 +983,7 @@ feature was added. The command line variant of this flag is ``--configure-option=arg``, which can be specified multiple times to pass multiple options. -.. cfg-field:: compiler: ghc, ghcjs, jhc, lhc, or uhc +.. cfg-field:: compiler: ghc, ghcjs, jhc, or lhc --compiler=compiler :synopsis: Compiler to build with. diff --git a/doc/config.rst b/doc/config.rst index 00032a459ca..23594115a11 100644 --- a/doc/config.rst +++ b/doc/config.rst @@ -365,8 +365,6 @@ The list of known programs is: +-----------------------+------------------------------------------------------------------------------------------------------------------------------------+ | ``tar`` | | +-----------------------+------------------------------------------------------------------------------------------------------------------------------------+ -| ``uhc`` | ``_ | -+-----------------------+------------------------------------------------------------------------------------------------------------------------------------+ .. warning:: diff --git a/doc/setup-commands.rst b/doc/setup-commands.rst index 970439e748d..b6e2ea0027e 100644 --- a/doc/setup-commands.rst +++ b/doc/setup-commands.rst @@ -168,7 +168,6 @@ files of a package: .. option:: -g, --ghc --ghcjs - --uhc --haskell-suite Specify which Haskell implementation to use to build the package. At diff --git a/test/IntegrationTests2/config/default-config b/test/IntegrationTests2/config/default-config index 4e9d195adc2..f8556d80e99 100644 --- a/test/IntegrationTests2/config/default-config +++ b/test/IntegrationTests2/config/default-config @@ -212,7 +212,6 @@ program-locations -- runghc-location: -- strip-location: -- tar-location: - -- uhc-location: program-default-options -- alex-options: @@ -236,4 +235,3 @@ program-default-options -- runghc-options: -- strip-options: -- tar-options: - -- uhc-options: diff --git a/test/IntegrationTests2/nix-config/default-config b/test/IntegrationTests2/nix-config/default-config index 4e9d195adc2..f8556d80e99 100644 --- a/test/IntegrationTests2/nix-config/default-config +++ b/test/IntegrationTests2/nix-config/default-config @@ -212,7 +212,6 @@ program-locations -- runghc-location: -- strip-location: -- tar-location: - -- uhc-location: program-default-options -- alex-options: @@ -236,4 +235,3 @@ program-default-options -- runghc-options: -- strip-options: -- tar-options: - -- uhc-options: diff --git a/tests/IntegrationTests2/config/default-config b/tests/IntegrationTests2/config/default-config index 5967b655790..95374819842 100644 --- a/tests/IntegrationTests2/config/default-config +++ b/tests/IntegrationTests2/config/default-config @@ -214,7 +214,6 @@ program-locations -- runghc-location: -- strip-location: -- tar-location: - -- uhc-location: program-default-options -- alex-options: @@ -238,4 +237,3 @@ program-default-options -- runghc-options: -- strip-options: -- tar-options: - -- uhc-options: diff --git a/tests/IntegrationTests2/nix-config/default-config b/tests/IntegrationTests2/nix-config/default-config index 4e9d195adc2..f8556d80e99 100644 --- a/tests/IntegrationTests2/nix-config/default-config +++ b/tests/IntegrationTests2/nix-config/default-config @@ -212,7 +212,6 @@ program-locations -- runghc-location: -- strip-location: -- tar-location: - -- uhc-location: program-default-options -- alex-options: @@ -236,4 +235,3 @@ program-default-options -- runghc-options: -- strip-options: -- tar-options: - -- uhc-options: From 3cec6f0b081ba2cf5769ab182aa00a338c1dfb2b Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Nov 2025 18:15:26 +0800 Subject: [PATCH 073/122] refactor: remove behaviour specific to GHC 8.4 --- Cabal/src/Distribution/Simple/Register.hs | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index d02112171a5..402e164950d 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -65,7 +65,7 @@ import Distribution.Backpack.DescribeUnitId import Distribution.Compat.Graph (IsNode (nodeKey)) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.License (licenseFromSPDX, licenseToSPDX) +import Distribution.License (licenseToSPDX) import Distribution.Package import Distribution.PackageDescription import Distribution.Pretty @@ -82,7 +82,6 @@ import Distribution.System import Distribution.Utils.MapAccum import Distribution.Utils.Path import Distribution.Verbosity as Verbosity -import Distribution.Version import System.Directory import System.FilePath (isAbsolute) @@ -490,11 +489,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi) , IPI.sourceLibName = libName lib , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi) - , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license - IPI.license = - if ghc84 - then Left $ either id licenseToSPDX $ licenseRaw pkg - else Right $ either licenseFromSPDX id $ licenseRaw pkg + , IPI.license = Left $ either id licenseToSPDX $ licenseRaw pkg , IPI.copyright = copyright pkg , IPI.maintainer = maintainer pkg , IPI.author = author pkg @@ -545,17 +540,12 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi , IPI.libVisibility = libVisibility lib } where - ghc84 = case compilerId $ compiler lbi of - CompilerId GHC v -> v >= mkVersion [8, 4] - _ -> False - bi = libBuildInfo lib -- TODO: unclear what the root cause of the -- duplication is, but we nub it here for now: depends = ordNub $ map fst (componentPackageDeps clbi) (absinc, relinc) = partition isAbsolute (map getSymbolicPath $ includeDirs bi) hasModules = not $ null (allLibModules lib clbi) - comp = compiler lbi hasLibrary = ( hasModules || not (null (cSources bi)) From c449c6d1c2b1ad25fc2dd5892dc4c18491eb4d5b Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Nov 2025 13:50:19 +0800 Subject: [PATCH 074/122] small change in logging --- .../Distribution/Client/ProjectBuilding/UnpackedPackage.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 63270d85448..4b53d401b1d 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -213,11 +213,11 @@ buildAndRegisterUnpackedPackage PBInstallPhase { runCopy = \destdir -> annotateFailure mlogFile InstallFailed $ do - info verbosity $ "--- Install phase, copy " ++ prettyShow (Graph.nodeKey pkg) + info verbosity $ "--- Install phase (copy) " ++ prettyShow (Graph.nodeKey pkg) setup Cabal.copyCommand Cabal.copyCommonFlags (return . copyFlags destdir) copyArgs , runRegister = \pkgDBStack registerOpts -> annotateFailure mlogFile InstallFailed $ do - info verbosity $ "--- Install phase, register " ++ prettyShow (Graph.nodeKey pkg) + info verbosity $ "--- Install phase (register) " ++ prettyShow (Graph.nodeKey pkg) -- We register ourselves rather than via Setup.hs. We need to -- grab and modify the InstalledPackageInfo. We decide what -- the installed package id is, not the build system. From 188bd336aefe339943bb0d75a1772436bf42daae Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 20 Nov 2025 13:51:39 +0800 Subject: [PATCH 075/122] use package.conf.d as GHC does package.db -> package.conf.d --- cabal-install/src/Distribution/Client/DistDirLayout.hs | 2 +- cabal-install/src/Distribution/Client/Store.hs | 2 +- cabal-testsuite/main/cabal-tests.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 8edebf02d07..0c46423768a 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -260,7 +260,7 @@ defaultStoreDirLayout storeRoot = storePackageDBPath :: Compiler -> FilePath storePackageDBPath compiler = - storeDirectory compiler "package.db" + storeDirectory compiler "package.conf.d" storePackageDB :: Compiler -> PackageDBCWD storePackageDB compiler = diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index dcf4c78d02c..4bcb5d75949 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -138,7 +138,7 @@ getStoreEntries StoreDirLayout{storeDirectory} compiler = do return $! mkEntries paths where mkEntries = - Set.delete (mkUnitId "package.db") + Set.delete (mkUnitId "package.conf.d") . Set.delete (mkUnitId "incoming") . Set.fromList . map mkUnitId diff --git a/cabal-testsuite/main/cabal-tests.hs b/cabal-testsuite/main/cabal-tests.hs index 05871ab7190..6dd73044688 100644 --- a/cabal-testsuite/main/cabal-tests.hs +++ b/cabal-testsuite/main/cabal-tests.hs @@ -167,7 +167,7 @@ buildCabalLibsProject projString verb mbGhc dir = do case filter (prettyShow pv `isInfixOf`) storesByGhc of [] -> return [final_package_db] storeForGhc:_ -> do - let storePackageDB = (storeRoot storeForGhc "package.db") + let storePackageDB = (storeRoot storeForGhc "package.conf.d") return [storePackageDB, final_package_db] From 99898783c6ff4c72d5793494201eab15354600d1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 19 Nov 2025 12:03:03 +0800 Subject: [PATCH 076/122] refactor: remove support for GHCJS --- Cabal-syntax/src/Distribution/Compiler.hs | 50 +- .../PackageDescription/FieldGrammar.hs | 49 +- .../src/Distribution/Types/BuildInfo.hs | 18 +- .../src/Distribution/Types/BuildInfo/Lens.hs | 11 +- .../src/Data/TreeDiff/Instances/Cabal.hs | 4 +- Cabal/Cabal.cabal | 1 - .../PackageDescription/Check/Target.hs | 2 +- Cabal/src/Distribution/Simple/Build.hs | 16 - .../Distribution/Simple/Build/PathsModule.hs | 1 - Cabal/src/Distribution/Simple/Compiler.hs | 3 - Cabal/src/Distribution/Simple/Configure.hs | 14 - .../src/Distribution/Simple/GHC/Build/Link.hs | 4 +- Cabal/src/Distribution/Simple/GHC/ImplInfo.hs | 7 - Cabal/src/Distribution/Simple/GHCJS.hs | 2117 ----------------- Cabal/src/Distribution/Simple/Haddock.hs | 5 +- Cabal/src/Distribution/Simple/Install.hs | 4 - Cabal/src/Distribution/Simple/InstallDirs.hs | 2 +- Cabal/src/Distribution/Simple/PreProcess.hs | 16 - Cabal/src/Distribution/Simple/Program/GHC.hs | 17 +- Cabal/src/Distribution/Simple/Register.hs | 8 +- Cabal/src/Distribution/Simple/Setup/Config.hs | 1 - .../src/Distribution/Simple/ShowBuildInfo.hs | 1 - .../src/Distribution/Client/CmdInstall.hs | 2 +- .../src/Distribution/Client/CmdPath.hs | 1 - .../Distribution/Client/ProjectPlanOutput.hs | 3 +- cabal-install/src/Distribution/Client/Run.hs | 21 +- .../src/Distribution/Client/ScriptUtils.hs | 13 +- .../src/Distribution/Client/SetupWrapper.hs | 29 +- 28 files changed, 63 insertions(+), 2357 deletions(-) delete mode 100644 Cabal/src/Distribution/Simple/GHCJS.hs diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 406cbcb55f0..eaca33b88e3 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -34,10 +34,6 @@ module Distribution.Compiler , classifyCompilerFlavor , knownCompilerFlavors - -- * Per compiler flavor - , PerCompilerFlavor (..) - , perCompilerFlavorToList - -- * Compiler id , CompilerId (..) @@ -63,7 +59,6 @@ import qualified Text.PrettyPrint as Disp data CompilerFlavor = GHC - | GHCJS | NHC | YHC | Hugs @@ -84,7 +79,7 @@ instance NFData CompilerFlavor where rnf = genericRnf knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, Eta, MHS] + [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, Eta, MHS] instance Pretty CompilerFlavor where pretty (OtherCompiler name) = Disp.text name @@ -126,48 +121,9 @@ defaultCompilerFlavor = case buildCompilerFlavor of OtherCompiler _ -> Nothing _ -> Just buildCompilerFlavor -------------------------------------------------------------------------------- --- Per compiler data -------------------------------------------------------------------------------- - --- | 'PerCompilerFlavor' carries only info per GHC and GHCJS --- --- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. -data PerCompilerFlavor v = PerCompilerFlavor v v - deriving - ( Generic - , Show - , Read - , Eq - , Ord - , Data - , Functor - , Foldable - , Traversable - ) - -instance Binary a => Binary (PerCompilerFlavor a) -instance Structured a => Structured (PerCompilerFlavor a) -instance NFData a => NFData (PerCompilerFlavor a) - -perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] -perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] - -instance Semigroup a => Semigroup (PerCompilerFlavor a) where - PerCompilerFlavor a b <> PerCompilerFlavor a' b' = - PerCompilerFlavor - (a <> a') - (b <> b') - -instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where - mempty = PerCompilerFlavor mempty mempty - mappend = (<>) - --- ------------------------------------------------------------ - +-------------------------------------------------------------- -- * Compiler Id - --- ------------------------------------------------------------ +-------------------------------------------------------------- data CompilerId = CompilerId CompilerFlavor Version deriving (Eq, Generic, Ord, Read, Show) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 558594f72b6..96caa1719e0 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -74,7 +74,7 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Compat.Newtype (Newtype, pack', unpack') -import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) +import Distribution.Compiler (CompilerFlavor (..)) import Distribution.FieldGrammar import Distribution.Fields import Distribution.ModuleName (ModuleName) @@ -720,61 +720,38 @@ hsSourceDirsGrammar = optionsFieldGrammar :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + => g BuildInfo [String] optionsFieldGrammar = - PerCompilerFlavor - <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) + monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') L.options -- NOTE: Hugs, NHC and JHC are not supported anymore, but these -- fields are kept around so that we can still parse legacy .cabal -- files that have them. + <* knownField "ghcjs-options" <* knownField "jhc-options" <* knownField "hugs-options" <* knownField "nhc98-options" - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.options . lookupLens flavor profOptionsFieldGrammar :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + => g BuildInfo [String] profOptionsFieldGrammar = - PerCompilerFlavor - <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profOptions . lookupLens flavor + monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') L.profOptions + <* knownField "ghcjs-prof-options" sharedOptionsFieldGrammar :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + => g BuildInfo [String] sharedOptionsFieldGrammar = - PerCompilerFlavor - <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.sharedOptions . lookupLens flavor + monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') L.sharedOptions + <* knownField "ghcjs-shared-options" profSharedOptionsFieldGrammar :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + => g BuildInfo [String] profSharedOptionsFieldGrammar = - PerCompilerFlavor - <$> monoidalFieldAla "ghc-prof-shared-options" (alaList' NoCommaFSep Token') (extract GHC) + monoidalFieldAla "ghc-prof-shared-options" (alaList' NoCommaFSep Token') L.profSharedOptions ^^^ availableSince CabalSpecV3_14 [] - <*> monoidalFieldAla "ghcjs-prof-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) - ^^^ availableSince CabalSpecV3_14 [] - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profSharedOptions . lookupLens flavor - -lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v -lookupLens k f p@(PerCompilerFlavor ghc ghcjs) - | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc - | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs - | otherwise = p <$ f mempty + <* knownField "ghcjs-prof-shared-options" ------------------------------------------------------------------------------- -- Flag diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index f41f800be13..c8d4772793f 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -139,11 +139,11 @@ data BuildInfo = BuildInfo -- ^ The .h files to be generated (e.g. by @autoconf@) , installIncludes :: [RelativePath Include File] -- ^ .h files to install with the package - , options :: PerCompilerFlavor [String] - , profOptions :: PerCompilerFlavor [String] - , sharedOptions :: PerCompilerFlavor [String] - , profSharedOptions :: PerCompilerFlavor [String] - , staticOptions :: PerCompilerFlavor [String] + , options :: [String] + , profOptions :: [String] + , sharedOptions :: [String] + , profSharedOptions :: [String] + , staticOptions :: [String] , customFieldsBI :: [(String, String)] -- ^ Custom fields starting -- with x-, stored in a @@ -318,12 +318,8 @@ hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] hcStaticOptions = lookupHcOptions staticOptions lookupHcOptions - :: (BuildInfo -> PerCompilerFlavor [String]) + :: (BuildInfo -> [String]) -> CompilerFlavor -> BuildInfo -> [String] -lookupHcOptions f hc bi = case f bi of - PerCompilerFlavor ghc ghcjs - | hc == GHC -> ghc - | hc == GHCJS -> ghcjs - | otherwise -> mempty +lookupHcOptions f _hc bi = f bi diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 70e7f1e38d4..b3db4a781b8 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -10,7 +10,6 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Compiler (PerCompilerFlavor) import Distribution.ModuleName (ModuleName) import Distribution.Types.BuildInfo (BuildInfo) import Distribution.Types.Dependency (Dependency) @@ -192,23 +191,23 @@ class HasBuildInfo a where installIncludes = buildInfo . installIncludes {-# INLINE installIncludes #-} - options :: Lens' a (PerCompilerFlavor [String]) + options :: Lens' a [String] options = buildInfo . options {-# INLINE options #-} - profOptions :: Lens' a (PerCompilerFlavor [String]) + profOptions :: Lens' a [String] profOptions = buildInfo . profOptions {-# INLINE profOptions #-} - sharedOptions :: Lens' a (PerCompilerFlavor [String]) + sharedOptions :: Lens' a [String] sharedOptions = buildInfo . sharedOptions {-# INLINE sharedOptions #-} - profSharedOptions :: Lens' a (PerCompilerFlavor [String]) + profSharedOptions :: Lens' a [String] profSharedOptions = buildInfo . profSharedOptions {-# INLINE profSharedOptions #-} - staticOptions :: Lens' a (PerCompilerFlavor [String]) + staticOptions :: Lens' a [String] staticOptions = buildInfo . staticOptions {-# INLINE staticOptions #-} diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index 77a1d5b86c3..ab6a81d87f3 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -13,7 +13,7 @@ import Data.TreeDiff.Instances.CabalVersion () import Distribution.Backpack (OpenModule, OpenUnitId) import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor, CompilerId, PerCompilerFlavor) +import Distribution.Compiler (CompilerFlavor, CompilerId) import Distribution.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription @@ -46,8 +46,6 @@ instance (ToExpr a) => ToExpr (NubList a) instance ToExpr a => ToExpr (NES.NonEmptySet a) where toExpr xs = App "NonEmptySet.fromNonEmpty" [toExpr $ NES.toNonEmpty xs] -instance ToExpr a => ToExpr (PerCompilerFlavor a) - instance ToExpr Dependency where toExpr d@(Dependency pn vr cs) | cs == mainLibSet = App "Dependency" [toExpr pn, toExpr vr, App "mainLibSet" []] diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index fb7ffedebb0..043d70a3e00 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -122,7 +122,6 @@ library Distribution.Simple.FileMonitor.Types Distribution.Simple.Flag Distribution.Simple.GHC - Distribution.Simple.GHCJS Distribution.Simple.Haddock Distribution.Simple.Glob Distribution.Simple.Glob.Internal diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs index d59ae78289c..baa8e092ada 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Target.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Target.hs @@ -481,7 +481,7 @@ checkBuildInfoPathsWellFormedness bi = do mapM_ (checkPath True "extra-lib-dirs-static" PathKindDirectory . getSymbolicPath) (extraLibDirsStatic bi) - mapM_ checkOptionPath (perCompilerFlavorToList $ options bi) + mapM_ checkOptionPath [(GHC, options bi)] where checkOptionPath :: Monad m diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 413002adcab..2183caa99bc 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -71,7 +71,6 @@ import Distribution.Backpack import Distribution.Backpack.DescribeUnitId import Distribution.Package import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.PackageIndex as Index import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) @@ -312,7 +311,6 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do -- which program we need. flavorToProgram :: CompilerFlavor -> Maybe Program flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram flavorToProgram JHC = Just jhcProgram flavorToProgram _ = Nothing @@ -435,7 +433,6 @@ startInterpreter startInterpreter verbosity programDb comp platform packageDBs = case compilerFlavor comp of GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs - GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs _ -> dieWithException verbosity REPLNotSupported buildComponent @@ -970,7 +967,6 @@ buildLib flags numJobs pkg_descr lbi lib clbi = let verbosity = fromFlag $ buildVerbosity flags in case compilerFlavor (compiler lbi) of GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi - GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler -- | Build a foreign library @@ -1001,7 +997,6 @@ buildExe buildExe verbosity numJobs pkg_descr lbi exe clbi = case compilerFlavor (compiler lbi) of GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi - GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi _ -> dieWithException verbosity BuildingNotSupportedWithCompiler replLib @@ -1013,12 +1008,10 @@ replLib -> IO () replLib replFlags pkg_descr lbi lib clbi = let verbosity = fromFlag $ replVerbosity replFlags - opts = replReplOptions replFlags in case compilerFlavor (compiler lbi) of -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass -- NoFlag as the numJobs parameter. GHC -> GHC.replLib replFlags NoFlag pkg_descr lbi lib clbi - GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi _ -> dieWithException verbosity REPLNotSupported replExe @@ -1032,15 +1025,6 @@ replExe flags pkg_descr lbi exe clbi = let verbosity = fromFlag $ replVerbosity flags in case compilerFlavor (compiler lbi) of GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi - GHCJS -> - GHCJS.replExe - (replOptionsFlags $ replReplOptions flags) - verbosity - NoFlag - pkg_descr - lbi - exe - clbi _ -> dieWithException verbosity REPLNotSupported replFLib diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule.hs b/Cabal/src/Distribution/Simple/Build/PathsModule.hs index 9392acf3cef..ece90cbd56c 100644 --- a/Cabal/src/Distribution/Simple/Build/PathsModule.hs +++ b/Cabal/src/Distribution/Simple/Build/PathsModule.hs @@ -84,7 +84,6 @@ generatePathsModule pkg_descr lbi clbi = _ -> False supportsRelocatableProgs GHC = isWindows - supportsRelocatableProgs GHCJS = isWindows supportsRelocatableProgs _ = False cid = componentUnitId clbi diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 543ff1e0083..8b88493abf6 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -506,7 +506,6 @@ coverageSupported :: Compiler -> Bool coverageSupported comp = case compilerFlavor comp of GHC -> True - GHCJS -> True _ -> False -- | Does this compiler support profiling? @@ -514,7 +513,6 @@ profilingSupported :: Compiler -> Bool profilingSupported comp = case compilerFlavor comp of GHC -> True - GHCJS -> True _ -> False -- | Returns Just if we can certainly determine whether a way is supported @@ -576,7 +574,6 @@ ghcSupported :: String -> Compiler -> Bool ghcSupported key comp = case compilerFlavor comp of GHC -> checkProp - GHCJS -> checkProp _ -> False where checkProp = diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 26874a6da2c..00229a4f8db 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -119,7 +119,6 @@ import Distribution.Verbosity import Distribution.Version import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS import Control.Exception ( try @@ -653,8 +652,6 @@ computeLocalBuildConfig cfg comp programDb = do GHC | compilerVersion comp >= mkVersion [8, 0] -> return True - GHCJS -> - return True _ -> do warn verbosity @@ -679,8 +676,6 @@ computeLocalBuildConfig cfg comp programDb = do return False GHC -> return True - GHCJS -> - return True _ -> do warn verbosity @@ -711,8 +706,6 @@ computeLocalBuildConfig cfg comp programDb = do -- been changed to read shared libraries instead of archive -- files (see next code block). notElem (GHC.compilerBuildWay comp) [DynWay, ProfDynWay] - CompilerId GHCJS _ -> - not (GHCJS.isDynamic comp) _ -> False withGHCiLib_ <- @@ -736,8 +729,6 @@ computeLocalBuildConfig cfg comp programDb = do -- if ghc is dynamic, then ghci needs a shared -- library, so we build one by default. GHC.compilerBuildWay comp == DynWay - CompilerId GHCJS _ -> - GHCJS.isDynamic comp _ -> False withSharedLib_ = -- build shared libraries if required by GHC or by the @@ -2069,7 +2060,6 @@ getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do packageDBs' <- filterM packageDBExists packageDBs case compilerFlavor comp of GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb - GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb flv -> dieWithException verbosity $ HowToFindInstalledPackages flv where @@ -2103,7 +2093,6 @@ getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do info verbosity "Reading installed packages..." case compilerFlavor comp of GHC -> GHC.getPackageDBContents verbosity mbWorkDir packageDB progdb - GHCJS -> GHCJS.getPackageDBContents verbosity mbWorkDir packageDB progdb -- For other compilers, try to fall back on 'getInstalledPackages'. _ -> getInstalledPackages verbosity comp mbWorkDir [packageDB] progdb @@ -2501,7 +2490,6 @@ configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCom configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do (comp, maybePlatform, programDb) <- case hcFlavor of GHC -> GHC.configure verbosity hcPath hcPkg progdb - GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb _ -> dieWithException verbosity UnknownCompilerException return (comp, fromMaybe buildPlatform maybePlatform, programDb) @@ -2520,7 +2508,6 @@ configCompiler mbFlavor hcPath progdb verbosity = do Just hcFlavor -> case hcFlavor of GHC -> GHC.configureCompiler verbosity hcPath progdb - GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb _ -> dieWithException verbosity UnknownCompilerException return (comp, fromMaybe buildPlatform maybePlatform, programDb) @@ -2537,7 +2524,6 @@ configCompilerProgDb configCompilerProgDb verbosity comp hcProgDb hcPkgPath = do case compilerFlavor comp of GHC -> GHC.compilerProgramDb verbosity comp hcProgDb hcPkgPath - GHCJS -> GHCJS.compilerProgramDb verbosity comp hcProgDb hcPkgPath _ -> return hcProgDb -- ----------------------------------------------------------------------------- diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index 7dbdea229d0..07d414d9608 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -727,9 +727,7 @@ extractRtsInfo lbi = -- threaded RTS. This is used to determine which RTS to link against when -- building a foreign library with a GHC without support for @-flink-rts@. hasThreaded :: BuildInfo -> Bool -hasThreaded bi = elem "-threaded" ghc - where - PerCompilerFlavor ghc _ = options bi +hasThreaded bi = elem "-threaded" (options bi) -- | Load a target component into a repl, or write to disk a script which runs -- GHCi with the GHC options Cabal elaborated to load the component interactively. diff --git a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs index f575697819b..24ec8a13403 100644 --- a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs +++ b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs @@ -70,13 +70,6 @@ getImplInfo :: Compiler -> GhcImplInfo getImplInfo comp = case compilerFlavor comp of GHC -> ghcVersionImplInfo (compilerVersion comp) - GHCJS -> case compilerCompatVersion GHC comp of - Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer - _ -> - error - ( "Distribution.Simple.GHC.Props.getImplProps: " - ++ "could not find GHC version for GHCJS compiler" - ) x -> error ( "Distribution.Simple.GHC.Props.getImplProps only works" diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs deleted file mode 100644 index de942f03515..00000000000 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ /dev/null @@ -1,2117 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.GHCJS - ( getGhcInfo - , configure - , configureCompiler - , compilerProgramDb - , getInstalledPackages - , getInstalledPackagesMonitorFiles - , getPackageDBContents - , buildLib - , buildFLib - , buildExe - , replLib - , replFLib - , replExe - , startInterpreter - , installLib - , installFLib - , installExe - , libAbiHash - , hcPkgInfo - , registerPackage - , componentGhcOptions - , Internal.componentCcGhcOptions - , getLibDir - , isDynamic - , getGlobalPackageDB - , pkgRoot - , runCmd - - -- * Constructing and deconstructing GHC environment files - , Internal.GhcEnvironmentFileEntry (..) - , Internal.simpleGhcEnvironmentFile - , Internal.renderGhcEnvironmentFile - , Internal.writeGhcEnvironmentFile - , Internal.ghcPlatformAndVersionString - , readGhcEnvironmentFile - , parseGhcEnvironmentFile - , ParseErrorExc (..) - - -- * Version-specific implementation quirks - , getImplInfo - , GhcImplInfo (..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Package -import Distribution.PackageDescription as PD -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.Pretty -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler -import Distribution.Simple.Errors -import Distribution.Simple.Flag -import Distribution.Simple.GHC.Build.Utils (isCxx) -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.Simple.GHC.ImplInfo -import qualified Distribution.Simple.GHC.Internal as Internal -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PreProcess.Types -import Distribution.Simple.Program -import Distribution.Simple.Program.GHC -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Setup.Common -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.PackageName.Magic -import Distribution.Types.ParStrat -import Distribution.Utils.NubList -import Distribution.Utils.Path -import Distribution.Verbosity (Verbosity) -import Distribution.Version - -import Control.Arrow ((***)) -import Control.Monad (msum) -import Data.Char (isLower) -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import System.Directory - ( canonicalizePath - , createDirectoryIfMissing - , doesFileExist - , getAppUserDataDirectory - , removeFile - , renameFile - ) -import System.FilePath - ( isRelative - , replaceExtension - , takeDirectory - , takeExtension - ) -import qualified System.Info - --- ----------------------------------------------------------------------------- --- Configuring - --- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@ --- as well as toolchain programs such as @ar@, @ld. -configure - :: Verbosity - -> Maybe FilePath - -- ^ user-specified @ghcjs@ path (optional) - -> Maybe FilePath - -- ^ user-specified @ghcjs-pkg@ path (optional) - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath conf0 = do - (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 - compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath - return (comp, compPlatform, compProgDb) - --- | Configure GHCJS. -configureCompiler - :: Verbosity - -> Maybe FilePath - -- ^ user-specified @ghc@ path (optional) - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configureCompiler verbosity hcPath conf0 = do - (ghcjsProg, ghcjsVersion, progdb1) <- - requireProgramVersion - verbosity - ghcjsProgram - (orLaterVersion (mkVersion [0, 1])) - (userMaybeSpecifyPath "ghcjs" hcPath conf0) - - Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) - unless (ghcjsGhcVersion < mkVersion [8, 8]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " - ++ prettyShow cabalVersion - ++ " supports 'ghc' version < 8.8): " - ++ programPath ghcjsProg - ++ " is based on GHC version " - ++ prettyShow ghcjsGhcVersion - - let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion - - languages <- Internal.getLanguages verbosity implInfo ghcjsProg - extensions <- Internal.getExtensions verbosity implInfo ghcjsProg - - ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg - let ghcInfoMap = Map.fromList ghcjsInfo - - let comp = - Compiler - { compilerId = CompilerId GHCJS ghcjsVersion - , compilerAbiTag = - AbiTag $ - "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) - , compilerCompat = [CompilerId GHC ghcjsGhcVersion] - , compilerLanguages = languages - , compilerExtensions = extensions - , compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcjsInfo - return (comp, compPlatform, progdb1) - --- | Given a configured @ghcjs@ program, configure auxiliary programs such --- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable. -compilerProgramDb - :: Verbosity - -> Compiler - -> ProgramDb - -> Maybe FilePath - -- ^ user-specified @ghc-pkg@ path (optional) - -> IO ProgramDb -compilerProgramDb verbosity comp progdb1 hcPkgPath = do - let - ghcjsProg = fromJust $ lookupProgram ghcjsProgram progdb1 - ghcjsVersion = compilerVersion comp - ghcjsGhcVersion = case compilerCompat comp of - [CompilerId GHC ghcjsGhcVer] -> ghcjsGhcVer - compat -> error $ "could not parse ghcjsGhcVersion:" ++ show compat - - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- - requireProgramVersion - verbosity - ghcjsPkgProgram - { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg - } - anyVersion - (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) - - Just ghcjsPkgGhcjsVersion <- - findGhcjsPkgGhcjsVersion - verbosity - (programPath ghcjsPkgProg) - - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ - dieWithException verbosity $ - VersionMismatchJS - (programPath ghcjsProg) - ghcjsVersion - (programPath ghcjsPkgProg) - ghcjsPkgGhcjsVersion - - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ - dieWithException verbosity $ - VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion - - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = - hsc2hsProgram - { programFindLocation = - guessHsc2hsFromGhcjsPath ghcjsProg - } - haddockProgram' = - haddockProgram - { programFindLocation = - guessHaddockFromGhcjsPath ghcjsProg - } - hpcProgram' = - hpcProgram - { programFindLocation = guessHpcFromGhcjsPath ghcjsProg - } - {- - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcjsPath ghcjsProg - } -} - progdb3 = - addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - {- addKnownProgram runghcProgram' -} progdb2 - - return progdb3 - -guessGhcjsPkgFromGhcjsPath - :: ConfiguredProgram - -> Verbosity - -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram - -guessHsc2hsFromGhcjsPath - :: ConfiguredProgram - -> Verbosity - -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram - -guessHaddockFromGhcjsPath - :: ConfiguredProgram - -> Verbosity - -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram - -guessHpcFromGhcjsPath - :: ConfiguredProgram - -> Verbosity - -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram - -guessToolFromGhcjsPath - :: Program - -> ConfiguredProgram - -> Verbosity - -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = - do - let toolname = programName tool - given_path = programPath ghcjsProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcjs dir = - dir - (toolname ++ "-ghcjs") - <.> exeExtension buildPlatform - guessGhcjsVersioned dir suf = - dir - (toolname ++ "-ghcjs" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = - dir - (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf - | null suf = [guessGhcjs dir, guessNormal dir] - | otherwise = - [ guessGhcjsVersioned dir suf - , guessVersioned dir suf - , guessGhcjs dir - , guessNormal dir - ] - guesses = - mkGuesses given_dir given_suf - ++ if real_path == given_path - then [] - else mkGuesses real_dir real_suf - info verbosity $ - "looking for tool " - ++ toolname - ++ " near compiler in " - ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [file | (file, True) <- zip guesses exists] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp : _) -> do - info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = - map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - where - takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg - where - version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents - :: Verbosity - -> Maybe (SymbolicPath CWD (Dir from)) - -> PackageDBX (SymbolicPath from (Dir PkgDB)) - -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity mbWorkDir packagedb progdb = do - pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages - :: Verbosity - -> Maybe (SymbolicPath CWD (Dir from)) - -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity mbWorkDir packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity packagedbs - pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! index - -toPackageIndex - :: Verbosity - -> [(PackageDBX a, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcjsProg - let indices = - [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss - ] - return $! (mconcat indices) - where - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace - `fmap` getDbProgramOutput - verbosity - ghcjsProgram - (withPrograms lbi) - ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcjsProg = - dropWhileEndLE isSpace - `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"] - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace - `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcjsProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getAppUserDataDirectory "ghcjs" - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = - Internal.ghcPlatformAndVersionString - platform - ghcjsVersion - packageConfFileName = "package.conf.d" - ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" - -checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () -checkPackageDbStack _ (GlobalPackageDB : rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack verbosity rest - | GlobalPackageDB `notElem` rest = - dieWithException verbosity GlobalPackageDBLimitation -checkPackageDbStack verbosity _ = - dieWithException verbosity GlobalPackageDBSpecifiedFirst - -getInstalledPackages' - :: Verbosity - -> Maybe (SymbolicPath CWD (Dir from)) - -> [PackageDBX (SymbolicPath from (Dir PkgDB))] - -> ProgramDb - -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])] -getInstalledPackages' verbosity mbWorkDir packagedbs progdb = - sequenceA - [ do - pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs - ] - --- | Get the packages from specific PackageDBs, not cumulative. -getInstalledPackagesMonitorFiles - :: Verbosity - -> Platform - -> Maybe (SymbolicPath CWD (Dir Pkg)) - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform mbWorkDir progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path0 = do - let path = - if isRelative path0 - then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0) - else path0 - isFileStyle <- doesFileExist path - if isFileStyle - then return path - else return (path "package.cache") - - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - -toJSLibName :: String -> String -toJSLibName lib - | takeExtension lib `elem` [".dll", ".dylib", ".so"] = - replaceExtension lib "js_so" - | takeExtension lib == ".a" = replaceExtension lib "js_a" - | otherwise = lib <.> "js_a" - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib - :: Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildLib = buildOrReplLib Nothing - -replLib - :: [String] - -> Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib - :: Maybe [String] - -> Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO () -buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - -- whenGHCiLib = when (withGHCiLib lbi) - forRepl = isJust mReplFlags - -- ifReplLib = when forRepl - comp = compiler lbi - implInfo = getImplInfo comp - platform@(Platform _hostArch _hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - mbWorkDir = mbWorkDirLBI lbi - - -- See Note [Symbolic paths] in Distribution.Utils.Path - i = interpretSymbolicPathLBI lbi - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir - - let libBi = libBuildInfo lib - - -- fixme flags shouldn't depend on ghcjs being dynamic or not - let isGhcjsDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcjsDynamic - forceSharedLib = doingTH && isGhcjsDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir (coerceSymbolicPath libTargetDir coerceSymbolicPath extraCompilationArtifacts) way - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True $ i libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) - jsSrcs = jsSources libBi - cObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - linkJsLibOpts = - mempty - { ghcOptExtra = - [ "-link-js-lib" - , getHSLibraryName uid - , "-js-lib-outputdir" - , getSymbolicPath libTargetDir - ] - ++ foldMap (\e -> getSymbolicPath (extraSourceFile e) : extraSourceOpts e) jsSrcs - } - vanillaOptsNoJsLib = - baseOpts - `mappend` mempty - { ghcOptMode = toFlag GhcModeMake - , ghcOptNumJobs = numJobs - , ghcOptInputModules = toNubListR $ allLibModules lib clbi - , ghcOptHPCDir = hpcdir Hpc.Vanilla - } - vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts - - profOpts = - adjustExts "p_hi" "p_o" vanillaOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptProfilingAuto = - Internal.profDetailLevelFlag - True - (withProfLibDetail lbi) - , -- ghcOptHiSuffix = toFlag "p_hi", - -- ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi - , ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = - adjustExts "dyn_hi" "dyn_o" vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptFPic = toFlag True - , -- ghcOptHiSuffix = toFlag "dyn_hi", - -- ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - - vanillaSharedOpts = - vanillaOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic - , ghcOptDynHiSuffix = toFlag "js_dyn_hi" - , ghcOptDynObjSuffix = toFlag "js_dyn_o" - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ - do - let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) - useDynToo = - dynamicTooSupported - && (forceVanillaLib || withVanillaLib lbi) - && (forceSharedLib || withSharedLib lbi) - && null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcjsProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Flag dynDir, Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir) - _ -> return () - else - if isGhcjsDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcjsProg profOpts) - - -- Build any C++ sources separately. - {- - unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcjsDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcjsProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcjsProg replOpts) - -} - -- build any C sources - -- TODO: Add support for S and CMM files. - {- - unless (not has_code || null (cSources libBi) || not nativeToo) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcjsDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcjsProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] - -} - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - - -- link: - - when has_code . when False {- fixme nativeToo -} . unless forRepl $ do - info verbosity "Linking..." - let cSharedObjs = - map - ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension)) . extraSourceFile) - (cSources libBi ++ cxxSources libBi) - compiler_id = compilerId (compiler lbi) - sharedLibFilePath = libTargetDir makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid) - staticLibFilePath = libTargetDir makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid) - - let stubObjs = [] - stubSharedObjs = [] - - {- - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - -} - hObjs <- - Internal.getHaskellObjects - implInfo - lib - lbi - clbi - (coerceSymbolicPath libTargetDir) - objExtension - True - hSharedObjs <- - if withSharedLib lbi - then - Internal.getHaskellObjects - implInfo - lib - lbi - clbi - (coerceSymbolicPath libTargetDir) - ("dyn_" ++ objExtension) - False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir ) . getSymbolicPath) cObjs - ++ stubObjs - dynamicObjectFiles = - hSharedObjs - ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir ) . getSymbolicPath) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty - { ghcOptShared = toFlag True - , ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptInputFiles = toNubListR dynamicObjectFiles - , ghcOptOutputFile = toFlag sharedLibFilePath - , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi - , -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - {- - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, -} - ghcOptHideAllPackages = toFlag True - , ghcOptNoAutoLinkPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> - toFlag pk - _ -> mempty - , ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty - , ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> - insts - _ -> [] - , ghcOptPackages = - toNubListR $ - Internal.mkGhcOptPackages mempty clbi - , ghcOptLinkLibs = extraLibs libBi - , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi - , ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi - , ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty - { ghcOptStaticLib = toFlag True - , ghcOptInputFiles = toNubListR staticObjectFiles - , ghcOptOutputFile = toFlag staticLibFilePath - , ghcOptExtra = hcStaticOptions GHC libBi - , ghcOptHideAllPackages = toFlag True - , ghcOptNoAutoLinkPackages = toFlag True - , ghcOptPackageDBs = withPackageDB lbi - , ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> - toFlag pk - _ -> mempty - , ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty - , ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> - insts - _ -> [] - , ghcOptPackages = - toNubListR $ - Internal.mkGhcOptPackages mempty clbi - , ghcOptLinkLibs = extraLibs libBi - , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - {- - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - -} - {- - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles - -} - whenSharedLib False $ - runGhcjsProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcjsProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter - :: Verbosity - -> ProgramDb - -> Compiler - -> Platform - -> PackageDBStack - -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = - mempty - { ghcOptMode = toFlag GhcModeInteractive - , ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity packageDBs - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb - runGHC verbosity ghcjsProg comp platform Nothing replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: [String] - -> Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. -buildExe - :: Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: [String] - -> Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode - = GBuildExe Executable - | GReplExe [String] Executable - | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = - let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) - == (Linux, ForeignLibNativeShared) = - let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = - let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [RelativePath Source File] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest - findIsMainArgs (_ : rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower = - -- The arg looked like "Foo.Bar.baz" - Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = - Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = - Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - where - -- 'safeTail' drops the char satisfying 'pred' - (r_suf, r_pre) = break pred' (reverse str) - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources - { cSourcesFiles :: [ExtraSource Pkg] - , cxxSourceFiles :: [ExtraSource Pkg] - , inputSourceFiles :: [SymbolicPath Pkg File] - , inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources - :: Verbosity - -> Maybe (SymbolicPath CWD ('Dir Pkg)) - -> PackageId - -> CabalSpecVersion - -> SymbolicPath Pkg (Dir Source) - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileCwd verbosity mbWorkDir (tmpDir : hsSourceDirs bnfo) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - haskellMain = isHaskell (getSymbolicPath main) - - -- Scripts have fakePackageId and are always Haskell but can have any extension. - if haskellMain || pkgId == fakePackageId - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ - "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return - BuildSources - { cSourcesFiles = cSources bnfo - , cxxSourceFiles = cxxSources bnfo - , inputSourceFiles = [main] - , inputSourceModules = filter (/= mainModName) $ exeModules exe - } - else - return - BuildSources - { cSourcesFiles = cSources bnfo - , cxxSourceFiles = cxxSources bnfo - , inputSourceFiles = [main] - , inputSourceModules = exeModules exe - } - else - let (csf, cxxsf) - | isCxx (getSymbolicPath main) = (cSources bnfo, ExtraSourcePkg main [] : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (ExtraSourcePkg main [] : cSources bnfo, cxxSources bnfo) - in return - BuildSources - { cSourcesFiles = csf - , cxxSourceFiles = cxxsf - , inputSourceFiles = [] - , inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources - { cSourcesFiles = cSources bnfo - , cxxSourceFiles = cxxSources bnfo - , inputSourceFiles = [] - , inputSourceModules = foreignLibModules flib - } - --- | FilePath has a Haskell extension: .hs or .lhs -isHaskell :: FilePath -> Bool -isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - --- | Generic build function. See comment for 'GBuildMode'. -gbuild - :: Verbosity - -> Flag ParStrat - -> PackageDescription - -> LocalBuildInfo - -> GBuildMode - -> ComponentLocalBuildInfo - -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - mbWorkDir = mbWorkDirLBI lbi - runGhcProg = runGHC verbosity ghcjsProg comp platform mbWorkDir - - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - targetDir = buildDir lbi makeRelativePathEx (gbuildName bm) - tmpDir = targetDir makeRelativePathEx (gbuildName bm ++ "-tmp") - - -- See Note [Symbolic paths] in Distribution.Utils.Path - i = interpretSymbolicPath mbWorkDir - - createDirectoryIfMissingVerbose verbosity True $ i targetDir - createDirectoryIfMissingVerbose verbosity True $ i tmpDir - - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = exeCoverage lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir coerceSymbolicPath extraCompilationArtifacts) way - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity mbWorkDir (package pkg_descr) (specVersion pkg_descr) tmpDir bm - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cSrcs - cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension) . extraSourceFile) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - buildRunner = case clbi of - LibComponentLocalBuildInfo{} -> False - FLibComponentLocalBuildInfo{} -> False - ExeComponentLocalBuildInfo{} -> True - TestComponentLocalBuildInfo{} -> True - BenchComponentLocalBuildInfo{} -> True - baseOpts = - (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty - { ghcOptMode = toFlag GhcModeMake - , ghcOptInputFiles = - toNubListR $ - if package pkg_descr == fakePackageId - then filter (isHaskell . getSymbolicPath) inputFiles - else inputFiles - , ghcOptInputScripts = - toNubListR $ - if package pkg_descr == fakePackageId - then filter (not . isHaskell . getSymbolicPath) inputFiles - else [] - , ghcOptInputModules = toNubListR inputModules - , -- for all executable components (exe/test/bench), - -- GHCJS must be passed the "-build-runner" option - ghcOptExtra = - if buildRunner - then ["-build-runner"] - else mempty - } - staticOpts = - baseOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticOnly - , ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = - baseOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptProfilingAuto = - Internal.profDetailLevelFlag - False - (withProfExeDetail lbi) - , ghcOptHiSuffix = toFlag "p_hi" - , ghcOptObjSuffix = toFlag "p_o" - , ghcOptExtra = hcProfOptions GHC bnfo - , ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = - baseOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcDynamicOnly - , -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True - , ghcOptHiSuffix = toFlag "dyn_hi" - , ghcOptObjSuffix = toFlag "dyn_o" - , ghcOptExtra = hcOptions GHC bnfo ++ hcSharedOptions GHC bnfo - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = - staticOpts - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic - , ghcOptDynHiSuffix = toFlag "dyn_hi" - , ghcOptDynObjSuffix = toFlag "dyn_o" - , ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = - mempty - { ghcOptLinkOptions = PD.ldOptions bnfo - , ghcOptLinkLibs = extraLibs bnfo - , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo - , ghcOptLinkFrameworks = - toNubListR $ - map getSymbolicPath $ - PD.frameworks bnfo - , ghcOptLinkFrameworkDirs = - toNubListR $ - PD.extraFrameworkDirs bnfo - , ghcOptInputFiles = - toNubListR - [makeSymbolicPath $ getSymbolicPath tmpDir getSymbolicPath x | x <- cObjs ++ cxxObjs] - } - dynLinkerOpts = - mempty - { ghcOptRPaths = rpaths - } - replOpts = - baseOpts - { ghcOptExtra = - Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty - { ghcOptMode = toFlag GhcModeInteractive - , ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts - | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts - | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = - dynamicTooSupported - && isGhcDynamic - && doingTH - && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts - | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg - compileTHOpts - { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs - } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless - ( (null inputFiles && null inputModules) - || gbuildIsRepl bm - ) - $ runGhcProg - compileOpts - { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs - } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do - let baseCxxOpts = - Internal.componentCxxGhcOptions - verbosity - lbi - bnfo - clbi - tmpDir - filename - vanillaCxxOpts = - if isGhcDynamic - then -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - baseCxxOpts{ghcOptFPic = toFlag True} - else baseCxxOpts - profCxxOpts = - vanillaCxxOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = - vanillaCxxOpts - `mappend` mempty - { ghcOptFPic = toFlag True - , ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts - | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True (i odir) - needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile filename) opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs - ] - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do - let baseCcOpts = - Internal.componentCcGhcOptions - verbosity - lbi - bnfo - clbi - tmpDir - filename - vanillaCcOpts = - if isGhcDynamic - then -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - baseCcOpts{ghcOptFPic = toFlag True} - else baseCcOpts - profCcOpts = - vanillaCcOpts - `mappend` mempty - { ghcOptProfilingMode = toFlag True - } - sharedCcOpts = - vanillaCcOpts - `mappend` mempty - { ghcOptFPic = toFlag True - , ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts - | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True (i odir) - needsRecomp <- checkNeedsRecompilation mbWorkDir (extraSourceFile filename) opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs - ] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = - commonOpts - `mappend` linkerOpts - `mappend` mempty - { ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir makeRelativePathEx targetName - when (compilerVersion comp < mkVersion [7, 7]) $ do - let targetPath = i target - e <- doesFileExist targetPath - when e (removeFile targetPath) - runGhcProg linkOpts{ghcOptOutputFile = toFlag target} - GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = - [ if needDynamic - then - if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else - if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty - { ghcOptLinkNoHsMain = toFlag True - , ghcOptShared = toFlag True - , ghcOptLinkLibs = rtsOptLinkLibs - , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo - , ghcOptFPic = toFlag True - , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ gbuildModDefFiles bm - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - buildFile = targetDir makeRelativePathEx buildName - runGhcProg linkOpts{ghcOptOutputFile = toFlag buildFile} - renameFile (i buildFile) (i targetDir targetName) - -data DynamicRtsInfo = DynamicRtsInfo - { dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo - { statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo - { rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = - RtsInfo - { rtsDynamicInfo = - DynamicRtsInfo - { dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = - StaticRtsInfo - { statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -> SymbolicPath Pkg File - -> GhcOptions - -> IO Bool -checkNeedsRecompilation mbWorkDir filename opts = - i filename `moreRecentFile` oname - where - oname = getObjectFileName mbWorkDir filename opts - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - --- | Finds the object file name of the given source file -getObjectFileName - :: Maybe (SymbolicPath CWD (Dir Pkg)) - -> SymbolicPath Pkg File - -> GhcOptions - -> FilePath -getObjectFileName mbWorkDir filename opts = oname - where - i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - odir = i $ fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - -- NB: the filepath might be absolute, e.g. if it is the path to - -- an autogenerated .hs file. - oname = odir replaceExtension (getSymbolicPath filename) oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths - :: LocalBuildInfo - -> ComponentLocalBuildInfo - -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux = True - supportRPaths Windows = False - supportRPaths OSX = True - supportRPaths FreeBSD = - case compid of - CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True - _ -> False - supportRPaths OpenBSD = False - supportRPaths NetBSD = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Wasi = False - supportRPaths Hurd = True - supportRPaths Haiku = False - supportRPaths (OtherOS _) = False --- Do _not_ add a default case so that we get a warning here when a new OS --- is added. - -getRPaths _ _ = return mempty - --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi{options = filterHcOptions (/= "-threaded") (options bi)} - , hasThreaded (options bi) - ) - where - filterHcOptions - :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs - - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc - --- | Extracts a String representing a hash of the ABI of a built --- library. It can fail if the library has not yet been built. -libAbiHash - :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - mbWorkDir = mbWorkDirLBI lbi - vanillaArgs = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty - { ghcOptMode = toFlag GhcModeAbiHash - , ghcOptInputModules = toNubListR $ exposedModules lib - } - sharedArgs = - vanillaArgs - `mappend` mempty - { ghcOptDynLinkMode = toFlag GhcDynamicOnly - , ghcOptFPic = toFlag True - , ghcOptHiSuffix = toFlag "js_dyn_hi" - , ghcOptObjSuffix = toFlag "js_dyn_o" - , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi - } - profArgs = - vanillaArgs - `mappend` mempty - { ghcOptProfilingMode = toFlag True - , ghcOptProfilingAuto = - Internal.profDetailLevelFlag - True - (withProfLibDetail lbi) - , ghcOptHiSuffix = toFlag "js_p_hi" - , ghcOptObjSuffix = toFlag "js_p_o" - , ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - hash <- - getProgramInvocationOutput - verbosity - =<< ghcInvocation verbosity ghcjsProg comp platform mbWorkDir ghcArgs - return (takeWhile (not . isSpace) hash) - -componentGhcOptions - :: Verbosity - -> LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> SymbolicPath Pkg (Dir build) - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir - in opts - { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi - } - --- ----------------------------------------------------------------------------- --- Installing - --- | Install executables for GHCJS. -installExe - :: Verbosity - -> LocalBuildInfo - -> FilePath - -- ^ Where to copy the files to - -> FilePath - -- ^ Build location - -> (FilePath, FilePath) - -- ^ Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe - verbosity - lbi - binDir - buildPref - (progprefix, progsuffix) - _pkg - exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeName' - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - runDbProgramCwd verbosity (mbWorkDirLBI lbi) ghcjsProgram (withPrograms lbi) $ - [ "--install-executable" - , buildPref exeName' exeFileName - , "-o" - , dest - ] - ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of - (True, Just strip) -> ["-strip-program", programPath strip] - _ -> [] - installBinary (binDir fixedExeBaseName) - --- | Install foreign library for GHC. -installFLib - :: Verbosity - -> LocalBuildInfo - -> FilePath - -- ^ install location - -> FilePath - -- ^ Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install - (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install _isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - installOrdinaryFile verbosity src dst - --- | Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib - :: Verbosity - -> LocalBuildInfo - -> FilePath - -- ^ install location - -> FilePath - -- ^ install location for dynamic libraries - -> FilePath - -- ^ Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do - whenVanilla $ copyModuleFiles $ Suffix "js_hi" - whenProf $ copyModuleFiles $ Suffix "js_p_hi" - whenShared $ copyModuleFiles $ Suffix "js_dyn_hi" - - -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName - -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName - -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName - -- fixme do these make the correct lib names? - whenHasCode $ do - whenVanilla $ do - sequence_ - [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib)) - , f <- "" : extraLibFlavours (libBuildInfo lib) - ] - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) - whenProf $ do - installOrdinary builtDir' targetDir (toJSLibName profileLibName) - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) - whenShared $ - sequence_ - [ installShared - builtDir' - dynlibTargetDir - (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "" : extraDynLibFlavours (libBuildInfo lib) - ] - where - i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path - builtDir' = componentBuildDir lbi clbi - mbWorkDir = mbWorkDirLBI lbi - - install isShared isJS srcDir dstDir name = do - let src = i $ srcDir makeRelativePathEx name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi && not isJS) $ - Strip.stripLib - verbosity - (hostPlatform lbi) - (withPrograms lbi) - dst - - installOrdinary = install False True - installShared = install True True - - copyModuleFiles ext = do - files <- findModuleFilesCwd verbosity mbWorkDir [builtDir'] [ext] (allLibModules lib clbi) - let files' = map (i *** getSymbolicPath) files - installOrdinaryFiles verbosity targetDir files' - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - -- vanillaLibName = mkLibName uid - profileLibName = mkProfLibName uid - -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid - - hasLib = - not $ - null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (jsSources (libBuildInfo lib)) - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - -adjustExts :: String -> String -> GhcOptions -> GhcOptions -adjustExts hiSuf objSuf opts = - opts - `mappend` mempty - { ghcOptHiSuffix = toFlag hiSuf - , ghcOptObjSuffix = toFlag objSuf - } - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else "" - -findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsGhcVersion verbosity pgm = - findProgramVersion "--numeric-ghc-version" id verbosity pgm - -findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsPkgGhcjsVersion verbosity pgm = - findProgramVersion "--numeric-ghcjs-version" id verbosity pgm - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = - HcPkg.HcPkgInfo - { HcPkg.hcPkgProgram = ghcjsPkgProg - , HcPkg.noPkgDbStack = False - , HcPkg.noVerboseFlag = False - , HcPkg.flagPackageConf = False - , HcPkg.supportsDirDbs = True - , HcPkg.requiresDirDbs = ver >= v7_10 - , HcPkg.nativeMultiInstance = ver >= v7_10 - , HcPkg.recacheMultiInstance = True - , HcPkg.suppressFilesCheck = True - } - where - v7_10 = mkVersion [7, 10] - ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb - ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg - -registerPackage - :: Verbosity - -> ProgramDb - -> Maybe (SymbolicPath CWD (Dir from)) - -> PackageDBStackS from - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions = - HcPkg.register - (hcPkgInfo progdb) - verbosity - mbWorkDir - packageDbs - installedPkgInfo - registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) - pkgRoot' UserPackageDB = do - appDir <- getAppUserDataDirectory "ghcjs" - -- fixme correct this version - let ver = compilerVersion (compiler lbi) - subdir = - System.Info.arch - ++ '-' - : System.Info.os - ++ '-' - : prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = - return $ - takeDirectory $ - interpretSymbolicPathLBI lbi fp - --- | Get the JavaScript file name and command and arguments to run a --- program compiled by GHCJS --- the exe should be the base program name without exe extension -runCmd - :: ProgramDb - -> FilePath - -> (FilePath, FilePath, [String]) -runCmd progdb exe = - ( script - , programPath ghcjsProg - , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] - ) - where - script = exe <.> "jsexe" "all" <.> "js" - ghcjsProg = fromMaybe (error "GHCJS.runCmd: no ghcjs program") $ lookupProgram ghcjsProgram progdb diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index b24ee8da5af..a79e43a305e 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/Cabal/src/Distribution/Simple/Haddock.hs @@ -36,7 +36,6 @@ import Distribution.Compat.Prelude import Prelude () import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -- local @@ -652,11 +651,10 @@ componentGhcOptions componentGhcOptions verbosity lbi bi clbi odir = let f = case compilerFlavor (compiler lbi) of GHC -> GHC.componentGhcOptions - GHCJS -> GHCJS.componentGhcOptions _ -> error $ "Distribution.Simple.Haddock.componentGhcOptions:" - ++ "haddock only supports GHC and GHCJS" + ++ "haddock only supports GHC" in f verbosity lbi bi clbi odir {- @@ -1036,7 +1034,6 @@ getGhcLibDir getGhcLibDir verbosity lbi = do l <- case compilerFlavor (compiler lbi) of GHC -> GHC.getLibDir verbosity lbi - GHCJS -> GHCJS.getLibDir verbosity lbi _ -> error "haddock only supports GHC and GHCJS" return $ mempty{argGhcLibDir = Flag l} diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs index 36452b57c56..823eb81ff16 100644 --- a/Cabal/src/Distribution/Simple/Install.hs +++ b/Cabal/src/Distribution/Simple/Install.hs @@ -73,7 +73,6 @@ import Distribution.Utils.Path import Distribution.Compat.Graph (IsNode (..)) import Distribution.Simple.Errors import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS import Distribution.Simple.Setup.Common import System.Directory @@ -245,7 +244,6 @@ copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do case compilerFlavor (compiler lbi) of GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do @@ -260,7 +258,6 @@ copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do case compilerFlavor (compiler lbi) of GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest @@ -292,7 +289,6 @@ copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do ) case compilerFlavor (compiler lbi) of GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index 274e6466834..6916ebcf77d 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -197,7 +197,7 @@ defaultInstallDirs' True comp userInstall hasLibs = do { datasubdir = toPathTemplate $ "$abi" "$libname" , docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" } -defaultInstallDirs' False comp userInstall _hasLibs = do +defaultInstallDirs' False _comp userInstall _hasLibs = do installPrefix <- if userInstall then do diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 4db235065c7..4055e9e3caf 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/Cabal/src/Distribution/Simple/PreProcess.hs @@ -406,7 +406,6 @@ ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> ppCpp' extraArgs bi lbi clbi = case compilerFlavor (compiler lbi) of GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi - GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi _ -> ppCpphs args bi lbi clbi where cppArgs = getCppOptions bi lbi @@ -644,7 +643,6 @@ ppHsc2hs bi lbi clbi = isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True packageHacks = case compilerFlavor (compiler lbi) of GHC -> hackRtsPackage - GHCJS -> hackRtsPackage _ -> id -- We don't link in the actual Haskell libraries of our dependencies, so -- the -u flags in the ldOptions of the rts package mean linking fails on @@ -746,23 +744,11 @@ platformDefines lbi = ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - GHCJS -> - compatGlasgowHaskell - ++ ["-D__GHCJS__=" ++ versionInt version] - ++ ["-D" ++ os ++ "_BUILD_OS=1"] - ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] - ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr - ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr _ -> [] where comp = compiler lbi Platform hostArch hostOS = hostPlatform lbi version = compilerVersion comp - compatGlasgowHaskell = - maybe - [] - (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) - (compilerCompatVersion GHC comp) -- TODO: move this into the compiler abstraction -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all -- the other compilers. Check if that's really what they want. @@ -832,7 +818,6 @@ ppHappy _ lbi _ = pp{platformIndependent = True} pp = standardPP lbi happyProgram (hcFlags hc) hc = compilerFlavor (compiler lbi) hcFlags GHC = ["-agc"] - hcFlags GHCJS = ["-agc"] hcFlags _ = [] ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor @@ -841,7 +826,6 @@ ppAlex _ lbi _ = pp{platformIndependent = True} pp = standardPP lbi alexProgram (hcFlags hc) hc = compilerFlavor (compiler lbi) hcFlags GHC = ["-g"] - hcFlags GHCJS = ["-g"] hcFlags _ = [] standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs index 17bc27f151c..aad82d5b9db 100644 --- a/Cabal/src/Distribution/Simple/Program/GHC.hs +++ b/Cabal/src/Distribution/Simple/Program/GHC.hs @@ -90,16 +90,11 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs checkComponentFlags getInfo = foldMap (checkComponent . getInfo) where checkComponent :: BuildInfo -> m - checkComponent = foldMap fun . filterGhcOptions . allGhcOptions + checkComponent = foldMap fun . allGhcOptions - allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] - allGhcOptions = - foldMap - (perCompilerFlavorToList .) - [options, profOptions, sharedOptions, staticOptions] - - filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] - filterGhcOptions l = [opts | (GHC, opts) <- l] + allGhcOptions :: BuildInfo -> [[String]] + allGhcOptions bi = + [options bi, profOptions bi, sharedOptions bi, staticOptions bi] safeToFilterWarnings :: Bool safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings @@ -738,10 +733,10 @@ ghcInvocation verbosity ghcProg comp platform mbWorkDir opts = do renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts - | compilerFlavor comp `notElem` [GHC, GHCJS] = + | compilerFlavor comp `notElem` [GHC] = error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + ++ "compiler flavor must be 'GHC'!" | otherwise = concat [ case flagToMaybe (ghcOptMode opts) of diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index d02112171a5..a9821503d08 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -58,7 +58,6 @@ import Distribution.Simple.BuildTarget import Distribution.Simple.LocalBuildInfo import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.PackageIndex as Index import Distribution.Backpack.DescribeUnitId @@ -313,8 +312,6 @@ abiHash verbosity pkg distPref lbi lib clbi = case compilerFlavor comp of GHC -> do fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi - GHCJS -> do - fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi _ -> return (mkAbiHash "") where comp = compiler lbi @@ -364,7 +361,6 @@ createPackageDB createPackageDB verbosity comp progdb preferCompat dbPath = case compilerFlavor comp of GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath - GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool @@ -413,7 +409,6 @@ withHcPkg withHcPkg verbosity name comp progdb f = case compilerFlavor comp of GHC -> f (GHC.hcPkgInfo progdb) - GHCJS -> f (GHCJS.hcPkgInfo progdb) _ -> dieWithException verbosity $ WithHcPkg name registerPackage @@ -428,7 +423,6 @@ registerPackage registerPackage verbosity comp progdb mbWorkDir packageDbs installedPkgInfo registerOptions = case compilerFlavor comp of GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions - GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions _ | HcPkg.registerMultiInstance registerOptions -> dieWithException verbosity RegisMultiplePkgNotSupported @@ -743,4 +737,4 @@ unregScriptFileName = case buildOS of _ -> "unregister.sh" internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB) -internalPackageDBPath lbi distPref = distPref makeRelativePathEx "package.conf.inplace" +internalPackageDBPath _lbi distPref = distPref makeRelativePathEx "package.conf.inplace" diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 37a0fa4b084..8cc041be852 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -436,7 +436,6 @@ configureOptions showOrParseArgs = (\v flags -> flags{configHcFlavor = v}) ( choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") - , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS") ] ) , option diff --git a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs index ac83518aa38..93cf85c2b70 100644 --- a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs +++ b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs @@ -201,7 +201,6 @@ getCompilerArgs getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of GHC -> ([], ghcArgs) - GHCJS -> ([], ghcArgs) c -> ( [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build " diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index e20df89abb6..0465d81f24f 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -1310,7 +1310,7 @@ getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO ( getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do envFileExists <- doesFileExist envFile (usedExisting, allEntries) <- - if (compilerFlavor == GHC || compilerFlavor == GHCJS) + if (compilerFlavor == GHC) && supportsPkgEnvFiles && envFileExists then catch ((True,) <$> readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> diff --git a/cabal-install/src/Distribution/Client/CmdPath.hs b/cabal-install/src/Distribution/Client/CmdPath.hs index a80a772ad5f..7e98c93b193 100644 --- a/cabal-install/src/Distribution/Client/CmdPath.hs +++ b/cabal-install/src/Distribution/Client/CmdPath.hs @@ -303,7 +303,6 @@ requireCompilerProg :: Verbosity -> Compiler -> IO Program requireCompilerProg verbosity compiler = case compilerFlavor compiler of GHC -> pure ghcProgram - GHCJS -> pure ghcjsProgram flavour -> die' verbosity $ "path: Unsupported compiler flavour: " diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 9e71be71140..4048e5213fd 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -913,8 +913,7 @@ argsEquivalentOfGhcEnvironmentFile argsEquivalentOfGhcEnvironmentFile compiler = case compilerId compiler of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc - CompilerId _ _ -> error "Only GHC and GHCJS are supported" + CompilerId _ _ -> error "Only GHC is supported" -- TODO remove this when we drop support for non-.ghc.env ghc argsEquivalentOfGhcEnvironmentFileGhc diff --git a/cabal-install/src/Distribution/Client/Run.hs b/cabal-install/src/Distribution/Client/Run.hs index baa6264abe4..38af56dc11e 100644 --- a/cabal-install/src/Distribution/Client/Run.hs +++ b/cabal-install/src/Distribution/Client/Run.hs @@ -30,7 +30,6 @@ import Distribution.PackageDescription import Distribution.Simple (PackageDBX (..)) import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths (exeExtension) -import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor) import Distribution.Simple.Flag (fromFlag) import Distribution.Simple.LocalBuildInfo ( ComponentName (..) @@ -57,8 +56,6 @@ import Distribution.Simple.Utils import Distribution.System (Platform (..)) import Distribution.Types.UnqualComponentName -import qualified Distribution.Simple.GHCJS as GHCJS - import Distribution.Client.Errors import Distribution.Utils.Path @@ -165,19 +162,11 @@ run verbosity lbi exe exeArgs = do (path, runArgs) <- let exeName' = prettyShow $ exeName exe - in case compilerFlavor (compiler lbiForExe) of - GHCJS -> do - let (script, cmd, cmdArgs) = - GHCJS.runCmd - (withPrograms lbiForExe) - (i buildPref exeName' exeName') - script' <- tryCanonicalizePath script - return (cmd, cmdArgs ++ [script']) - _ -> do - p <- - tryCanonicalizePath $ - i buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbiForExe)) - return (p, []) + in do + p <- + tryCanonicalizePath $ + i buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbiForExe)) + return (p, []) -- Compute the appropriate environment for running the executable let progDb = withPrograms lbiForExe diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 8c54f093007..fd2a0b46cfd 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -90,10 +90,6 @@ import Distribution.Client.Types , PackageSpecifier (..) , UnresolvedSourcePackage ) -import Distribution.Compiler - ( CompilerId (..) - , perCompilerFlavorToList - ) import Distribution.FieldGrammar ( parseFieldGrammar , takeFields @@ -395,7 +391,7 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just - & L.buildInfo . L.options %~ fmap (setExePath exePathRel) + & L.buildInfo . L.options %~ setExePath exePathRel createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) @@ -590,14 +586,11 @@ fakeProjectSourcePackage projectRoot = sourcePackage -- | Find the path of an exe that has been relocated with a "-o" option movedExePath :: UnqualComponentName -> DistDirLayout -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> Maybe FilePath -movedExePath selectedComponent distDirLayout elabShared elabConfigured = do +movedExePath selectedComponent distDirLayout _1elabShared elabConfigured = do exe <- find ((== selectedComponent) . exeName) . executables $ elabPkgDescription elabConfigured - let CompilerId flavor _ = compilerId toolchainCompiler - opts <- lookup flavor (perCompilerFlavorToList . options $ buildInfo exe) + opts <- Just (options $ buildInfo exe) let projectRoot = distProjectRootDirectory distDirLayout fmap (projectRoot ) . lookup "-o" $ reverse (zip opts (drop 1 opts)) - where - Toolchain{..} = getStage (pkgConfigToolchains elabShared) (elabStage elabConfigured) -- Lenses diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 87301412b7b..b343680754d 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -78,7 +78,6 @@ import Distribution.Simple.Program , getDbProgramOutputCwd , getProgramSearchPath , ghcProgram - , ghcjsProgram , runDbProgramCwd ) import Distribution.Simple.Program.Db @@ -1044,21 +1043,20 @@ getExternalSetupMethod verbosity options pkg bt = do True createDirectoryIfMissingVerbose verbosity True setupCacheDir installExecutableFile verbosity src cachedSetupProgFile - -- Do not strip if we're using GHCJS, since the result may be a script - when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $ do - -- Add the relevant PATH overrides for the package to the - -- program database. + + -- Add the relevant PATH overrides for the package to the + -- program database. + setupProgDb + <- prependProgramSearchPath verbosity + (useExtraPathEnv options) + (useExtraEnvOverrides options) + (useProgramDb options') + >>= configureAllKnownPrograms verbosity + Strip.stripExe + verbosity + platform setupProgDb - <- prependProgramSearchPath verbosity - (useExtraPathEnv options) - (useExtraEnvOverrides options) - (useProgramDb options') - >>= configureAllKnownPrograms verbosity - Strip.stripExe - verbosity - platform - setupProgDb - cachedSetupProgFile + cachedSetupProgFile return cachedSetupProgFile where criticalSection' = maybe id criticalSection $ setupCacheLock options' @@ -1086,7 +1084,6 @@ getExternalSetupMethod verbosity options pkg bt = do let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion (program, extraOpts) = case compilerFlavor compiler of - GHCJS -> (ghcjsProgram, ["-build-runner"]) _ -> (ghcProgram, ["-threaded"]) cabalDep = maybe From 9d458f8f92fb6e3cddb93c5ed59f6f1e8ce4775c Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 19 Nov 2025 11:39:27 +0800 Subject: [PATCH 077/122] refactor: remove support for JHC --- Cabal-syntax/src/Distribution/Compiler.hs | 3 +-- Cabal/src/Distribution/Simple/Build.hs | 1 - Cabal/src/Distribution/Simple/Program.hs | 1 - Cabal/src/Distribution/Simple/Program/Builtin.hs | 14 -------------- 4 files changed, 1 insertion(+), 18 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 406cbcb55f0..88664a799c2 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -69,7 +69,6 @@ data CompilerFlavor | Hugs | HBC | Helium - | JHC | LHC | Eta | -- | @since 3.12.1.0 @@ -84,7 +83,7 @@ instance NFData CompilerFlavor where rnf = genericRnf knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, Eta, MHS] + [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, LHC, Eta, MHS] instance Pretty CompilerFlavor where pretty (OtherCompiler name) = Disp.text name diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs index 413002adcab..3040762ddb5 100644 --- a/Cabal/src/Distribution/Simple/Build.hs +++ b/Cabal/src/Distribution/Simple/Build.hs @@ -313,7 +313,6 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do flavorToProgram :: CompilerFlavor -> Maybe Program flavorToProgram GHC = Just ghcProgram flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram JHC = Just jhcProgram flavorToProgram _ = Nothing repl diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index c5c410a8589..0609d17c613 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -111,7 +111,6 @@ module Distribution.Simple.Program , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram - , jhcProgram , gccProgram , gppProgram , arProgram diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs index e58a8348ea1..6425945991f 100644 --- a/Cabal/src/Distribution/Simple/Program/Builtin.hs +++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs @@ -20,7 +20,6 @@ module Distribution.Simple.Program.Builtin , runghcProgram , ghcjsProgram , ghcjsPkgProgram - , jhcProgram , gccProgram , gppProgram , arProgram @@ -70,7 +69,6 @@ builtinPrograms = , ghcPkgProgram , ghcjsProgram , ghcjsPkgProgram - , jhcProgram , hpcProgram , -- preprocessors hscolourProgram @@ -173,18 +171,6 @@ ghcjsPkgProgram = _ -> "" } -jhcProgram :: Program -jhcProgram = - (simpleProgram "jhc") - { programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_ : ver : _) -> ver - _ -> "" - } - hpcProgram :: Program hpcProgram = (simpleProgram "hpc") From c91782503fd5e1e06bd4e4a4b81177ee2545f8f6 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 19 Nov 2025 11:35:49 +0800 Subject: [PATCH 078/122] refactor: remove support for NHC, YHC, Hugs, HBC, Helium, Eta The is no support other than knowledge of their (past) existence --- Cabal-syntax/src/Distribution/Compiler.hs | 56 ++--------------------- 1 file changed, 3 insertions(+), 53 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 406cbcb55f0..4805af869d8 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -34,10 +34,6 @@ module Distribution.Compiler , classifyCompilerFlavor , knownCompilerFlavors - -- * Per compiler flavor - , PerCompilerFlavor (..) - , perCompilerFlavorToList - -- * Compiler id , CompilerId (..) @@ -64,14 +60,8 @@ import qualified Text.PrettyPrint as Disp data CompilerFlavor = GHC | GHCJS - | NHC - | YHC - | Hugs - | HBC - | Helium | JHC | LHC - | Eta | -- | @since 3.12.1.0 -- MicroHS, see https://github.com/augustss/MicroHs MHS @@ -84,11 +74,10 @@ instance NFData CompilerFlavor where rnf = genericRnf knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, Eta, MHS] + [GHC, GHCJS, JHC, LHC, MHS] instance Pretty CompilerFlavor where pretty (OtherCompiler name) = Disp.text name - pretty NHC = Disp.text "nhc98" pretty other = Disp.text (lowercase (show other)) instance Parsec CompilerFlavor where @@ -126,48 +115,9 @@ defaultCompilerFlavor = case buildCompilerFlavor of OtherCompiler _ -> Nothing _ -> Just buildCompilerFlavor -------------------------------------------------------------------------------- --- Per compiler data -------------------------------------------------------------------------------- - --- | 'PerCompilerFlavor' carries only info per GHC and GHCJS --- --- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. -data PerCompilerFlavor v = PerCompilerFlavor v v - deriving - ( Generic - , Show - , Read - , Eq - , Ord - , Data - , Functor - , Foldable - , Traversable - ) - -instance Binary a => Binary (PerCompilerFlavor a) -instance Structured a => Structured (PerCompilerFlavor a) -instance NFData a => NFData (PerCompilerFlavor a) - -perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] -perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] - -instance Semigroup a => Semigroup (PerCompilerFlavor a) where - PerCompilerFlavor a b <> PerCompilerFlavor a' b' = - PerCompilerFlavor - (a <> a') - (b <> b') - -instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where - mempty = PerCompilerFlavor mempty mempty - mappend = (<>) - --- ------------------------------------------------------------ - +-------------------------------------------------------------- -- * Compiler Id - --- ------------------------------------------------------------ +-------------------------------------------------------------- data CompilerId = CompilerId CompilerFlavor Version deriving (Eq, Generic, Ord, Read, Show) From c45f2b608e82536fac6c7cadd0bb00ed06771105 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 1 Sep 2022 12:47:29 +0200 Subject: [PATCH 079/122] refactor: remove support for LHC --- Cabal-syntax/src/Distribution/Compiler.hs | 3 +-- Cabal/src/Distribution/Simple/Program/Script.hs | 2 +- doc/cabal-package-description-file.rst | 5 ++--- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs index 406cbcb55f0..ca81d444f9e 100644 --- a/Cabal-syntax/src/Distribution/Compiler.hs +++ b/Cabal-syntax/src/Distribution/Compiler.hs @@ -70,7 +70,6 @@ data CompilerFlavor | HBC | Helium | JHC - | LHC | Eta | -- | @since 3.12.1.0 -- MicroHS, see https://github.com/augustss/MicroHs @@ -84,7 +83,7 @@ instance NFData CompilerFlavor where rnf = genericRnf knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, Eta, MHS] + [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, Eta, MHS] instance Pretty CompilerFlavor where pretty (OtherCompiler name) = Disp.text name diff --git a/Cabal/src/Distribution/Simple/Program/Script.hs b/Cabal/src/Distribution/Simple/Program/Script.hs index f89db34306e..1cb79ade764 100644 --- a/Cabal/src/Distribution/Simple/Program/Script.hs +++ b/Cabal/src/Distribution/Simple/Program/Script.hs @@ -10,7 +10,7 @@ -- Portability : portable -- -- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and LHC have hc-pkg programs. +-- Currently only GHC has hc-pkg programs. module Distribution.Simple.Program.Script ( invocationAsSystemScript , invocationAsShellScript diff --git a/doc/cabal-package-description-file.rst b/doc/cabal-package-description-file.rst index 1193f546a05..1313e401b37 100644 --- a/doc/cabal-package-description-file.rst +++ b/doc/cabal-package-description-file.rst @@ -264,9 +264,8 @@ The syntax of the value depends on the field. Field types include: *identifier* A letter followed by zero or more alphanumerics or underscores. *compiler* - A compiler flavor (``GHC`` or ``LHC``) - followed by a version range. For example, ``GHC ==6.10.3``, or - ``LHC >=0.6 && <0.8``. + A compiler flavor (``GHC`` or ``MHS``) + followed by a version range. For example, ``GHC ==6.10.3``. Modules and preprocessors ^^^^^^^^^^^^^^^^^^^^^^^^^ From 56b5dfcea56012773211aa652982e777fcff37c0 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Fri, 21 Nov 2025 12:31:14 +0800 Subject: [PATCH 080/122] remove libraryDynDirSupported --- Cabal/src/Distribution/Simple/Compiler.hs | 15 --------------- Cabal/src/Distribution/Simple/Register.hs | 4 +--- 2 files changed, 1 insertion(+), 18 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs index 8b88493abf6..a2f8d17710c 100644 --- a/Cabal/src/Distribution/Simple/Compiler.hs +++ b/Cabal/src/Distribution/Simple/Compiler.hs @@ -82,7 +82,6 @@ module Distribution.Simple.Compiler , backpackSupported , arResponseFilesSupported , arDashLSupported - , libraryDynDirSupported , libraryVisibilitySupported , jsemSupported , reexportedAsSupported @@ -476,20 +475,6 @@ reexportedAsSupported comp = case compilerFlavor comp of where v = compilerVersion comp --- | Does this compiler support a package database entry with: --- "dynamic-library-dirs"? -libraryDynDirSupported :: Compiler -> Bool -libraryDynDirSupported comp = case compilerFlavor comp of - GHC -> - -- Not just v >= mkVersion [8,0,1,20161022], as there - -- are many GHC 8.1 nightlies which don't support this. - ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1]) - || v >= mkVersion [8, 1, 20161021] - ) - _ -> False - where - v = compilerVersion comp - -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). arResponseFilesSupported :: Compiler -> Bool diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs index be438be7f39..255b510f497 100644 --- a/Cabal/src/Distribution/Simple/Register.hs +++ b/Cabal/src/Distribution/Simple/Register.hs @@ -569,12 +569,10 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi -- the dynamic-library-dirs defaults to the library-dirs if not specified, -- so this works whether the dynamic-library-dirs field is supported or not - | libraryDynDirSupported comp = + | otherwise = ( libdir installDirs : extraLibDirs' , dynlibdir installDirs : extraLibDirs' ) - | otherwise = - (libdir installDirs : dynlibdir installDirs : extraLibDirs', []) expectLibraryComponent (Just attribute) = attribute expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.") From 8b581ae868463a22f1e4176f4db7423810541daa Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 11:31:07 +0800 Subject: [PATCH 081/122] refactor: remove sanityCheckElaboratedConfiguredPackage --- .../Distribution/Client/ProjectPlanning.hs | 89 +------------------ 1 file changed, 1 insertion(+), 88 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 4d17c8821ae..3d99aa219ac 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -248,89 +248,6 @@ import System.Directory (getCurrentDirectory) import System.FilePath import qualified Text.PrettyPrint as Disp --- | Check that an 'ElaboratedConfiguredPackage' actually makes --- sense under some 'ElaboratedSharedConfig'. -sanityCheckElaboratedConfiguredPackage - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a -sanityCheckElaboratedConfiguredPackage - sharedConfig - elab@ElaboratedConfiguredPackage{..} = - ( case elabPkgOrComp of - ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg - ElabComponent comp -> sanityCheckElaboratedComponent elab comp - ) - -- The assertion below fails occasionally for unknown reason - -- so it was muted until we figure it out, otherwise it severely - -- hinders our ability to share and test development builds of cabal-install. - -- Tracking issue: https://github.com/haskell/cabal/issues/6006 - -- - -- either a package is being built inplace, or the - -- 'installedPackageId' we assigned is consistent with - -- the 'hashedInstalledPackageId' we would compute from - -- the elaborated configured package - . assert - ( isInplaceBuildStyle elabBuildStyle - || elabComponentId - == hashedInstalledPackageId - (packageHashInputs sharedConfig elab) - ) - -- the stanzas explicitly disabled should not be available - . assert - ( optStanzaSetNull $ - optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable - ) - -- either a package is built inplace, or we are not attempting to - -- build any test suites or benchmarks (we never build these - -- for remote packages!) - . assert - ( isInplaceBuildStyle elabBuildStyle - || optStanzaSetNull elabStanzasAvailable - ) - -sanityCheckElaboratedComponent - :: ElaboratedConfiguredPackage - -> ElaboratedComponent - -> a - -> a -sanityCheckElaboratedComponent - ElaboratedConfiguredPackage{..} - ElaboratedComponent{..} = - -- Should not be building bench or test if not inplace. - assert - ( isInplaceBuildStyle elabBuildStyle - || case compComponentName of - Nothing -> True - Just (CLibName _) -> True - Just (CExeName _) -> True - -- This is interesting: there's no way to declare a dependency - -- on a foreign library at the moment, but you may still want - -- to install these to the store - Just (CFLibName _) -> True - Just (CBenchName _) -> False - Just (CTestName _) -> False - ) - -sanityCheckElaboratedPackage - :: ElaboratedConfiguredPackage - -> ElaboratedPackage - -> a - -> a -sanityCheckElaboratedPackage - ElaboratedConfiguredPackage{..} - ElaboratedPackage{..} = - -- we should only have enabled stanzas that actually can be built - -- (according to the solver) - assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable) - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert - ( optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested - `optStanzaSetIsSubset` pkgStanzasEnabled - ) - -- $readingTheProjectConfiguration -- -- The project configuration is assembled into a ProjectConfig as follows: @@ -4154,11 +4071,7 @@ setupHsConfigureFlags -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions configPackageDBs <- (traverse . traverse . traverse) mkSymbolicPath (Nothing : map Just elabBuildPackageDBStack) - return $ - sanityCheckElaboratedConfiguredPackage - sharedConfig - elab - Cabal.ConfigFlags{..} + return Cabal.ConfigFlags{..} where Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage From 33fb14950057796821ced07d8cc9997c97459e48 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 15:35:59 +0800 Subject: [PATCH 082/122] make createDirectoryIfMissingVerbose spam less --- Cabal/src/Distribution/Simple/Utils.hs | 39 +++----------------------- 1 file changed, 4 insertions(+), 35 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 5d0f5c7847d..204f3b1dac7 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -253,6 +253,7 @@ import Numeric (showFFloat) import System.Directory ( Permissions (executable) , createDirectory + , createDirectoryIfMissing , doesDirectoryExist , doesFileExist , getDirectoryContents @@ -269,7 +270,6 @@ import System.FilePath (takeFileName) import System.FilePath as FilePath ( getSearchPath , joinPath - , normalise , searchPathSeparator , splitDirectories , splitExtension @@ -1587,40 +1587,9 @@ createDirectoryIfMissingVerbose -- ^ Create its parents too? -> FilePath -> IO () -createDirectoryIfMissingVerbose verbosity create_parents path0 - | create_parents = withFrozenCallStack $ createDirs (parents path0) - | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . normalise - - createDirs [] = return () - createDirs (dir : []) = createDir dir throwIO - createDirs (dir : dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir throwIO - - createDir :: FilePath -> (IOException -> IO ()) -> IO () - createDir dir notExistHandler = do - r <- tryIO $ createDirectoryVerbose verbosity dir - case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e - -- createDirectory (and indeed POSIX mkdir) does not distinguish - -- between a dir already existing and a file already existing. So we - -- check for it here. Unfortunately there is a slight race condition - -- here, but we think it is benign. It could report an exception in - -- the case that the dir did exist but another process deletes the - -- directory and creates a file in its place before we can check - -- that the directory did indeed exist. - | isAlreadyExistsError e -> - ( do - isDir <- doesDirectoryExist dir - unless isDir $ throwIO e - ) - `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIO e +createDirectoryIfMissingVerbose verbosity create_parents dir = withFrozenCallStack $ do + info verbosity $ "creating directory " ++ dir + createDirectoryIfMissing create_parents dir createDirectoryVerbose :: Verbosity -> FilePath -> IO () createDirectoryVerbose verbosity dir = withFrozenCallStack $ do From 33a13856069a486dceb7dd649c086155ea1a56a4 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 8 Dec 2025 16:54:04 +0800 Subject: [PATCH 083/122] remove some useless asserts --- .../src/Distribution/Client/ProjectBuilding.hs | 10 ++-------- .../Client/ProjectBuilding/UnpackedPackage.hs | 10 +++------- 2 files changed, 5 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index e929f4fa32a..474364f3bc3 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -49,7 +49,6 @@ import Distribution.Client.ProjectBuilding.Types import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types import Distribution.Client.Store import Distribution.Client.DistDirLayout @@ -86,7 +85,7 @@ import qualified Data.Set as Set import qualified Text.PrettyPrint as Disp -import Control.Exception (assert, handle) +import Control.Exception (handle) import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), ()) import System.Semaphore (SemaphoreName (..)) @@ -588,12 +587,7 @@ rebuildTarget rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult rebuildPhase buildStatus srcdir = do info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir - assert - (isInplaceBuildStyle $ elabBuildStyle pkg) - buildInplace - buildStatus - srcdir - builddir + buildInplace buildStatus srcdir builddir where distdir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) builddir = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 4b53d401b1d..426f505c6af 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -104,7 +104,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 import qualified Data.List.NonEmpty as NE -import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, assert, catches, onException) +import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, catches, onException) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile) import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) import System.IO (Handle, IOMode (AppendMode), withFile) @@ -720,17 +720,13 @@ buildAndInstallUnpackedPackage debug verbosity $ "registerPkg: elab does NOT require registration for " ++ prettyShow uid - | otherwise = do - let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout toolchainCompiler] - assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) - _ <- - runRegister + | otherwise = + void $ runRegister (elabRegisterPackageDBStack pkg) Cabal.defaultRegisterOptions { Cabal.registerMultiInstance = True , Cabal.registerSuppressFilesCheck = True } - return () -- Actual installation void $ From 7cf08965eccb6c59c482baa0b8bb22ff43407957 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 15:35:59 +0800 Subject: [PATCH 084/122] remove lukko --- cabal-install/cabal-install.cabal | 9 ---- .../src/Distribution/Client/Store.hs | 48 +++---------------- 2 files changed, 7 insertions(+), 50 deletions(-) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 3dddb14bb50..8a2d70eda84 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -34,11 +34,6 @@ Flag native-dns default: True manual: True -Flag lukko - description: Use @lukko@ for file-locking - default: False - manual: False - flag git-rev description: include Git revision hash in version default: False @@ -290,10 +285,6 @@ library build-depends: , unix >= 2.5 && < 2.8 || >= 2.8.6.0 && < 2.9 - if flag(lukko) - build-depends: - , lukko >= 0.1 && <0.2 - -- pull in process version with fixed waitForProcess error if impl(ghc >=8.2) build-depends: diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index 4bcb5d75949..f875b41b8e6 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -43,12 +43,8 @@ import qualified Data.Set as Set import System.Directory import System.FilePath -#ifdef MIN_VERSION_lukko -import Lukko -#else import System.IO (openFile, IOMode(ReadWriteMode), hClose) import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock) -#endif -- $concurrency -- @@ -197,17 +193,13 @@ newStoreEntry exists <- doesStoreEntryExist storeDirLayout compiler unitid if exists - then -- If the entry exists then we lost the race and we must abandon, + then do + -- If the entry exists then we lost the race and we must abandon, -- unlock and re-use the existing store entry. - do - info verbosity $ - "Concurrent build race: abandoning build in favour of existing " - ++ "store entry " - ++ prettyShow compid - prettyShow unitid + info verbosity $ "Concurrent build race: abandoning build in favour of existing entry " ++ finalEntryDir return UseExistingStoreEntry - else -- If the entry does not exist then we won the race and can proceed. - do + else do + -- If the entry does not exist then we won the race and can proceed. -- Register the package into the package db (if appropriate). register @@ -218,12 +210,9 @@ newStoreEntry createDirectoryIfMissing True (takeDirectory finalStoreFile) renameFile file finalStoreFile - debug verbosity $ - "Installed store entry " ++ prettyShow compid prettyShow unitid + debug verbosity $ "Installed entry " ++ finalEntryDir return UseNewStoreEntry where - compid = compilerId compiler - finalEntryDir = storePackageDirectory compiler unitid withTempIncomingDir @@ -252,37 +241,14 @@ withIncomingUnitIdLock action = bracket takeLock releaseLock (\_hnd -> action) where - compid = compilerId compiler -#ifdef MIN_VERSION_lukko - takeLock - | fileLockingSupported = do - fd <- fdOpen (storeIncomingLock compiler unitid) - gotLock <- fdTryLock fd ExclusiveLock - unless gotLock $ do - info verbosity $ "Waiting for file lock on store entry " - ++ prettyShow compid prettyShow unitid - fdLock fd ExclusiveLock - return fd - - -- if there's no locking, do nothing. Be careful on AIX. - | otherwise = return undefined -- :( - - releaseLock fd - | fileLockingSupported = do - fdUnlock fd - fdClose fd - | otherwise = return () -#else takeLock = do h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode -- First try non-blocking, but if we would have to wait then -- log an explanation and do it again in blocking mode. gotlock <- hTryLock h ExclusiveLock unless gotlock $ do - info verbosity $ "Waiting for file lock on store entry " - ++ prettyShow compid prettyShow unitid + info verbosity $ "Waiting for file lock on store entry " ++ prettyShow unitid hLock h ExclusiveLock return h releaseLock h = hUnlock h >> hClose h -#endif From 8e727389e44072a48b665282099a102beeda0e83 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 16:59:40 +0800 Subject: [PATCH 085/122] refactor withIncomingUnitIdLock --- .../src/Distribution/Client/Store.hs | 41 +++++++------------ 1 file changed, 15 insertions(+), 26 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index f875b41b8e6..ce7a93fc081 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -34,9 +34,6 @@ import Distribution.Simple.Utils , info , withTempDirectory ) -import Distribution.Verbosity - ( silent - ) import Control.Exception import qualified Data.Set as Set @@ -182,13 +179,14 @@ newStoreEntry copyFiles register = -- See $concurrency above for an explanation of the concurrency protocol - - withTempIncomingDir storeDirLayout compiler $ \incomingTmpDir -> do + withTempDirectory verbosity incomingDir "new" $ \incomingTmpDir -> do -- Write all store entry files within the temp dir and return the prefix. (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir -- Take a lock named after the 'UnitId' in question. - withIncomingUnitIdLock verbosity storeDirLayout compiler unitid $ do + let lockfile = storeIncomingLock compiler unitid + message = "Waiting to acquire the store lock for " ++ show unitid + withIncomingUnitIdLock verbosity lockfile message $ do -- Check for the existence of the final store entry directory. exists <- doesStoreEntryExist storeDirLayout compiler unitid @@ -214,41 +212,32 @@ newStoreEntry return UseNewStoreEntry where finalEntryDir = storePackageDirectory compiler unitid - -withTempIncomingDir - :: StoreDirLayout - -> Compiler - -> (FilePath -> IO a) - -> IO a -withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compiler action = do - createDirectoryIfMissing True incomingDir - withTempDirectory silent incomingDir "new" action - where - incomingDir = storeIncomingDirectory compiler + incomingDir = storeIncomingDirectory compiler withIncomingUnitIdLock :: Verbosity - -> StoreDirLayout - -> Compiler - -> UnitId + -> FilePath + -> String -> IO a -> IO a withIncomingUnitIdLock verbosity - StoreDirLayout{storeIncomingLock} - compiler - unitid + lockfile + message action = bracket takeLock releaseLock (\_hnd -> action) where takeLock = do - h <- openFile (storeIncomingLock compiler unitid) ReadWriteMode + h <- openFile lockfile ReadWriteMode -- First try non-blocking, but if we would have to wait then -- log an explanation and do it again in blocking mode. gotlock <- hTryLock h ExclusiveLock unless gotlock $ do - info verbosity $ "Waiting for file lock on store entry " ++ prettyShow unitid + info verbosity message hLock h ExclusiveLock return h - releaseLock h = hUnlock h >> hClose h + releaseLock h = do + hUnlock h + hClose h + removeFile lockfile From 754971b772910d260255bea7d973e99c2654bf2d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 1 Dec 2025 17:55:28 +0800 Subject: [PATCH 086/122] elabToolchain --- .../src/Distribution/Client/CmdExec.hs | 2 +- .../Distribution/Client/CmdHaddockProject.hs | 11 +-- .../src/Distribution/Client/CmdListBin.hs | 5 +- .../src/Distribution/Client/CmdRepl.hs | 1 - .../src/Distribution/Client/CmdRun.hs | 3 +- .../src/Distribution/Client/DistDirLayout.hs | 6 +- .../Distribution/Client/ProjectBuilding.hs | 10 +- .../ProjectBuilding/PackageFileMonitor.hs | 6 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 23 ++--- .../Client/ProjectOrchestration.hs | 4 +- .../Distribution/Client/ProjectPlanOutput.hs | 8 +- .../Distribution/Client/ProjectPlanning.hs | 94 +++++++------------ .../Client/ProjectPlanning/Types.hs | 25 +++-- 13 files changed, 68 insertions(+), 130 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index 6d270fd7439..1329cb3d2c0 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -304,7 +304,7 @@ binDirectories layout config = fromElaboratedInstallPlan where fromElaboratedInstallPlan = fromGraph . toGraph fromGraph = foldMap fromPlan - fromSrcPkg = S.fromList . Planning.binDirectories layout config + fromSrcPkg = S.fromList . Planning.binDirectories layout fromPlan (PreExisting _) = mempty fromPlan (Configured pkg) = fromSrcPkg pkg diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index e929f3c1956..266248c3694 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -36,12 +36,10 @@ import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan , ElaboratedInstalledPackageInfo - , ElaboratedSharedConfig (..) , TargetAction (..) , Toolchain (..) , WithStage (..) , elabDistDirParams - , getStage ) import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) @@ -159,9 +157,6 @@ haddockProjectAction flags _extraArgs globalFlags = do let elaboratedPlan :: ElaboratedInstallPlan elaboratedPlan = elaboratedPlanOriginal buildCtx - sharedConfig :: ElaboratedSharedConfig - sharedConfig = elaboratedShared buildCtx - pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage] pkgs = matchingPackages elaboratedPlan @@ -177,7 +172,6 @@ haddockProjectAction flags _extraArgs globalFlags = do -- . pkgConfigCompilerProgs -- $ sharedConfig -- let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs} - let sharedConfig' = sharedConfig -- _ <- -- requireProgramVersion @@ -227,7 +221,7 @@ haddockProjectAction flags _extraArgs globalFlags = do Right package -> case elabLocalToProject package of True -> do - let distDirParams = elabDistDirParams sharedConfig' package + let distDirParams = elabDistDirParams package pkg_descr = elabPkgDescription package packageName = pkgName $ elabPkgSourceId package @@ -299,8 +293,7 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> do let pkg_descr = elabPkgDescription package unitId = unUnitId (elabUnitId package) - compilers = toolchainCompiler <$> pkgConfigToolchains sharedConfig' - compiler = getStage compilers (elabStage package) + compiler = toolchainCompiler (elabToolchain package) packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index ecce6fcb6e5..282c13a127d 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -193,7 +193,7 @@ listbinAction flags args globalFlags = do ] ElabComponent comp -> bin_file (compSolverName comp) where - dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) + dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elab) bin_file c = case c of CD.ComponentExe s @@ -206,8 +206,7 @@ listbinAction flags args globalFlags = do | s == selectedComponent -> [flib_file' s] _ -> [] - Toolchain{toolchainPlatform = plat} = - getStage (pkgConfigToolchains elaboratedSharedConfig) (elabStage elab) + Toolchain{toolchainPlatform = plat} = elabToolchain elab -- here and in PlanOutput, -- use binDirectoryFor? diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 655f5a3fa9c..136fc5a4a76 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -409,7 +409,6 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout - elaboratedShared' elaboratedPlan' let elaboratedPlan'' = diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index bbc2eeff44b..c9d1448c8dc 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -305,7 +305,6 @@ runAction flags targetAndArgs globalFlags = let defaultExePath = binDirectoryFor (distDirLayout baseCtx) - (elaboratedShared buildCtx) pkg exeName exeName @@ -326,7 +325,7 @@ runAction flags targetAndArgs globalFlags = , let pkg_descr = elabPkgDescription pkg , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr , let thisExeBI = PD.buildInfo thisExe = - [ binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg depExeNm + [ binDirectoryFor (distDirLayout baseCtx) pkg depExeNm | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI , let depExeNm = unUnqualComponentName depExe ] diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 0c46423768a..33dad521444 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -45,7 +45,7 @@ import Distribution.Simple.Compiler ( Compiler (..) , OptimisationLevel (..) , PackageDBCWD - , PackageDBX (..) + , PackageDBX (..), showCompilerIdWithAbi ) import Distribution.System import Distribution.Types.ComponentName @@ -250,9 +250,7 @@ defaultStoreDirLayout storeRoot = where storeDirectory :: Compiler -> FilePath storeDirectory compiler = - storeRoot case compilerAbiTag compiler of - NoAbiTag -> prettyShow (compilerId compiler) - AbiTag tag -> prettyShow (compilerId compiler) <> "-" <> tag + storeRoot showCompilerIdWithAbi compiler storePackageDirectory :: Compiler -> UnitId -> FilePath storePackageDirectory compiler ipkgid = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 474364f3bc3..504c6127e10 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -167,10 +167,9 @@ import qualified Distribution.Compat.Graph as Graph -- 'InstallPlan.Installed' state when we find that they're already up to date. rebuildTargetsDryRun :: DistDirLayout - -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> IO BuildStatusMap -rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = +rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = -- Do the various checks to work out the 'BuildStatus' of each package foldMInstallPlanDepOrder dryRunPkg where @@ -246,9 +245,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = packageFileMonitor :: PackageFileMonitor packageFileMonitor = newPackageFileMonitor - shared distDirLayout - (elabDistDirParams shared pkg) + (elabDistDirParams pkg) -- | A specialised traversal over the packages in an install plan. -- @@ -571,7 +569,7 @@ rebuildTarget distDirLayout tarball (packageId pkg) - (elabDistDirParams sharedPackageConfig pkg) + (elabDistDirParams pkg) (elabBuildStyle pkg) (elabPkgDescriptionOverride pkg) $ case elabBuildStyle pkg of @@ -589,7 +587,7 @@ rebuildTarget info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir buildInplace buildStatus srcdir builddir where - distdir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) + distdir = distBuildDirectory (elabDistDirParams pkg) builddir = makeSymbolicPath $ makeRelative (normalise $ getSymbolicPath srcdir) distdir diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs index 71d31cb5926..9b99f422021 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs @@ -55,19 +55,17 @@ data PackageFileMonitor = PackageFileMonitor type BuildResultMisc = (DocsResult, TestsResult) newPackageFileMonitor - :: ElaboratedSharedConfig - -> DistDirLayout + :: DistDirLayout -> DistDirParams -> PackageFileMonitor newPackageFileMonitor - shared DistDirLayout{distPackageCacheFile} dparams = PackageFileMonitor { pkgFileMonitorConfig = FileMonitor { fileMonitorCacheFile = distPackageCacheFile dparams "config" - , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared + , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage , fileMonitorCheckIfOnlyValueChanged = False } , pkgFileMonitorBuild = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 426f505c6af..5e94e23e431 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -263,8 +263,7 @@ buildAndRegisterUnpackedPackage where uid = installedUnitId rpkg - Toolchain{toolchainCompiler, toolchainProgramDb} = - getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + Toolchain{toolchainCompiler, toolchainProgramDb} = elabToolchain pkg comp_par_strat = case maybe_semaphore of Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) @@ -296,7 +295,6 @@ buildAndRegisterUnpackedPackage (\p -> makeSymbolicPath <$> canonicalizePath p) plan rpkg - pkgshared commonFlags configureArgs _ = setupHsConfigureArgs pkg @@ -352,7 +350,6 @@ buildAndRegisterUnpackedPackage flip filterHaddockFlags v $ setupHsHaddockFlags pkg - pkgshared buildTimeSettings commonFlags haddockArgs v = @@ -542,7 +539,6 @@ buildInplaceUnpackedPackage map monitorFileHashed $ elabInplaceDependencyBuildCacheFiles distDirLayout - pkgshared plan pkg updatePackageBuildFileMonitor @@ -606,12 +602,11 @@ buildInplaceUnpackedPackage , buildResultLogFile = Nothing } where - dparams = elabDistDirParams pkgshared pkg + dparams = elabDistDirParams pkg - Toolchain{toolchainPlatform = Platform _ os} = - getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + Toolchain{toolchainPlatform = Platform _ os} = elabToolchain pkg - packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + packageFileMonitor = newPackageFileMonitor distDirLayout dparams whenReConfigure action = case buildStatus of BuildStatusConfigure _ -> action @@ -735,7 +730,7 @@ buildAndInstallUnpackedPackage storeDirLayout toolchainCompiler uid - (copyPkgFiles verbosity pkgshared pkg runCopy) + (copyPkgFiles verbosity pkg runCopy) registerPkg -- No tests on install @@ -771,8 +766,7 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg - Toolchain{toolchainCompiler, toolchainPlatform} = - getStage (pkgConfigToolchains pkgshared) (elabStage pkg) + Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain pkg dispname :: String dispname = case elabPkgOrComp pkg of @@ -812,7 +806,6 @@ buildAndInstallUnpackedPackage -- | The copy part of the installation phase when doing build-and-install copyPkgFiles :: Verbosity - -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> (FilePath -> IO ()) -- ^ The 'runCopy' function which invokes ./Setup copy for the @@ -820,7 +813,7 @@ copyPkgFiles -> FilePath -- ^ The temporary dir file path -> IO (FilePath, [FilePath]) -copyPkgFiles verbosity pkgshared pkg runCopy tmpDir = do +copyPkgFiles verbosity pkg runCopy tmpDir = do let tmpDirNormalised = normalise tmpDir runCopy tmpDirNormalised -- Note that the copy command has put the files into @@ -837,7 +830,7 @@ copyPkgFiles verbosity pkgshared pkg runCopy tmpDir = do createDirectoryIfMissingVerbose verbosity True entryDir let hashFileName = entryDir "cabal-hash.txt" - outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) + outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkg) info verbosity $ "creating file with the inputs used to compute the package hash: " ++ hashFileName diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index d5146f66e04..e8db22e7b74 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -405,7 +405,6 @@ runProjectPreBuildPhase pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout - elaboratedShared elaboratedPlan' -- Improve the plan by marking up-to-date packages as installed. @@ -1207,7 +1206,7 @@ printPlan showConfigureFlags :: ElaboratedConfiguredPackage -> String showConfigureFlags elab = - let Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains elaboratedShared) (elabStage elab) + let Toolchain{toolchainProgramDb} = elabToolchain elab commonFlags = setupHsCommonFlags verbosity @@ -1220,7 +1219,6 @@ printPlan (\_ -> return (error "unused")) elaboratedPlan (ReadyPackage elab) - elaboratedShared commonFlags ) -- \| Given a default value @x@ for a flag, nub @Flag x@ diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 4048e5213fd..2ab2eff552e 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -216,8 +216,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] ++ bin_file (compSolverName comp) where - Toolchain{toolchainPlatform = plat} = - Stage.getStage toolchains (elabStage elab) + Toolchain{toolchainPlatform = plat} = elabToolchain elab -- \| Only add build-info file location if the Setup.hs CLI -- is recent enough to be able to generate build info files. @@ -293,10 +292,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] dist_dir :: FilePath - dist_dir = - distBuildDirectory - distDirLayout - (elabDistDirParams elaboratedSharedConfig elab) + dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elab) bin_file :: ComponentDeps.Component -> [J.Pair] bin_file c = case c of diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 3d99aa219ac..d8826d8e1cb 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -700,7 +700,7 @@ rebuildInstallPlan -- The improved plan changes each time we install something, whereas -- the underlying elaborated plan only changes when input config -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared + improvedPlan <- phaseImprovePlan elaboratedPlan return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) where @@ -937,7 +937,6 @@ rebuildInstallPlan instantiateInstallPlan cabalStoreDirLayout installDirs - elaboratedShared elaboratedPlan infoProgress $ text "Elaborated install plan:" $$ text (showElaboratedInstallPlan instantiatedPlan) @@ -978,9 +977,8 @@ rebuildInstallPlan -- phaseImprovePlan :: ElaboratedInstallPlan - -> ElaboratedSharedConfig -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan elaboratedShared = do + phaseImprovePlan elaboratedPlan = do liftIO $ debug verbosity "Improving the install plan..." improvedPlan <- liftIO $ InstallPlan.installedM canBeImproved elaboratedPlan liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) @@ -991,8 +989,10 @@ rebuildInstallPlan return improvedPlan where canBeImproved pkg = do - let Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains elaboratedShared) (elabStage pkg) - doesStoreEntryExist cabalStoreDirLayout toolchainCompiler (installedUnitId pkg) + doesStoreEntryExist + cabalStoreDirLayout + (toolchainCompiler (elabToolchain pkg)) + (installedUnitId pkg) -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. @@ -1891,11 +1891,7 @@ elaborateInstallPlan Nothing -> prettyShow pkgid Just n -> prettyShow pkgid ++ "-" ++ prettyShow n BuildAndInstall -> - hashedInstalledPackageId - ( packageHashInputs - elaboratedSharedConfig - elab1 -- knot tied - ) + hashedInstalledPackageId (packageHashInputs elab1) -- knot tied cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} @@ -1952,7 +1948,6 @@ elaborateInstallPlan computeInstallDirs storeDirLayout defaultInstallDirs - elaboratedSharedConfig elab2 } @@ -2012,7 +2007,6 @@ elaborateInstallPlan inplace_bin_dir elab = binDirectoryFor distDirLayout - elaboratedSharedConfig elab $ case Cabal.componentNameString cname of Just n -> prettyShow n @@ -2055,7 +2049,6 @@ elaborateInstallPlan in binDirectoryFor distDirLayout - elaboratedSharedConfig elab <$> executables @@ -2076,8 +2069,7 @@ elaborateInstallPlan return elab where elab0@ElaboratedConfiguredPackage - { elabPkgSourceHash - , elabStanzasRequested + { elabStanzasRequested , elabStage } = elaborateSolverToCommon solverPkg @@ -2095,7 +2087,6 @@ elaborateInstallPlan computeInstallDirs storeDirLayout defaultInstallDirs - elaboratedSharedConfig elab1 } @@ -2107,12 +2098,7 @@ elaborateInstallPlan | shouldBuildInplaceOnly solverPkg = mkComponentId (prettyShow srcpkgPackageId) | otherwise = - assert (isJust elabPkgSourceHash) $ - hashedInstalledPackageId - ( packageHashInputs - elaboratedSharedConfig - elab -- recursive use of elab - ) + hashedInstalledPackageId (packageHashInputs elab) -- recursive use of elab -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. @@ -2182,8 +2168,6 @@ elaborateInstallPlan elaboratedPackage where compilers = fmap toolchainCompiler toolchains - platforms = fmap toolchainPlatform toolchains - programDbs = fmap toolchainProgramDb toolchains packageDbs = fmap toolchainPackageDBs toolchains elaboratedPackage = ElaboratedConfiguredPackage{..} @@ -2199,9 +2183,10 @@ elaborateInstallPlan elabPkgSourceId = srcpkgPackageId elabStage = solverPkgStage - elabCompiler = getStage compilers elabStage - elabPlatform = getStage platforms elabStage - elabProgramDb = getStage programDbs elabStage + elabToolchain = getStage toolchains elabStage + elabCompiler = toolchainCompiler elabToolchain + elabPlatform = toolchainPlatform elabToolchain + elabProgramDb = toolchainProgramDb elabToolchain elabPkgDescription = case PD.finalizePD @@ -2277,7 +2262,7 @@ elaborateInstallPlan then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = getStage packageDbs elabStage + elabPackageDbs = toolchainPackageDBs elabToolchain elabBuildPackageDBStack = buildAndRegisterDbs elabStage elabRegisterPackageDBStack = buildAndRegisterDbs elabStage @@ -2711,10 +2696,9 @@ mkShapeMapping dpkg = -- with multiple executables. binDirectories :: DistDirLayout - -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> [FilePath] -binDirectories layout config package = case elabBuildStyle package of +binDirectories layout package = case elabBuildStyle package of -- quick sanity check: no sense returning a bin directory if we're not going -- to put any executables in it, that will just clog up the PATH _ | noExecutables -> [] @@ -2731,7 +2715,7 @@ binDirectories layout config package = case elabBuildStyle package of where noExecutables = null . PD.executables . elabPkgDescription $ package root = - distBuildDirectory layout (elabDistDirParams config package) + distBuildDirectory layout (elabDistDirParams package) "build" type InstS = Map (WithStage UnitId) ElaboratedPlanPackage @@ -2809,10 +2793,9 @@ instantiateInstallPlan :: HasCallStack => StoreDirLayout -> Staged InstallDirs.InstallDirTemplates - -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> LogProgress ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = do +instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do InstallPlan.new (Map.elems ready_map) where pkgs = InstallPlan.toList plan @@ -2891,7 +2874,6 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = computeInstallDirs storeDirLayout defaultInstallDirs - elaboratedShared elab1 } @@ -4017,10 +3999,9 @@ storePackageInstallDirs' computeInstallDirs :: StoreDirLayout -> Staged InstallDirs.InstallDirTemplates - -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs sharedConfig elab = +computeInstallDirs storeDirLayout defaultInstallDirs elab = if isInplaceBuildStyle (elabBuildStyle elab) then -- use the ordinary default install dirs @@ -4045,7 +4026,7 @@ computeInstallDirs storeDirLayout defaultInstallDirs sharedConfig elab = toolchainCompiler (elabUnitId elab) where - Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) (elabStage elab) + Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain elab defaultInstallDirs' = getStage defaultInstallDirs (elabStage elab) -- TODO: [code cleanup] perhaps reorder this code @@ -4059,21 +4040,19 @@ setupHsConfigureFlags -- to do this is to convert the potentially relative path into an absolute path. -> ElaboratedInstallPlan -> ElaboratedReadyPackage - -> ElaboratedSharedConfig -> Cabal.CommonSetupFlags -> m Cabal.ConfigFlags setupHsConfigureFlags mkSymbolicPath _plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - sharedConfig configCommonFlags = do -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions configPackageDBs <- (traverse . traverse . traverse) mkSymbolicPath (Nothing : map Just elabBuildPackageDBStack) return Cabal.ConfigFlags{..} where - Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage + Toolchain{toolchainCompiler} = elabToolchain Cabal.ConfigFlags { configVanillaLib @@ -4369,19 +4348,17 @@ setupHsRegisterFlags setupHsHaddockFlags :: ElaboratedConfiguredPackage - -> ElaboratedSharedConfig -> BuildTimeSettings -> Cabal.CommonSetupFlags -> Cabal.HaddockFlags setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) - sharedConfig _buildTimeSettings common = Cabal.HaddockFlags { haddockCommonFlags = common , haddockProgramPaths = - case lookupProgram haddockProgram toolchainProgramDb of + case lookupProgram haddockProgram (toolchainProgramDb elabToolchain) of Nothing -> mempty Just prg -> [ @@ -4410,8 +4387,6 @@ setupHsHaddockFlags , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir , haddockUseUnicode = toFlag elabHaddockUseUnicode } - where - Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains sharedConfig) elabStage setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] -- TODO: Does the issue #3335 affects test as well @@ -4463,11 +4438,9 @@ setupHsHaddockArgs elab = -- not replace installed packages with ghc-pkg. packageHashInputs - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage + :: ElaboratedConfiguredPackage -> PackageHashInputs packageHashInputs - pkgshared elab@( ElaboratedConfiguredPackage { elabPkgSourceHash = Just srchash } @@ -4479,7 +4452,7 @@ packageHashInputs , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) , pkgHashLibDeps , pkgHashExeDeps - , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab + , pkgHashOtherConfig = packageHashConfigInputs elab } where pkgHashComponent = @@ -4518,16 +4491,15 @@ packageHashInputs -- affect the result, so we do not include them. relevantDeps (CD.ComponentTest _) = False relevantDeps (CD.ComponentBench _) = False -packageHashInputs _ pkg = +packageHashInputs pkg = error $ "packageHashInputs: only for packages with source hashes. " ++ prettyShow (packageId pkg) packageHashConfigInputs - :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage + :: ElaboratedConfiguredPackage -> PackageHashConfigInputs -packageHashConfigInputs sharedConfig pkg = +packageHashConfigInputs pkg = PackageHashConfigInputs { pkgHashCompilerId = compilerId toolchainCompiler , pkgHashCompilerABI = compilerAbiTag toolchainCompiler @@ -4578,8 +4550,8 @@ packageHashConfigInputs sharedConfig pkg = , pkgHashHaddockUseUnicode = elabHaddockUseUnicode } where - Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains sharedConfig) elabStage - ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage sharedConfig pkg + Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage pkg LBC.BuildOptions{..} = elabBuildOptions -- TODO: sanity checks: @@ -4601,13 +4573,12 @@ packageHashConfigInputs sharedConfig pkg = -- HACK. binDirectoryFor :: DistDirLayout - -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> FilePath -> FilePath -binDirectoryFor layout config package exe = case elabBuildStyle package of +binDirectoryFor layout package exe = case elabBuildStyle package of BuildAndInstall -> installedBinDirectory package - BuildInplaceOnly{} -> inplaceBinRoot layout config package exe + BuildInplaceOnly{} -> inplaceBinRoot layout package exe -- package has been built and installed. installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath @@ -4616,11 +4587,10 @@ installedBinDirectory = InstallDirs.bindir . elabInstallDirs -- | The path to the @build@ directory for an inplace build. inplaceBinRoot :: DistDirLayout - -> ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> FilePath -inplaceBinRoot layout config package = - distBuildDirectory layout (elabDistDirParams config package) +inplaceBinRoot layout package = + distBuildDirectory layout (elabDistDirParams package) "build" -- FIXME: whathever diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index ea19684a7cc..d725e15599c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -273,6 +273,7 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage -- helps with error messages when the user asks to build something -- they explicitly disabled. , elabStage :: Stage + , elabToolchain :: Toolchain , -- TODO: The 'Bool' here should be refined into an ADT with three -- cases: NotRequested, ExplicitlyRequested and -- ImplicitlyRequested. A stanza is explicitly requested if @@ -366,13 +367,12 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage deriving (Eq, Show, Generic) normaliseConfiguredPackage - :: ElaboratedSharedConfig + :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage - -> ElaboratedConfiguredPackage -normaliseConfiguredPackage shared pkg = +normaliseConfiguredPackage pkg = pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} where - Toolchain{toolchainProgramDb} = getStage (pkgConfigToolchains shared) (elabStage pkg) + Toolchain{toolchainProgramDb} = elabToolchain pkg knownProgramDb = addKnownPrograms builtinPrograms toolchainProgramDb pkgDesc :: PackageDescription @@ -561,8 +561,8 @@ elabConfiguredName verbosity elab | otherwise = prettyShow (elabUnitId elab) -elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams -elabDistDirParams shared elab = +elabDistDirParams :: ElaboratedConfiguredPackage -> DistDirParams +elabDistDirParams elab = DistDirParams { distParamStage = elabStage elab , distParamUnitId = installedUnitId elab @@ -571,12 +571,10 @@ elabDistDirParams shared elab = , distParamComponentName = case elabPkgOrComp elab of ElabComponent comp -> compComponentName comp ElabPackage _ -> Nothing - , distParamCompilerId = compilerId toolchainCompiler - , distParamPlatform = toolchainPlatform + , distParamCompilerId = compilerId (toolchainCompiler (elabToolchain elab)) + , distParamPlatform = toolchainPlatform (elabToolchain elab) , distParamOptimization = LBC.withOptimization $ elabBuildOptions elab - } - where - Toolchain{toolchainCompiler, toolchainPlatform} = getStage (pkgConfigToolchains shared) (elabStage elab) + } where -- -- Order dependencies @@ -728,16 +726,15 @@ pkgSetupLibDependencies pkg = -- rebuilds. elabInplaceDependencyBuildCacheFiles :: DistDirLayout - -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedConfiguredPackage -> [FilePath] -elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = +elabInplaceDependencyBuildCacheFiles layout plan root_elab = go =<< InstallPlan.directDeps plan (nodeKey root_elab) where go = InstallPlan.foldPlanPackage (const []) $ \elab -> do guard (isInplaceBuildStyle (elabBuildStyle elab)) - return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" + return $ distPackageCacheFile layout (elabDistDirParams elab) "build" -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" From 43832a41480177b1ed75b435af5ba87033c5be9c Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 11:39:52 +0800 Subject: [PATCH 087/122] use toolchain in StoreDirLayout --- .../Distribution/Client/CmdHaddockProject.hs | 5 +- .../src/Distribution/Client/CmdInstall.hs | 42 ++++++------ .../src/Distribution/Client/DistDirLayout.hs | 66 ++++++++++--------- .../Client/ProjectBuilding/UnpackedPackage.hs | 3 +- .../Distribution/Client/ProjectPlanning.hs | 28 +++++--- .../src/Distribution/Client/Store.hs | 32 ++++----- .../src/Distribution/Client/Toolchain.hs | 23 +++++++ 7 files changed, 117 insertions(+), 82 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 266248c3694..b7563d307ef 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -37,7 +37,6 @@ import Distribution.Client.ProjectPlanning , ElaboratedInstallPlan , ElaboratedInstalledPackageInfo , TargetAction (..) - , Toolchain (..) , WithStage (..) , elabDistDirParams ) @@ -293,11 +292,11 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> do let pkg_descr = elabPkgDescription package unitId = unUnitId (elabUnitId package) - compiler = toolchainCompiler (elabToolchain package) packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) - compiler + (elabStage package) + (elabToolchain package) (elabUnitId package) -- TODO: use `InstallDirTemplates` docDir = packageDir "share" "doc" "html" diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 0465d81f24f..8152b298533 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -94,6 +94,8 @@ import Distribution.Client.ProjectPlanning ( ElaboratedInstallPlan , ElaboratedPlanPackage , Stage (..) + , Toolchain (..) + , configToolchainExSafe , storePackageInstallDirs' ) import Distribution.Client.RebuildMonad @@ -139,8 +141,7 @@ import Distribution.Simple.Compiler , PackageDBX (..) ) import Distribution.Simple.Configure - ( configCompilerEx - , interpretPackageDbFlags + ( interpretPackageDbFlags ) import Distribution.Simple.Flag ( flagElim @@ -275,8 +276,8 @@ data InstallCfg = InstallCfg { verbosity :: Verbosity , baseCtx :: ProjectBaseContext , buildCtx :: ProjectBuildContext - , platform :: Platform - , compiler :: Compiler + , stage :: Stage + , toolchain :: Toolchain , installConfigFlags :: ConfigFlags , installClientFlags :: ClientInstallFlags } @@ -450,17 +451,15 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project $ configProgDb -- progDb is a program database with compiler tools configured properly - (compiler@Compiler{compilerId = CompilerId compilerFlavor compilerVersion}, platform, progDb) <- - configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity + toolchain@Toolchain{..} <- configToolchainExSafe verbosity hcFlavor hcPath hcPkg preProgDb + let Compiler{compilerId = CompilerId compilerFlavor compilerVersion} = toolchainCompiler + GhcImplInfo{supportsPkgEnvFiles} = getImplInfo toolchainCompiler - let - GhcImplInfo{supportsPkgEnvFiles} = getImplInfo compiler - - (usedPackageEnvFlag, envFile) <- getEnvFile clientInstallFlags platform compilerVersion + (usedPackageEnvFlag, envFile) <- getEnvFile clientInstallFlags toolchainPlatform compilerVersion (usedExistingPkgEnvFile, existingEnvEntries) <- getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile - packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir projectConfigPackageDBs - installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb + packageDbs <- getPackageDbStack Host toolchain projectConfigStoreDir projectConfigLogsDir projectConfigPackageDBs + installedIndex <- getInstalledPackages verbosity toolchainCompiler packageDbs toolchainProgramDb let (envSpecs, nonGlobalEnvEntries) = @@ -520,7 +519,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors printPlan verbosity baseCtx buildCtx - let installCfg = InstallCfg verbosity baseCtx buildCtx platform compiler configFlags clientInstallFlags + let installCfg = InstallCfg verbosity baseCtx buildCtx Host toolchain configFlags clientInstallFlags let dryRun = @@ -544,7 +543,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project verbosity buildCtx installedIndex - compiler + toolchainCompiler packageDbs envFile nonGlobalEnvEntries' @@ -924,7 +923,7 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do -- actually perform its installation. prepareExeInstall :: InstallCfg -> IO InstallExe prepareExeInstall - InstallCfg{verbosity, baseCtx, buildCtx, platform, compiler, installConfigFlags, installClientFlags} = do + InstallCfg{verbosity, baseCtx, buildCtx, stage, toolchain, installConfigFlags, installClientFlags} = do installPath <- defaultInstallPath let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx @@ -934,13 +933,13 @@ prepareExeInstall mkUnitBinDir :: UnitId -> FilePath mkUnitBinDir = InstallDirs.bindir - . storePackageInstallDirs' storeDirLayout compiler + . storePackageInstallDirs' storeDirLayout stage toolchain mkExeName :: UnqualComponentName -> FilePath - mkExeName exe = unUnqualComponentName exe <.> exeExtension platform + mkExeName exe = unUnqualComponentName exe <.> exeExtension (toolchainPlatform toolchain) mkFinalExeName :: UnqualComponentName -> FilePath - mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform + mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension (toolchainPlatform toolchain) installdirUnknown = "installdir is not defined. Set it in your cabal config file " ++ "or use --installdir=. Using default installdir: " @@ -1347,17 +1346,18 @@ getLocalEnv dir platform compilerVersion = <> ghcPlatformAndVersionString platform compilerVersion getPackageDbStack - :: Compiler + :: Stage + -> Toolchain -> Flag FilePath -> Flag FilePath -> [Maybe PackageDBCWD] -> IO PackageDBStackCWD -getPackageDbStack compiler storeDirFlag logsDirFlag packageDbs = do +getPackageDbStack stage toolchain storeDirFlag logsDirFlag packageDbs = do mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag let mlogsDir = flagToMaybe logsDirFlag cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir - let storePackageDBStack = interpretPackageDbFlags False packageDbs ++ [storePackageDB (cabalStoreDirLayout cabalLayout) compiler] + let storePackageDBStack = interpretPackageDbFlags False packageDbs ++ [storePackageDB (cabalStoreDirLayout cabalLayout) stage toolchain] pure storePackageDBStack -- | This defines what a 'TargetSelector' means for the @bench@ command. diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 33dad521444..b2841d32f0b 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -33,7 +33,7 @@ import Distribution.Client.Config ( defaultLogsDir , defaultStoreDir ) -import Distribution.Client.Toolchain (Stage) +import Distribution.Client.Toolchain (Stage, Toolchain (..)) import Distribution.Compiler import Distribution.Package ( ComponentId @@ -42,8 +42,7 @@ import Distribution.Package , UnitId ) import Distribution.Simple.Compiler - ( Compiler (..) - , OptimisationLevel (..) + ( OptimisationLevel (..) , PackageDBCWD , PackageDBX (..), showCompilerIdWithAbi ) @@ -118,12 +117,12 @@ data DistDirLayout = DistDirLayout -- | The layout of a cabal nix-style store. data StoreDirLayout = StoreDirLayout - { storeDirectory :: Compiler -> FilePath - , storePackageDirectory :: Compiler -> UnitId -> FilePath - , storePackageDBPath :: Compiler -> FilePath - , storePackageDB :: Compiler -> PackageDBCWD - , storeIncomingDirectory :: Compiler -> FilePath - , storeIncomingLock :: Compiler -> UnitId -> FilePath + { storeDirectory :: Stage -> Toolchain -> FilePath + , storePackageDirectory :: Stage -> Toolchain -> UnitId -> FilePath + , storePackageDBPath :: Stage -> Toolchain -> FilePath + , storePackageDB :: Stage -> Toolchain -> PackageDBCWD + , storeIncomingDirectory :: Stage -> Toolchain -> FilePath + , storeIncomingLock :: Stage -> Toolchain -> UnitId -> FilePath } -- TODO: move to another module, e.g. CabalDirLayout? @@ -248,29 +247,32 @@ defaultStoreDirLayout :: FilePath -> StoreDirLayout defaultStoreDirLayout storeRoot = StoreDirLayout{..} where - storeDirectory :: Compiler -> FilePath - storeDirectory compiler = - storeRoot showCompilerIdWithAbi compiler - - storePackageDirectory :: Compiler -> UnitId -> FilePath - storePackageDirectory compiler ipkgid = - storeDirectory compiler prettyShow ipkgid - - storePackageDBPath :: Compiler -> FilePath - storePackageDBPath compiler = - storeDirectory compiler "package.conf.d" - - storePackageDB :: Compiler -> PackageDBCWD - storePackageDB compiler = - SpecificPackageDB (storePackageDBPath compiler) - - storeIncomingDirectory :: Compiler -> FilePath - storeIncomingDirectory compiler = - storeDirectory compiler "incoming" - - storeIncomingLock :: Compiler -> UnitId -> FilePath - storeIncomingLock compiler unitid = - storeIncomingDirectory compiler prettyShow unitid <.> "lock" + storeDirectory :: Stage -> Toolchain -> FilePath + storeDirectory stage toolchain = + storeRoot + prettyShow stage + prettyShow (toolchainPlatform toolchain) + showCompilerIdWithAbi (toolchainCompiler toolchain) + + storePackageDirectory :: Stage -> Toolchain -> UnitId -> FilePath + storePackageDirectory stage toolchain ipkgid = + storeDirectory stage toolchain prettyShow ipkgid + + storePackageDBPath :: Stage -> Toolchain -> FilePath + storePackageDBPath stage toolchain = + storeDirectory stage toolchain "package.conf.d" + + storePackageDB :: Stage -> Toolchain -> PackageDBCWD + storePackageDB stage toolchain = + SpecificPackageDB (storePackageDBPath stage toolchain) + + storeIncomingDirectory :: Stage -> Toolchain -> FilePath + storeIncomingDirectory stage toolchain = + storeDirectory stage toolchain + + storeIncomingLock :: Stage -> Toolchain -> UnitId -> FilePath + storeIncomingLock stage toolchain unitid = + storeIncomingDirectory stage toolchain prettyShow unitid <.> "lock" defaultCabalDirLayout :: IO CabalDirLayout defaultCabalDirLayout = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 5e94e23e431..f637a8864d1 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -728,7 +728,8 @@ buildAndInstallUnpackedPackage newStoreEntry verbosity storeDirLayout - toolchainCompiler + (elabStage pkg) + (elabToolchain pkg) uid (copyPkgFiles verbosity pkg runCopy) registerPkg diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d8826d8e1cb..e674880c925 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -105,6 +105,9 @@ module Distribution.Client.ProjectPlanning , storePackageInstallDirs , storePackageInstallDirs' , elabDistDirParams + + -- * Toolchain + , configToolchainExSafe ) where import Distribution.Client.Compat.Prelude @@ -991,7 +994,8 @@ rebuildInstallPlan canBeImproved pkg = do doesStoreEntryExist cabalStoreDirLayout - (toolchainCompiler (elabToolchain pkg)) + (elabStage pkg) + (elabToolchain pkg) (installedUnitId pkg) -- | If a 'PackageSpecifier' refers to a single package, return Just that @@ -2281,7 +2285,7 @@ elaborateInstallPlan inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory "packagedb" prettyShow stage prettyShow (compilerId (getStage compilers stage)))] -- The project packagedbs (typically the global packagedb but others can be added) followed by the store. - corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout (getStage compilers stage)] + corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout stage (getStage toolchains stage)] elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage @@ -3952,15 +3956,17 @@ userInstallDirTemplates compiler = do storePackageInstallDirs :: StoreDirLayout - -> Compiler + -> Stage + -> Toolchain -> InstalledPackageId -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs storeDirLayout compiler ipkgid = - storePackageInstallDirs' storeDirLayout compiler $ newSimpleUnitId ipkgid +storePackageInstallDirs storeDirLayout stage toolchain ipkgid = + storePackageInstallDirs' storeDirLayout stage toolchain $ newSimpleUnitId ipkgid storePackageInstallDirs' :: StoreDirLayout - -> Compiler + -> Stage + -> Toolchain -> UnitId -> InstallDirs.InstallDirs FilePath storePackageInstallDirs' @@ -3968,12 +3974,13 @@ storePackageInstallDirs' { storePackageDirectory , storeDirectory } - compiler + stage + toolchain unitid = InstallDirs.InstallDirs{..} where - store = storeDirectory compiler - prefix = storePackageDirectory compiler unitid + store = storeDirectory stage toolchain + prefix = storePackageDirectory stage toolchain unitid bindir = prefix "bin" libdir = prefix "lib" libsubdir = "" @@ -4023,7 +4030,8 @@ computeInstallDirs storeDirLayout defaultInstallDirs elab = storePackageInstallDirs' storeDirLayout - toolchainCompiler + (elabStage elab) + (elabToolchain elab) (elabUnitId elab) where Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain elab diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs index ce7a93fc081..95912d8dcb7 100644 --- a/cabal-install/src/Distribution/Client/Store.hs +++ b/cabal-install/src/Distribution/Client/Store.hs @@ -25,9 +25,9 @@ import Prelude () import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad +import Distribution.Client.Toolchain (Toolchain (..), Stage) import Distribution.Package (UnitId, mkUnitId) -import Distribution.Simple.Compiler (Compiler (..)) import Distribution.Simple.Utils ( debug @@ -119,20 +119,19 @@ import GHC.IO.Handle.Lock (LockMode (ExclusiveLock), hLock, hTryLock, hUnlock) -- or replace, i.e. not failing if the db entry already exists. -- | Check if a particular 'UnitId' exists in the store. -doesStoreEntryExist :: StoreDirLayout -> Compiler -> UnitId -> IO Bool -doesStoreEntryExist StoreDirLayout{storePackageDirectory} compiler unitid = - doesDirectoryExist (storePackageDirectory compiler unitid) +doesStoreEntryExist :: StoreDirLayout -> Stage -> Toolchain -> UnitId -> IO Bool +doesStoreEntryExist StoreDirLayout{storePackageDirectory} stage toolchain unitid = + doesDirectoryExist (storePackageDirectory stage toolchain unitid) -- | Return the 'UnitId's of all packages\/components already installed in the -- store. -getStoreEntries :: StoreDirLayout -> Compiler -> Rebuild (Set UnitId) -getStoreEntries StoreDirLayout{storeDirectory} compiler = do - paths <- getDirectoryContentsMonitored (storeDirectory compiler) +getStoreEntries :: StoreDirLayout -> Stage -> Toolchain -> Rebuild (Set UnitId) +getStoreEntries StoreDirLayout{storeDirectory} stage toolchain = do + paths <- getDirectoryContentsMonitored (storeDirectory stage toolchain) return $! mkEntries paths where mkEntries = Set.delete (mkUnitId "package.conf.d") - . Set.delete (mkUnitId "incoming") . Set.fromList . map mkUnitId . filter valid @@ -164,7 +163,8 @@ data NewStoreEntryOutcome newStoreEntry :: Verbosity -> StoreDirLayout - -> Compiler + -> Stage + -> Toolchain -> UnitId -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files. @@ -174,7 +174,8 @@ newStoreEntry newStoreEntry verbosity storeDirLayout@StoreDirLayout{..} - compiler + stage + toolchain unitid copyFiles register = @@ -184,11 +185,11 @@ newStoreEntry (incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir -- Take a lock named after the 'UnitId' in question. - let lockfile = storeIncomingLock compiler unitid + let lockfile = storeIncomingLock stage toolchain unitid message = "Waiting to acquire the store lock for " ++ show unitid withIncomingUnitIdLock verbosity lockfile message $ do -- Check for the existence of the final store entry directory. - exists <- doesStoreEntryExist storeDirLayout compiler unitid + exists <- doesStoreEntryExist storeDirLayout stage toolchain unitid if exists then do @@ -204,15 +205,16 @@ newStoreEntry -- Atomically rename the temp dir to the final store entry location. renameDirectory incomingEntryDir finalEntryDir for_ otherFiles $ \file -> do - let finalStoreFile = storeDirectory compiler makeRelative (normalise $ incomingTmpDir (dropDrive (storeDirectory compiler))) file + let finalStoreFile = storeDirectory stage toolchain makeRelative (normalise $ incomingTmpDir dropDrive (storeDirectory stage toolchain)) file createDirectoryIfMissing True (takeDirectory finalStoreFile) renameFile file finalStoreFile debug verbosity $ "Installed entry " ++ finalEntryDir return UseNewStoreEntry where - finalEntryDir = storePackageDirectory compiler unitid - incomingDir = storeIncomingDirectory compiler + finalEntryDir = storePackageDirectory stage toolchain unitid + incomingDir = storeIncomingDirectory stage toolchain + withIncomingUnitIdLock :: Verbosity diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs index e6023fdd91a..e9658104eff 100644 --- a/cabal-install/src/Distribution/Client/Toolchain.hs +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -10,6 +10,7 @@ module Distribution.Client.Toolchain , configToolchains , module Distribution.Solver.Types.Stage , module Distribution.Solver.Types.Toolchain + , configToolchainExSafe ) where @@ -120,3 +121,25 @@ configCompilerExSafe verbosity hcFlavor hcPath hcPkg progdb = do -- I think this should be fixed in configCompilerExAux or even configCompilerEx progdb'' <- configureAllKnownPrograms verbosity progdb' return (compiler, platform, progdb'') + +configToolchainExSafe + :: Verbosity + -> Maybe CompilerFlavor + -> Maybe FilePath + -> Maybe FilePath + -> ProgramDb + -> IO Toolchain +configToolchainExSafe verbosity hcFlavor hcPath hcPkg progdb = do + (toolchainCompiler, toolchainPlatform, progdb') <- + configCompilerEx + hcFlavor + hcPath + hcPkg + progdb + verbosity + + -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the future. + -- I think this should be fixed in configCompilerExAux or even configCompilerEx + toolchainProgramDb <- configureAllKnownPrograms verbosity progdb' + let toolchainPackageDBs = [] + return Toolchain{..} From 8f1a5b77a19db853e5da9efd7084dd57610f49ba Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 15:37:23 +0800 Subject: [PATCH 088/122] use toolchain in DistDirParams --- .../src/Distribution/Client/DistDirLayout.hs | 25 +++++------------- .../Client/ProjectPlanning/Types.hs | 11 ++------ .../src/Distribution/Client/ScriptUtils.hs | 26 +++++-------------- 3 files changed, 16 insertions(+), 46 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index b2841d32f0b..cd72e5927e5 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -36,18 +36,15 @@ import Distribution.Client.Config import Distribution.Client.Toolchain (Stage, Toolchain (..)) import Distribution.Compiler import Distribution.Package - ( ComponentId - , PackageId + ( PackageId , PackageIdentifier , UnitId ) import Distribution.Simple.Compiler - ( OptimisationLevel (..) - , PackageDBCWD - , PackageDBX (..), showCompilerIdWithAbi + ( PackageDBCWD + , PackageDBX (..) + , showCompilerIdWithAbi ) -import Distribution.System -import Distribution.Types.ComponentName -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained @@ -56,16 +53,8 @@ import Distribution.Types.ComponentName -- the user, say, adds a dependency to their project. data DistDirParams = DistDirParams { distParamStage :: Stage + , distParamToolchain :: Toolchain , distParamUnitId :: UnitId - , distParamPackageId :: PackageId - , distParamComponentId :: ComponentId - , distParamComponentName :: Maybe ComponentName - , distParamCompilerId :: CompilerId - , distParamPlatform :: Platform - , distParamOptimization :: OptimisationLevel - -- TODO (see #3343): - -- Flag assignments - -- Optimization } -- | The layout of the project state directory. Traditionally this has been @@ -195,8 +184,8 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distBuildDirectory params = distBuildRootDirectory prettyShow (distParamStage params) - prettyShow (distParamPlatform params) - prettyShow (distParamCompilerId params) + prettyShow (toolchainPlatform (distParamToolchain params)) + showCompilerIdWithAbi (toolchainCompiler (distParamToolchain params)) prettyShow (distParamUnitId params) distUnpackedSrcRootDirectory :: FilePath diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index d725e15599c..4c7a776b8fd 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -565,16 +565,9 @@ elabDistDirParams :: ElaboratedConfiguredPackage -> DistDirParams elabDistDirParams elab = DistDirParams { distParamStage = elabStage elab + , distParamToolchain = elabToolchain elab , distParamUnitId = installedUnitId elab - , distParamComponentId = elabComponentId elab - , distParamPackageId = elabPkgSourceId elab - , distParamComponentName = case elabPkgOrComp elab of - ElabComponent comp -> compComponentName comp - ElabPackage _ -> Nothing - , distParamCompilerId = compilerId (toolchainCompiler (elabToolchain elab)) - , distParamPlatform = toolchainPlatform (elabToolchain elab) - , distParamOptimization = LBC.withOptimization $ elabBuildOptions elab - } where + } -- -- Order dependencies diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index fd2a0b46cfd..cbb06cd37cc 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -49,8 +49,7 @@ import Distribution.Client.NixStyleOptions ( NixStyleFlags (..) ) import Distribution.Client.ProjectConfig - ( PackageConfig (..) - , ProjectConfig (..) + ( ProjectConfig (..) , ProjectConfigShared (..) , projectConfigHttpTransport , reportParseResult @@ -112,13 +111,8 @@ import Distribution.Parsec ( Position (..) ) import qualified Distribution.SPDX.License as SPDX -import Distribution.Simple.Compiler - ( Compiler (..) - , OptimisationLevel (..) - ) import Distribution.Simple.Flag ( flagToMaybe - , fromFlagOrDefault ) import Distribution.Simple.PackageDescription ( parseString @@ -378,13 +372,13 @@ withContextAndSelectors verbosity noTargets kind flags@NixStyleFlags{..} targetS toolchains <- runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) - let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host + let toolchain@Toolchain{toolchainCompiler, toolchainPlatform = Platform arch os} = getStage toolchains Host (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, toolchainCompiler)) mempty projectCfgSkeleton let ctx' = baseCtx & lProjectConfig %~ (<> projectCfg) - build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform + build_dir = distBuildDirectory (distDirLayout ctx') $ scriptDistDirParams script toolchain exePath = build_dir "bin" scriptExeFileName script exePathRel = makeRelative (normalise projectRoot) exePath @@ -424,22 +418,16 @@ scriptComponentName scriptPath = fromString cname scriptExeFileName :: FilePath -> FilePath scriptExeFileName scriptPath = "cabal-script-" ++ takeFileName scriptPath -scriptDistDirParams :: FilePath -> ProjectBaseContext -> Compiler -> Platform -> DistDirParams -scriptDistDirParams scriptPath ctx compiler platform = +scriptDistDirParams :: FilePath -> Toolchain -> DistDirParams +scriptDistDirParams scriptPath toolchain = DistDirParams { distParamStage = Host + , distParamToolchain = toolchain , distParamUnitId = newSimpleUnitId cid - , distParamPackageId = fakePackageId - , distParamComponentId = cid - , distParamComponentName = Just $ CExeName cn - , distParamCompilerId = compilerId compiler - , distParamPlatform = platform - , distParamOptimization = fromFlagOrDefault NormalOptimisation optimization } where - cn = scriptComponentName scriptPath + cn = scriptComponentName scriptPath :: UnqualComponentName cid = mkComponentId $ prettyShow fakePackageId <> "-inplace-" <> prettyShow cn - optimization = (packageConfigOptimization . projectConfigLocalPackages . projectConfig) ctx setExePath :: FilePath -> [String] -> [String] setExePath exePath options From 1df99bd2702780c0cb8f926f57509b04a24fa0d1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 9 Dec 2025 15:37:56 +0800 Subject: [PATCH 089/122] formatting emphatise the similarity between elabLibDependencies/elabExeDependencies/elabExeDependencyPaths --- .../src/Distribution/Client/ProjectPlanning/Types.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 4c7a776b8fd..eb8b54c4327 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -647,10 +647,8 @@ elabLibDependencies elab = -- building. map (\(cid, promised) -> (WithStage (elabStage elab) cid, promised)) $ case elabPkgOrComp elab of - ElabPackage pkg -> - ordNub $ CD.nonSetupDeps (pkgLibDependencies pkg) - ElabComponent comp -> - compLibDependencies comp + ElabPackage pkg -> ordNub $ CD.nonSetupDeps (pkgLibDependencies pkg) + ElabComponent comp -> compLibDependencies comp -- | The executable dependencies (i.e., the executables we depend on); -- these are the executables we must add to the PATH before we invoke @@ -668,9 +666,10 @@ elabExeDependencies elab = -- actually want to build something.) elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] elabExeDependencyPaths elab = + map snd $ case elabPkgOrComp elab of - ElabPackage pkg -> ordNub $ map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) - ElabComponent comp -> map snd (compExeDependencyPaths comp) + ElabPackage pkg -> ordNub $ CD.nonSetupDeps (pkgExeDependencyPaths pkg) + ElabComponent comp -> compExeDependencyPaths comp elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] elabPkgConfigDependencies elab = From eb5ea4db4d028336f82243df14943e406071902d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 10 Dec 2025 17:15:24 +0800 Subject: [PATCH 090/122] remove workaround for ancient GHCs --- Cabal/src/Distribution/Simple/GHC/Build/Link.hs | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index 07d414d9608..82749f9dd89 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -51,8 +51,6 @@ import Distribution.Version import System.Directory ( createDirectoryIfMissing , doesDirectoryExist - , doesFileExist - , removeFile , renameFile ) import System.FilePath @@ -507,16 +505,9 @@ linkExecutable linkerOpts (way, buildOpts) targetDir targetName runGhcProg lbi = -- assume there is a main function in another non-haskell object ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty) } - comp = compiler lbi - -- Work around old GHCs not relinking in this -- situation, see #3294 - let target = - targetDir makeRelativePathEx (exeTargetName (hostPlatform lbi) targetName) - when (compilerVersion comp < mkVersion [7, 7]) $ do - let targetPath = interpretSymbolicPathLBI lbi target - e <- doesFileExist targetPath - when e (removeFile targetPath) + let target = targetDir makeRelativePathEx (exeTargetName (hostPlatform lbi) targetName) runGhcProg linkOpts{ghcOptOutputFile = toFlag target} -- | Link a foreign library component From 7e6f086fb88978e0f74140bd52354bce9105cf8f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 10 Dec 2025 17:19:02 +0800 Subject: [PATCH 091/122] small refactor in Link.hs --- .../src/Distribution/Simple/GHC/Build/Link.hs | 63 ++++++++++--------- 1 file changed, 32 insertions(+), 31 deletions(-) diff --git a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs index 82749f9dd89..32b5d25d076 100644 --- a/Cabal/src/Distribution/Simple/GHC/Build/Link.hs +++ b/Cabal/src/Distribution/Simple/GHC/Build/Link.hs @@ -440,43 +440,44 @@ linkLibrary buildTargetDir cleanedExtraLibDirs cleanedExtraLibDirsStatic pkg_des dynamicObjectFiles <- getObjFiles DynWay profDynamicObjectFiles <- getObjFiles ProfDynWay - let - linkWay = \case - ProfWay -> do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - when (withGHCiLib lbi) $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles - verbosity - lbi - ldProg - ghciProfLibFilePath - profObjectFiles - ProfDynWay -> do - runGhcProg $ ghcProfSharedLinkArgs profDynamicObjectFiles - DynWay -> do - runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles - StaticWay -> do - when (withVanillaLib lbi) $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build + -- kind that we might have wanted instead? + -- This would be simpler by not adding every object to the invocation, and + -- rather using module names. + unless (null staticObjectFiles) $ do + let opts = ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir) + for_ (fromNubListR opts) $ \pkgOpts -> + info verbosity (show pkgOpts) + for_ wantedWays $ \way -> do + info verbosity ("Linking " ++ show way ++ " library...") + case way of + ProfWay -> do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles when (withGHCiLib lbi) $ do (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath - staticObjectFiles - when (withStaticLib lbi) $ do - runGhcProg $ ghcStaticLinkArgs staticObjectFiles - - -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build - -- kind that we might have wanted instead? - -- This would be simpler by not adding every object to the invocation, and - -- rather using module names. - unless (null staticObjectFiles) $ do - info verbosity (show (ghcOptPackages (Internal.componentGhcOptions verbosity lbi libBi clbi buildTargetDir))) - traverse_ linkWay wantedWays + ghciProfLibFilePath + profObjectFiles + ProfDynWay -> do + runGhcProg $ ghcProfSharedLinkArgs profDynamicObjectFiles + DynWay -> do + runGhcProg $ ghcSharedLinkArgs dynamicObjectFiles + StaticWay -> do + when (withVanillaLib lbi) $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + when (withGHCiLib lbi) $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles + verbosity + lbi + ldProg + ghciLibFilePath + staticObjectFiles + when (withStaticLib lbi) $ do + runGhcProg $ ghcStaticLinkArgs staticObjectFiles -- | Link the executable resulting from building this component, be it an -- executable, test, or benchmark component. From d6c3ed2e4c9c4412879f7fa9c0c18f964a0b4418 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 3 Dec 2025 11:39:52 +0800 Subject: [PATCH 092/122] remove inplace builds, use project local store simplify some code --- cabal-install/cabal-install.cabal | 1 - .../src/Distribution/Client/CmdExec.hs | 8 +- .../src/Distribution/Client/CmdFreeze.hs | 4 +- .../src/Distribution/Client/CmdGenBounds.hs | 3 +- .../Distribution/Client/CmdHaddockProject.hs | 2 +- .../src/Distribution/Client/CmdListBin.hs | 14 +- .../src/Distribution/Client/CmdRun.hs | 18 +- .../src/Distribution/Client/CmdTarget.hs | 4 +- .../src/Distribution/Client/DistDirLayout.hs | 13 +- .../Distribution/Client/ProjectBuilding.hs | 153 +---- .../Client/ProjectBuilding/Types.hs | 2 + .../Client/ProjectBuilding/UnpackedPackage.hs | 342 ++------- .../src/Distribution/Client/ProjectConfig.hs | 11 - .../Client/ProjectOrchestration.hs | 9 - .../Distribution/Client/ProjectPlanOutput.hs | 64 +- .../Distribution/Client/ProjectPlanning.hs | 649 +++++++----------- .../Client/ProjectPlanning/Types.hs | 193 +----- 17 files changed, 389 insertions(+), 1101 deletions(-) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 8a2d70eda84..7552237944b 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -264,7 +264,6 @@ library , hackage-security >= 0.6.2.0 && < 0.7 , text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2 , parsec >= 3.1.13.0 && < 3.2 - , open-browser >= 0.2.1.0 && < 0.5 , regex-base >= 0.94.0.0 && <0.95 , regex-posix >= 0.96.0.0 && <0.97 , safe-exceptions >= 0.1.7.0 && < 0.2 diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs index 1329cb3d2c0..02f702738d0 100644 --- a/cabal-install/src/Distribution/Client/CmdExec.hs +++ b/cabal-install/src/Distribution/Client/CmdExec.hs @@ -60,7 +60,6 @@ import Distribution.Client.ProjectPlanning import qualified Distribution.Client.ProjectPlanning as Planning import Distribution.Client.ProjectPlanning.Types ( Toolchain (..) - , dataDirsEnvironmentForPlan ) import Distribution.Client.Setup ( GlobalFlags @@ -180,10 +179,7 @@ execAction flags extraArgs globalFlags = do -- NOTE: only build-stage dependencies make sense here pkgProgs = getStage progdbs Build -- - extraEnvVars = - dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - (elaboratedPlanToExecute buildCtx) + extraEnvVars = [] programDb <- prependProgramSearchPath verbosity extraPaths extraEnvVars pkgProgs @@ -304,7 +300,7 @@ binDirectories layout config = fromElaboratedInstallPlan where fromElaboratedInstallPlan = fromGraph . toGraph fromGraph = foldMap fromPlan - fromSrcPkg = S.fromList . Planning.binDirectories layout + fromSrcPkg = S.fromList . Planning.binDirectories fromPlan (PreExisting _) = mempty fromPlan (Configured pkg) = fromSrcPkg pkg diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index eb799324f7c..cd0c562c73d 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -131,7 +131,6 @@ freezeAction flags extraArgs globalFlags = do ProjectBaseContext { distDirLayout - , cabalDirLayout , projectConfig , localPackages , buildSettings @@ -142,7 +141,6 @@ freezeAction flags extraArgs globalFlags = do rebuildInstallPlan verbosity distDirLayout - cabalDirLayout projectConfig localPackages Nothing @@ -279,5 +277,5 @@ projectFreezeConstraints plan = Map.fromList [ (packageName elab, ()) | InstallPlan.Configured elab <- InstallPlan.toList plan - , elabLocalToProject elab + , elabIsSourcePackage elab ] diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 6188ef3d46a..06f07fdff18 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -92,14 +92,13 @@ genBoundsAction flags targetStrings globalFlags = dieWithException verbosity $ GenBoundsDoesNotSupportScript path - let ProjectBaseContext{distDirLayout, cabalDirLayout, projectConfig, localPackages} = baseCtx + let ProjectBaseContext{distDirLayout, projectConfig, localPackages} = baseCtx -- Step 1: Create the install plan for the project. (_, elaboratedPlan, _, _, _) <- rebuildInstallPlan verbosity distDirLayout - cabalDirLayout projectConfig localPackages Nothing diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index b7563d307ef..8b5341db45f 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -218,7 +218,7 @@ haddockProjectAction flags _extraArgs globalFlags = do False -> return Nothing Left _ -> return [] Right package -> - case elabLocalToProject package of + case elabIsSourcePackage package of True -> do let distDirParams = elabDistDirParams package pkg_descr = elabPkgDescription package diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 282c13a127d..da62869bc47 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -193,8 +193,6 @@ listbinAction flags args globalFlags = do ] ElabComponent comp -> bin_file (compSolverName comp) where - dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elab) - bin_file c = case c of CD.ComponentExe s | s == selectedComponent -> [moved_bin_file s] @@ -210,15 +208,9 @@ listbinAction flags args globalFlags = do -- here and in PlanOutput, -- use binDirectoryFor? - bin_file' s = - if isInplaceBuildStyle (elabBuildStyle elab) - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' s = - if isInplaceBuildStyle (elabBuildStyle elab) - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + bin_file' s = InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + + flib_file' s = InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat moved_bin_file s = fromMaybe (bin_file' s) (movedExePath selectedComponent distDirLayout elaboratedSharedConfig elab) diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index c9d1448c8dc..9f6806bf94c 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -56,11 +56,10 @@ import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan , WithStage (..) - , binDirectoryFor + , installedBinDirectory ) import Distribution.Client.ProjectPlanning.Types ( ElaboratedPackageOrComponent (..) - , dataDirsEnvironmentForPlan , elabExeDependencyPaths ) @@ -302,12 +301,7 @@ runAction flags targetAndArgs globalFlags = dieWithException verbosity $ MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let defaultExePath = - binDirectoryFor - (distDirLayout baseCtx) - pkg - exeName - exeName + let defaultExePath = installedBinDirectory pkg exeName exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) let dryRun = @@ -325,7 +319,7 @@ runAction flags targetAndArgs globalFlags = , let pkg_descr = elabPkgDescription pkg , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr , let thisExeBI = PD.buildInfo thisExe = - [ binDirectoryFor (distDirLayout baseCtx) pkg depExeNm + [ installedBinDirectory pkg depExeNm | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI , let depExeNm = unUnqualComponentName depExe ] @@ -352,11 +346,7 @@ runAction flags targetAndArgs globalFlags = emptyProgramInvocation { progInvokePath = exePath , progInvokeArgs = args - , progInvokeEnv = - ("PATH", Just $ progPath) - : dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan + , progInvokeEnv = [("PATH", Just $ progPath)] } where (targetStr, args) = splitAt 1 targetAndArgs diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs index 7c9b986b929..943c285d3e8 100644 --- a/cabal-install/src/Distribution/Client/CmdTarget.hs +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -151,7 +151,6 @@ targetAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () targetAction flags@NixStyleFlags{..} ts globalFlags = do ProjectBaseContext { distDirLayout - , cabalDirLayout , projectConfig , localPackages } <- @@ -161,7 +160,6 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do rebuildInstallPlan verbosity distDirLayout - cabalDirLayout projectConfig localPackages Nothing @@ -208,7 +206,7 @@ printTargetForms verbosity targetStrings targets elaboratedPlan = in text "Found" <+> int n <+> text t <+> text "matching" <+> text query Pretty.<> char '.' localPkgs = - [x | Configured x@ElaboratedConfiguredPackage{elabLocalToProject = True} <- InstallPlan.toList elaboratedPlan] + [x | Configured x@ElaboratedConfiguredPackage{elabIsSourcePackage = True} <- InstallPlan.toList elaboratedPlan] targetForm ct x = let pkgId@PackageIdentifier{pkgName = n} = elabPkgSourceId x diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index cd72e5927e5..4a0b41f38dd 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -34,7 +34,6 @@ import Distribution.Client.Config , defaultStoreDir ) import Distribution.Client.Toolchain (Stage, Toolchain (..)) -import Distribution.Compiler import Distribution.Package ( PackageId , PackageIdentifier @@ -43,6 +42,7 @@ import Distribution.Package import Distribution.Simple.Compiler ( PackageDBCWD , PackageDBX (..) + , showCompilerIdWithAbi ) @@ -99,9 +99,9 @@ data DistDirLayout = DistDirLayout , distSdistDirectory :: FilePath , distTempDirectory :: FilePath , distBinDirectory :: FilePath - , distPackageDB :: CompilerId -> PackageDBCWD , distHaddockOutputDir :: Maybe FilePath -- ^ Is needed when `--haddock-output-dir` flag is used. + , distStoreDirLayout :: StoreDirLayout } -- | The layout of a cabal nix-style store. @@ -223,15 +223,12 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distBinDirectory :: FilePath distBinDirectory = distDirectory "bin" - distPackageDBPath :: CompilerId -> FilePath - distPackageDBPath compid = distDirectory "packagedb" prettyShow compid - - distPackageDB :: CompilerId -> PackageDBCWD - distPackageDB = SpecificPackageDB . distPackageDBPath - distHaddockOutputDir :: Maybe FilePath distHaddockOutputDir = haddockOutputDir + distStoreDirLayout :: StoreDirLayout + distStoreDirLayout = defaultStoreDirLayout (distDirectory "store") + defaultStoreDirLayout :: FilePath -> StoreDirLayout defaultStoreDirLayout storeRoot = StoreDirLayout{..} diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 504c6127e10..9b50f568bc4 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -49,7 +49,6 @@ import Distribution.Client.ProjectBuilding.Types import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectPlanning -import Distribution.Client.Store import Distribution.Client.DistDirLayout import Distribution.Client.FetchUtils @@ -94,7 +93,7 @@ import Distribution.Client.Errors import Distribution.Simple.Flag (fromFlagOrDefault) import Distribution.Client.ProjectBuilding.PackageFileMonitor -import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage) import qualified Distribution.Compat.Graph as Graph ------------------------------------------------------------------------------ @@ -169,7 +168,7 @@ rebuildTargetsDryRun :: DistDirLayout -> ElaboratedInstallPlan -> IO BuildStatusMap -rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = +rebuildTargetsDryRun distDirLayout = -- Do the various checks to work out the 'BuildStatus' of each package foldMInstallPlanDepOrder dryRunPkg where @@ -206,19 +205,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = -> [BuildStatus] -> FilePath -> IO BuildStatus - dryRunTarballPkg pkg depsBuildStatus tarball = - case elabBuildStyle pkg of - BuildAndInstall -> return (BuildStatusUnpack tarball) - BuildInplaceOnly{} -> do - -- TODO: [nice to have] use a proper file monitor rather - -- than this dir exists test - exists <- doesDirectoryExist srcdir - if exists - then dryRunLocalPkg pkg depsBuildStatus srcdir - else return (BuildStatusUnpack tarball) - where - srcdir :: FilePath - srcdir = distUnpackedSrcDirectory (packageId pkg) + dryRunTarballPkg _pkg _depsBuildStatus tarball = + return (BuildStatusUnpack tarball) dryRunLocalPkg :: ElaboratedConfiguredPackage @@ -330,7 +318,6 @@ rebuildTargets :: Verbosity -> ProjectConfig -> DistDirLayout - -> StoreDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> BuildStatusMap @@ -340,7 +327,6 @@ rebuildTargets verbosity projectConfig distDirLayout - storeDirLayout installPlan sharedPackageConfig pkgsBuildStatus @@ -361,14 +347,12 @@ rebuildTargets rebuildTarget verbosity distDirLayout - storeDirLayout (jobControlSemaphore jobControl) buildSettings downloadMap registerLock cacheLock sharedPackageConfig - installPlan pkg pkgBuildStatus @@ -501,28 +485,24 @@ rebuildTargets' rebuildTarget :: Verbosity -> DistDirLayout - -> StoreDirLayout -> Maybe SemaphoreName -> BuildTimeSettings -> AsyncFetchMap -> Lock -> Lock -> ElaboratedSharedConfig - -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> BuildStatus -> IO BuildResult rebuildTarget verbosity distDirLayout@DistDirLayout{distBuildDirectory} - storeDirLayout semaphoreName buildSettings downloadMap registerLock cacheLock sharedPackageConfig - plan rpkg@(ReadyPackage pkg) pkgBuildStatus -- Technically, doing the --only-download filtering only in this function is @@ -570,64 +550,31 @@ rebuildTarget tarball (packageId pkg) (elabDistDirParams pkg) - (elabBuildStyle pkg) (elabPkgDescriptionOverride pkg) - $ case elabBuildStyle pkg of - BuildAndInstall -> buildAndInstall - BuildInplaceOnly{} -> buildInplace buildStatus - where - buildStatus = BuildStatusConfigure MonitorFirstRun - - -- Note that this really is rebuild, not build. It can only happen for - -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages - -- would only start from download or unpack phases. - -- + buildAndInstall + rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult rebuildPhase buildStatus srcdir = do - info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir - buildInplace buildStatus srcdir builddir + info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir ++ " with rebuild reason " ++ show buildStatus + buildAndInstall srcdir (makeSymbolicPath builddir) where - distdir = distBuildDirectory (elabDistDirParams pkg) - builddir = - makeSymbolicPath $ - makeRelative (normalise $ getSymbolicPath srcdir) distdir - -- TODO: [nice to have] ^^ do this relative stuff better + builddir = distBuildDirectory (elabDistDirParams pkg) buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult buildAndInstall srcdir builddir = do - info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir + info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) buildAndInstallUnpackedPackage verbosity distDirLayout - storeDirLayout semaphoreName buildSettings registerLock cacheLock sharedPackageConfig - plan rpkg srcdir builddir - buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildInplace buildStatus srcdir builddir = do - -- TODO: [nice to have] use a relative build dir rather than absolute - info verbosity $ "[buildInplace] Building inplace " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir - buildInplaceUnpackedPackage - verbosity - distDirLayout - semaphoreName - buildSettings - registerLock - cacheLock - sharedPackageConfig - plan - rpkg - buildStatus - srcdir - builddir - rebuildTargetOnlyDownload :: Verbosity -> AsyncFetchMap @@ -721,7 +668,6 @@ withTarballLocalDirectory -> FilePath -> PackageId -> DistDirParams - -> BuildStyle -> Maybe CabalFileText -> ( SymbolicPath CWD (Dir Pkg) -- Source directory -> SymbolicPath Pkg (Dir Dist) -- Build directory @@ -730,64 +676,35 @@ withTarballLocalDirectory -> IO a withTarballLocalDirectory verbosity - distDirLayout@DistDirLayout{..} + distDirLayout tarball pkgid dparams - buildstyle pkgTextOverride - buildPkg = - case buildstyle of - -- In this case we make a temp dir (e.g. tmp/src2345/), unpack - -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for - -- compatibility we put the dist dir within it - -- (i.e. tmp/src2345/foo-1.0/dist/). - -- - -- Unfortunately, a few custom Setup.hs scripts do not respect - -- the --builddir flag and always look for it at ./dist/ so - -- this way we avoid breaking those packages - BuildAndInstall -> - let tmpdir = distTempDirectory - builddir = relativeSymbolicPath $ makeRelativePathEx "dist" - in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do - let srcdir = makeSymbolicPath $ unpackdir prettyShow pkgid - unpackPackageTarball - verbosity - tarball - unpackdir - pkgid - pkgTextOverride - buildPkg srcdir builddir - - -- In this case we make sure the tarball has been unpacked to the - -- appropriate location under the shared dist dir, and then build it - -- inplace there - BuildInplaceOnly{} -> do - let srcrootdir = distUnpackedSrcRootDirectory - srcdir = distUnpackedSrcDirectory pkgid - builddir = - makeSymbolicPath $ - makeRelative (normalise srcdir) $ - distBuildDirectory dparams - -- TODO: [nice to have] ^^ do this relative stuff better - exists <- doesDirectoryExist srcdir - -- TODO: [nice to have] use a proper file monitor rather - -- than this dir exists test - unless exists $ do - createDirectoryIfMissingVerbose verbosity True srcrootdir - unpackPackageTarball - verbosity - tarball - srcrootdir - pkgid - pkgTextOverride - moveTarballShippedDistDirectory - verbosity - distDirLayout - srcrootdir - pkgid - dparams - buildPkg (makeSymbolicPath srcdir) builddir + buildPkg = do + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + unpackPackageTarball + verbosity + tarball + srcrootdir + pkgid + pkgTextOverride + moveTarballShippedDistDirectory + verbosity + distDirLayout + srcrootdir + pkgid + dparams + buildPkg (makeSymbolicPath srcdir) builddir + where + srcrootdir = distUnpackedSrcRootDirectory distDirLayout + srcdir = distUnpackedSrcDirectory distDirLayout pkgid + builddir = + makeSymbolicPath $ + makeRelative (normalise srcdir) $ + distBuildDirectory distDirLayout dparams unpackPackageTarball :: Verbosity diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 8a54b494f76..148dbb1e759 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -109,6 +109,7 @@ data BuildStatusRebuild -- @Just Nothing@ indicates that we know that no registration is -- necessary (e.g., executable.) BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason + deriving (Show) data BuildReason = -- | The dependencies of this package have been (re)built so the build @@ -130,6 +131,7 @@ data BuildReason -- we're going to build some part of a component or run a repl or any -- other action that does not result in additional persistent artifacts. BuildReasonEphemeralTargets + deriving (Show) ------------------------------------------------------------------------------ -- Build outcomes: result of the build diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index f637a8864d1..fdec0bed578 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -5,22 +5,10 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} --- | This module exposes functions to build and register unpacked packages. --- --- Mainly, unpacked packages are either: --- * Built and registered in-place --- * Built and installed --- --- The two cases differ significantly for there to be a distinction. --- For instance, we only care about file monitoring and re-building when dealing --- with "inplace" registered packages, whereas for installed packages we don't. +-- | This module exposes functions to build and register packages. module Distribution.Client.ProjectBuilding.UnpackedPackage - ( buildInplaceUnpackedPackage - , buildAndInstallUnpackedPackage - - -- ** Auxiliary definitions - , buildAndRegisterUnpackedPackage - , PackageBuildingPhase + ( buildAndInstallUnpackedPackage + , PackageBuildingPhase(..) -- ** Utilities , annotateFailure @@ -36,11 +24,9 @@ import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.RebuildMonad import Distribution.Client.Store import Distribution.Client.DistDirLayout -import Distribution.Client.FileMonitor import Distribution.Client.JobControl import Distribution.Client.Setup ( CommonSetupFlags @@ -55,9 +41,6 @@ import Distribution.Client.Setup , filterTestFlags ) import Distribution.Client.SetupWrapper -import Distribution.Client.SourceFiles -import Distribution.Client.SrcDist (allPackageSourceFiles) -import qualified Distribution.Client.Tar as Tar import Distribution.Client.Types hiding ( BuildFailure (..) , BuildOutcome @@ -73,8 +56,6 @@ import Distribution.Compat.Lens import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.BuildPaths (haddockDirName) import Distribution.Simple.Command (CommandUI) import Distribution.Simple.Compiler ( PackageDBStackCWD @@ -89,7 +70,6 @@ import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.Setup as Cabal -import Distribution.Types.BuildType import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Simple.Utils @@ -104,20 +84,17 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 import qualified Data.List.NonEmpty as NE -import Control.Exception (ErrorCall, Handler (..), SomeAsyncException, catches, onException) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile) -import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) +import Control.Exception (Handler (..), SomeAsyncException, catches) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, removeDirectoryRecursive, renameDirectory, renameFile) +import System.FilePath (dropDrive, normalise, takeDirectory, (), makeRelative) import System.IO (Handle, IOMode (AppendMode), withFile) import System.Semaphore (SemaphoreName (..)) -import Web.Browser (openBrowser) import Distribution.Client.Errors import Distribution.Compat.Directory (listDirectory) -import Distribution.Client.ProjectBuilding.PackageFileMonitor import qualified Distribution.Compat.Graph as Graph -import Distribution.System (Platform (..)) -- | Each unpacked package is processed in the following phases: -- @@ -163,7 +140,6 @@ buildAndRegisterUnpackedPackage -> Lock -> Lock -> ElaboratedSharedConfig - -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) @@ -173,13 +149,12 @@ buildAndRegisterUnpackedPackage -> IO () buildAndRegisterUnpackedPackage verbosity - distDirLayout@DistDirLayout{distTempDirectory} + DistDirLayout{distTempDirectory} maybe_semaphore buildTimeSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingKeepTempFiles} registerLock cacheLock pkgshared - plan rpkg@(ReadyPackage pkg) srcdir builddir @@ -293,7 +268,6 @@ buildAndRegisterUnpackedPackage flip filterConfigureFlags v <$> setupHsConfigureFlags (\p -> makeSymbolicPath <$> canonicalizePath p) - plan rpkg commonFlags configureArgs _ = setupHsConfigureArgs pkg @@ -359,9 +333,7 @@ buildAndRegisterUnpackedPackage scriptOptions = setupHsScriptOptions rpkg - plan pkgshared - distDirLayout srcdir builddir (isParallelBuild buildSettingNumJobs) @@ -374,16 +346,10 @@ buildAndRegisterUnpackedPackage -> (Version -> [String]) -> IO () setup cmd getCommonFlags flags args = - withLogging $ \mLogFileHandle -> do + withLogging $ \mLogFileHandle -> setupWrapper verbosity - scriptOptions - { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = - dataDirsEnvironmentForPlan - distDirLayout - plan - } + scriptOptions { useLoggingHandle = mLogFileHandle } (Just (elabPkgDescription pkg)) cmd getCommonFlags @@ -399,7 +365,7 @@ buildAndRegisterUnpackedPackage setupInteractive cmd getCommonFlags flags args = setupWrapper verbosity - scriptOptions{isInteractive = True} + scriptOptions { isInteractive = True } (Just (elabPkgDescription pkg)) cmd getCommonFlags @@ -427,222 +393,10 @@ buildAndRegisterUnpackedPackage Nothing -> action Nothing Just logFile -> withFile logFile AppendMode (action . Just) --------------------------------------------------------------------------------- - --- * Build Inplace - --------------------------------------------------------------------------------- - -buildInplaceUnpackedPackage - :: Verbosity - -> DistDirLayout - -> Maybe SemaphoreName - -> BuildTimeSettings - -> Lock - -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatusRebuild - -> SymbolicPath CWD (Dir Pkg) - -> SymbolicPath Pkg (Dir Dist) - -> IO BuildResult -buildInplaceUnpackedPackage - verbosity - distDirLayout@DistDirLayout - { distPackageCacheDirectory - , distDirectory - , distHaddockOutputDir - } - maybe_semaphore - buildSettings@BuildTimeSettings{buildSettingHaddockOpen} - registerLock - cacheLock - pkgshared - plan - rpkg@(ReadyPackage pkg) - buildStatus - srcdir - builddir = do - -- TODO: [code cleanup] there is duplication between the - -- distdirlayout and the builddir here builddir is not - -- enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity True $ interpretSymbolicPath (Just srcdir) builddir - createDirectoryIfMissingVerbose - verbosity - True - (distPackageCacheDirectory dparams) - - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildResult :: BuildResultMisc - buildResult = (docsResult, testsResult) - - buildAndRegisterUnpackedPackage - verbosity - distDirLayout - maybe_semaphore - buildSettings - registerLock - cacheLock - pkgshared - plan - rpkg - srcdir - builddir - Nothing -- no log file for inplace builds! - $ \case - PBConfigurePhase{runConfigure} -> do - whenReConfigure $ do - runConfigure - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg - PBBuildPhase{runBuild} -> do - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - runBuild - -- Be sure to invalidate the cache if building throws an exception! - -- If not, we'll abort execution with a stale recompilation cache. - -- See ghc#24926 for an example of how this can go wrong. - `onException` invalidatePackageRegFileMonitor packageFileMonitor - - let listSimple = - execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity (getSymbolicPath srcdir) - ifNullThen m m' = do - xs <- m - if null xs then m' else return xs - monitors <- case PD.buildType (elabPkgDescription pkg) of - Simple -> listSimple - -- If a Custom setup was used, AND the Cabal is recent - -- enough to have sdist --list-sources, use that to - -- determine the files that we need to track. This can - -- cause unnecessary rebuilding (for example, if README - -- is edited, we will try to rebuild) but there isn't - -- a more accurate Custom interface we can use to get - -- this info. We prefer not to use listSimple here - -- as it can miss extra source files that are considered - -- by the Custom setup. - _ - | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> - -- However, sometimes sdist --list-sources will fail - -- and return an empty list. In that case, fall - -- back on the (inaccurate) simple tracking. - listSdist `ifNullThen` listSimple - | otherwise -> - listSimple - - let dep_monitors = - map monitorFileHashed $ - elabInplaceDependencyBuildCacheFiles - distDirLayout - plan - pkg - updatePackageBuildFileMonitor - packageFileMonitor - (getSymbolicPath srcdir) - timestamp - pkg - buildStatus - (monitors ++ dep_monitors) - buildResult - PBHaddockPhase{runHaddock} -> do - runHaddock - let haddockTarget = elabHaddockForHackage pkg - when (haddockTarget == Cabal.ForHackage) $ do - let dest = distDirectory name <.> "tar.gz" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = - distBuildDirectory distDirLayout dparams - "doc" - "html" - Tar.createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - - when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do - let dest = docDir "index.html" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = case distHaddockOutputDir of - Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name - Just dir -> dir - catch - (void $ openBrowser dest) - ( \(_ :: ErrorCall) -> - dieWithException verbosity $ - FindOpenProgramLocationErr $ - "Unsupported OS: " <> show os - ) - PBInstallPhase{runCopy = _runCopy, runRegister} -> do - -- PURPOSELY omitted: no copy! - - whenReRegister $ do - -- Register locally - mipkg <- - if elabRequiresRegistration pkg - then do - ipkg <- - runRegister - (elabRegisterPackageDBStack pkg) - Cabal.defaultRegisterOptions - return (Just ipkg) - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) mipkg - PBTestPhase{runTest} -> runTest - PBBenchPhase{runBench} -> runBench - PBReplPhase{runRepl} -> runRepl - - return - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = Nothing - } - where - dparams = elabDistDirParams pkg - - Toolchain{toolchainPlatform = Platform _ os} = elabToolchain pkg - - packageFileMonitor = newPackageFileMonitor distDirLayout dparams - - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - - whenRebuild action - | null (elabBuildTargets pkg) - , -- NB: we have to build the test/bench suite! - null (elabTestTargets pkg) - , null (elabBenchTargets pkg) = - return () - | otherwise = action - - whenReRegister action = - case buildStatus of - -- We registered the package already - BuildStatusBuild (Just _) _ -> - info verbosity "whenReRegister: previously registered" - -- There is nothing to register - BuildStatusBuild Nothing _ -> - info verbosity "whenReRegister: nothing to register, we know it!" - BuildStatusConfigure _reason - | null (elabBuildTargets pkg) -> - info verbosity "whenReRegister: nothing to register, it seems ..." - | otherwise -> action - --------------------------------------------------------------------------------- - --- * Build and Install - --------------------------------------------------------------------------------- buildAndInstallUnpackedPackage :: Verbosity -> DistDirLayout - -> StoreDirLayout -> Maybe SemaphoreName -- ^ Whether to pass a semaphore to build process -- this is different to BuildTimeSettings because the @@ -651,7 +405,6 @@ buildAndInstallUnpackedPackage -> Lock -> Lock -> ElaboratedSharedConfig - -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) @@ -659,13 +412,11 @@ buildAndInstallUnpackedPackage buildAndInstallUnpackedPackage verbosity distDirLayout - storeDirLayout maybe_semaphore buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock pkgshared - plan rpkg@(ReadyPackage pkg) srcdir builddir = do @@ -692,7 +443,6 @@ buildAndInstallUnpackedPackage registerLock cacheLock pkgshared - plan rpkg srcdir builddir @@ -710,29 +460,34 @@ buildAndInstallUnpackedPackage PBInstallPhase{runCopy, runRegister} -> do noticeProgress ProgressInstalling - let registerPkg - | not (elabRequiresRegistration pkg) = - debug verbosity $ - "registerPkg: elab does NOT require registration for " - ++ prettyShow uid - | otherwise = - void $ runRegister - (elabRegisterPackageDBStack pkg) - Cabal.defaultRegisterOptions - { Cabal.registerMultiInstance = True - , Cabal.registerSuppressFilesCheck = True - } - - -- Actual installation - void $ - newStoreEntry - verbosity - storeDirLayout - (elabStage pkg) - (elabToolchain pkg) - uid - (copyPkgFiles verbosity pkg runCopy) - registerPkg + let storeDirLayout = distStoreDirLayout distDirLayout + storeFile = storeDirectory storeDirLayout (elabStage pkg) (elabToolchain pkg) + finalEntryDir = storePackageDirectory storeDirLayout (elabStage pkg) (elabToolchain pkg) uid + incomingDir = storeIncomingDirectory storeDirLayout (elabStage pkg) (elabToolchain pkg) + + withTempDirectory verbosity incomingDir "new" $ \incomingTmpDir -> do + -- Write all store entry files within the temp dir and return the prefix. + (incomingEntryDir, otherFiles) <- copyPkgFiles verbosity pkg runCopy incomingTmpDir + + if elabRequiresRegistration pkg then + void $ runRegister + (elabRegisterPackageDBStack pkg) + Cabal.defaultRegisterOptions + { Cabal.registerMultiInstance = True + , Cabal.registerSuppressFilesCheck = True + } + else + info verbosity $ "registerPkg: elab does NOT require registration for " ++ prettyShow uid + + removeDirectoryRecursive finalEntryDir `catch` \(_ :: IOException) -> + return () -- ignore all IO exceptions, likely the dir did not exist + + renameDirectory incomingEntryDir finalEntryDir + + for_ otherFiles $ \file -> do + let finalStoreFile = storeFile makeRelative (normalise (incomingTmpDir dropDrive storeFile)) file + createDirectoryIfMissing True (takeDirectory finalStoreFile) + renameFile file finalStoreFile -- No tests on install PBTestPhase{} -> return () @@ -830,18 +585,21 @@ copyPkgFiles verbosity pkg runCopy tmpDir = do -- https://github.com/haskell/cabal/issues/4130 createDirectoryIfMissingVerbose verbosity True entryDir - let hashFileName = entryDir "cabal-hash.txt" - outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkg) + case elabPkgSourceHash pkg of + Nothing -> return () + Just srchash -> do + let hashFileName = entryDir "cabal-hash.txt" + outPkgHashInputs = renderPackageHashInputs (packageHashInputs srchash pkg) - info verbosity $ - "creating file with the inputs used to compute the package hash: " ++ hashFileName + info verbosity $ + "creating file with the inputs used to compute the package hash: " ++ hashFileName - LBS.writeFile hashFileName outPkgHashInputs + LBS.writeFile hashFileName outPkgHashInputs - debug verbosity "Package hash inputs:" - traverse_ - (debug verbosity . ("> " ++)) - (lines $ LBS.Char8.unpack outPkgHashInputs) + debug verbosity "Package hash inputs:" + traverse_ + (debug verbosity . ("> " ++)) + (lines $ LBS.Char8.unpack outPkgHashInputs) -- Ensure that there are no files in `tmpDir`, that are -- not in `entryDir`. While this breaks the diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 3b2b7e886cd..f1d7ef32ea9 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1868,17 +1868,6 @@ truncateString n s | length s <= n = s | otherwise = take (n - 1) s ++ "_" --- TODO: add something like this, here or in the project planning --- Based on the package location, which packages will be built inplace in the --- build tree vs placed in the store. This has various implications on what we --- can do with the package, e.g. can we run tests, ghci etc. --- --- packageIsLocalToProject :: ProjectPackageLocation -> Bool - ---------------------------------------------- --- Checking configuration sanity --- - data BadPerPackageCompilerPaths = BadPerPackageCompilerPaths [(PackageName, String)] deriving (Show) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index e8db22e7b74..d1bf91be6f9 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -344,7 +344,6 @@ withInstallPlan verbosity ProjectBaseContext { distDirLayout - , cabalDirLayout , projectConfig , localPackages , installedPackages @@ -358,7 +357,6 @@ withInstallPlan rebuildInstallPlan verbosity distDirLayout - cabalDirLayout projectConfig localPackages installedPackages @@ -373,7 +371,6 @@ runProjectPreBuildPhase verbosity ProjectBaseContext { distDirLayout - , cabalDirLayout , projectConfig , localPackages , installedPackages @@ -387,7 +384,6 @@ runProjectPreBuildPhase rebuildInstallPlan verbosity distDirLayout - cabalDirLayout projectConfig localPackages installedPackages @@ -445,7 +441,6 @@ runProjectBuildPhase verbosity projectConfig distDirLayout - (cabalStoreDirLayout cabalDirLayout) elaboratedPlanToExecute elaboratedShared pkgsBuildStatus @@ -1161,9 +1156,6 @@ printPlan , if verbosity >= deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) - , case elabBuildStyle elab of - BuildInplaceOnly InMemory -> "(interactive)" - _ -> "" , case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) ElabComponent comp -> @@ -1217,7 +1209,6 @@ printPlan runIdentity $ ( setupHsConfigureFlags (\_ -> return (error "unused")) - elaboratedPlan (ReadyPackage elab) commonFlags ) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 2ab2eff552e..5a93f70c551 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -41,8 +41,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package import qualified Distribution.PackageDescription as PD import Distribution.Simple.BuildPaths - ( buildInfoPref - , dllExtension + ( dllExtension , exeExtension ) import Distribution.Simple.Compiler @@ -55,13 +54,6 @@ import Distribution.Simple.GHC ) import Distribution.Simple.Utils import Distribution.System -import Distribution.Types.Version - ( mkVersion - ) -import Distribution.Utils.Path hiding - ( (<.>) - , () - ) import Distribution.Verbosity import Distribution.Client.Compat.Prelude @@ -103,7 +95,7 @@ writePlanExternalRepresentation -- | Renders a subset of the elaborated install plan in a semi-stable JSON -- format. encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value -encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = +encodePlanAsJson _distDirLayout elaboratedInstallPlan elaboratedSharedConfig = -- TODO: [nice to have] include all of the sharedPackageConfig and all of -- the parts of the elaboratedInstallPlan J.object $ @@ -175,7 +167,6 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = [ PD.unFlagName fn J..= v | (fn, v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] - , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) ] ++ [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) @@ -184,13 +175,6 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) | Just hash <- [elabPkgSourceHash elab] ] - ++ ( case elabBuildStyle elab of - BuildInplaceOnly{} -> - ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] - BuildAndInstall -> - -- TODO: install dirs? - [] - ) ++ case elabPkgOrComp elab of ElabPackage pkg -> let components = @@ -216,21 +200,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ] ++ bin_file (compSolverName comp) where - Toolchain{toolchainPlatform = plat} = elabToolchain elab - - -- \| Only add build-info file location if the Setup.hs CLI - -- is recent enough to be able to generate build info files. - -- Otherwise, write 'null'. - -- - -- Consumers of `plan.json` can use the nullability of this file location - -- to indicate that the given component uses `build-type: Custom` - -- with an old lib:Cabal version. - buildInfoFileLocation :: J.Pair - buildInfoFileLocation - | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] = - "build-info" J..= J.Null - | otherwise = - "build-info" J..= J.String (getSymbolicPath $ buildInfoPref $ makeSymbolicPath dist_dir) + Toolchain{toolchainPlatform = plat} = + Stage.getStage toolchains (elabStage elab) packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value packageLocationToJ pkgloc = @@ -291,9 +262,6 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = , "subdir" J..= fmap J.String srpSubdir ] - dist_dir :: FilePath - dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elab) - bin_file :: ComponentDeps.Component -> [J.Pair] bin_file c = case c of ComponentDeps.ComponentExe s -> bin_file' s @@ -304,29 +272,17 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = bin_file' s = ["bin-file" J..= J.String bin] where - bin = - if isInplaceBuildStyle (elabBuildStyle elab) - then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat - else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + bin = InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat flib_file' :: (Pretty a, Show a) => a -> [J.Pair] flib_file' s = ["bin-file" J..= J.String bin] where - bin = - if isInplaceBuildStyle (elabBuildStyle elab) - then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat - else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + bin = InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat comp2str :: ComponentDeps.Component -> String comp2str = prettyShow - style2str :: Bool -> BuildStyle -> String - style2str True _ = "local" - style2str False (BuildInplaceOnly OnDisk) = "inplace" - style2str False (BuildInplaceOnly InMemory) = "interactive" - style2str False BuildAndInstall = "global" - jdisplay :: Pretty a => a -> J.Value jdisplay = J.String . prettyShow @@ -519,6 +475,7 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- ^ As a convenience for 'Set.intersection' with any of the other -- 'PackageIdSet's to select only packages that are being built -- in-place within the project (i.e. not destined for the store). + -- FIXME: remove the refence to "inplace" , packagesAlreadyInStore :: PackageIdSet -- ^ As a convenience for 'Set.intersection' or 'Set.difference' with -- any of the other 'PackageIdSet's to select only packages that were @@ -678,7 +635,7 @@ postBuildProjectStatus case pkg of InstallPlan.PreExisting _ -> False InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg + InstallPlan.Configured elab -> elabIsSourcePackage elab packagesBuildInplace :: Set (WithStage UnitId) packagesBuildInplace = @@ -686,7 +643,7 @@ postBuildProjectStatus case pkg of InstallPlan.PreExisting _ -> False InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) + InstallPlan.Configured elab -> elabIsSourcePackageClosure elab packagesAlreadyInStore :: Set (WithStage UnitId) packagesAlreadyInStore = @@ -1010,11 +967,12 @@ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = -- this feature, e.g. write out multiple env files, one for each -- compiler / project profile. + -- FIXME inplacePackages :: [ElaboratedConfiguredPackage] inplacePackages = [ srcpkg | srcpkg <- sourcePackages - , isInplaceBuildStyle (elabBuildStyle srcpkg) + , elabIsSourcePackageClosure srcpkg ] sourcePackages :: [ElaboratedConfiguredPackage] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index e674880c925..d13e3db369b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -41,7 +41,6 @@ module Distribution.Client.ProjectPlanning , ElaboratedPlanPackage , ElaboratedSharedConfig (..) , ElaboratedReadyPackage - , BuildStyle (..) , CabalFileText , Toolchain (..) , Stage (..) @@ -100,7 +99,7 @@ module Distribution.Client.ProjectPlanning , packageHashInputs -- * Path construction - , binDirectoryFor + , installedBinDirectory , binDirectories , storePackageInstallDirs , storePackageInstallDirs' @@ -236,7 +235,6 @@ import Control.Exception (assert) import Control.Monad (sequence) import Control.Monad.IO.Class (liftIO) import Control.Monad.State (State, execState, gets, modify) -import Data.Foldable (fold) import Data.List (deleteBy, groupBy) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map @@ -633,7 +631,6 @@ rebuildInstallPlan :: HasCallStack => Verbosity -> DistDirLayout - -> CabalDirLayout -> ProjectConfig -> [PackageSpecifier UnresolvedSourcePackage] -> Maybe InstalledPackageIndex @@ -650,10 +647,9 @@ rebuildInstallPlan distDirLayout@DistDirLayout { distProjectRootDirectory , distProjectCacheFile + , distStoreDirLayout } - CabalDirLayout - { cabalStoreDirLayout - } = \projectConfig localPackages mbInstalledPackages -> + = \projectConfig localPackages mbInstalledPackages -> runRebuild distProjectRootDirectory $ do progsearchpath <- liftIO $ getSystemSearchPath let projectConfigMonitored = projectConfig{projectConfigBuildOnly = mempty} @@ -704,6 +700,7 @@ rebuildInstallPlan -- the underlying elaborated plan only changes when input config -- changes, so it's worth caching them separately. improvedPlan <- phaseImprovePlan elaboratedPlan + liftIO $ info verbosity (render (text "Improved install plan:" $$ text (showElaboratedInstallPlan improvedPlan))) return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) where @@ -866,7 +863,7 @@ rebuildInstallPlan packageConfigBenchmarks projectConfig pkgname - isLocal = isJust (shouldBeLocal pkg) + isLocal = isJust (isLocalUnpackedPackage pkg) stanzas | isLocal = Map.fromList $ @@ -914,11 +911,6 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - installDirs <- - for toolchains $ \t -> do - defaultInstallDirs <- liftIO $ userInstallDirTemplates (toolchainCompiler t) - return $ fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - liftIO $ runLogProgress verbosity $ do (elaboratedPlan, elaboratedShared) <- elaborateInstallPlan @@ -926,11 +918,9 @@ rebuildInstallPlan toolchains pkgConfigDB distDirLayout - cabalStoreDirLayout solverPlan localPackages sourcePackageHashes - installDirs projectConfigShared projectConfigAllPackages projectConfigLocalPackages @@ -938,8 +928,7 @@ rebuildInstallPlan instantiatedPlan <- instantiateInstallPlan - cabalStoreDirLayout - installDirs + distStoreDirLayout elaboratedPlan infoProgress $ text "Elaborated install plan:" $$ text (showElaboratedInstallPlan instantiatedPlan) @@ -981,22 +970,28 @@ rebuildInstallPlan phaseImprovePlan :: ElaboratedInstallPlan -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan = do - liftIO $ debug verbosity "Improving the install plan..." - improvedPlan <- liftIO $ InstallPlan.installedM canBeImproved elaboratedPlan - liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) - -- TODO: [nice to have] having checked which packages from the store - -- we're using, it may be sensible to sanity check those packages - -- by loading up the compiler package db and checking everything - -- matches up as expected, e.g. no dangling deps, files deleted. - return improvedPlan + phaseImprovePlan elaboratedPlan = liftIO $ do + info verbosity "Improving the install plan using the package store..." + InstallPlan.installedM canBeImproved elaboratedPlan where - canBeImproved pkg = do - doesStoreEntryExist - cabalStoreDirLayout - (elabStage pkg) - (elabToolchain pkg) - (installedUnitId pkg) + -- Only packages that do not depend on source packages can be cached + canBeImproved elab = do + info verbosity ("Checking if " ++ prettyShow (installedUnitId elab) ++ " is already installed...") + isPresent <- doesStoreEntryExist + distStoreDirLayout + (elabStage elab) + (elabToolchain elab) + (installedUnitId elab) + if isPresent then + if elabIsSourcePackageClosure elab then do + info verbosity (prettyShow (installedUnitId elab) ++ " is already present but I will not reuse it because it depends on source packages.") + return False + else do + info verbosity (prettyShow (installedUnitId elab) ++ " is already present and can be reused.") + return True + else do + info verbosity (prettyShow (installedUnitId elab) ++ " is not present in the store.") + return False -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. @@ -1557,11 +1552,9 @@ elaborateInstallPlan -> Staged Toolchain -> Staged (Maybe PkgConfigDb) -> DistDirLayout - -> StoreDirLayout -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Map PackageId PackageSourceHash - -> Staged InstallDirs.InstallDirTemplates -> ProjectConfigShared -> PackageConfig -> PackageConfig @@ -1571,12 +1564,10 @@ elaborateInstallPlan verbosity toolchains pkgConfigDB - distDirLayout@DistDirLayout{..} - storeDirLayout + distDirLayout solverPlan localPackages sourcePackageHashes - defaultInstallDirs sharedPackageConfig allPackagesConfig localPackagesConfig @@ -1614,7 +1605,7 @@ elaborateInstallPlan return [InstallPlan.PreExisting (WithStage (instSolverStage pkg) (instSolverPkgIPI pkg))] SolverInstallPlan.Configured pkg -> let inplace_doc - | shouldBuildInplaceOnly pkg = text "inplace" + | inProjectSourcePackagesClosure pkg = text "is local" | otherwise = Disp.empty in addProgressCtx ( text "In the" @@ -1631,9 +1622,7 @@ elaborateInstallPlan => (SolverId -> [ElaboratedPlanPackage]) -> SolverPackage UnresolvedPkgLoc -> LogProgress [ElaboratedConfiguredPackage] - elaborateSolverToComponents - mapDep - solverPkg@SolverPackage{solverPkgStage, solverPkgLibDeps, solverPkgExeDeps} = + elaborateSolverToComponents mapDep solverPkg = case mkComponentsGraph (elabEnabledSpec elab0) pd of Left cns -> dieProgress $ @@ -1749,7 +1738,7 @@ elaborateInstallPlan , compComponentName = Nothing , compLibDependencies = [ (configuredId cid, False) - | cid <- CD.setupDeps solverPkgLibDeps >>= elaborateLibSolverId mapDep + | cid <- CD.setupDeps (solverPkgLibDeps solverPkg) >>= elaborateLibSolverId mapDep ] , compLinkedLibDependencies = notImpl "compLinkedLibDependencies" , compOrderLibDependencies = notImpl "compOrderLibDependencies" @@ -1827,17 +1816,18 @@ elaborateInstallPlan compExeDependencies :: [WithStage ConfiguredId] compExeDependencies = - -- External + -- External dependencies (confSrcId confId /= pkgid). [ WithStage (stageOf pkg) confId | pkg <- external_exe_dep_pkgs , let confId = configuredId pkg - , -- only executables - Just (CExeName _) <- [confCompName confId] , confSrcId confId /= pkgid + , -- only executables + Just (CExeName _) <- [confCompName confId] ] <> - -- Internal, assume the same stage - [ WithStage solverPkgStage confId + -- Internal dependencies (confSrcId confId == pkgid). + -- Here we assume the same stage. + [ WithStage (solverPkgStage solverPkg) confId | aid <- cc_exe_deps cc0 , let confId = annotatedIdToConfiguredId aid , confSrcId confId == pkgid @@ -1845,18 +1835,19 @@ elaborateInstallPlan compExeDependencyPaths :: [(WithStage ConfiguredId, FilePath)] compExeDependencyPaths = - -- External + -- External dependencies (confSrcId confId /= pkgid). [ (WithStage (stageOf pkg) confId, path) | pkg <- external_exe_dep_pkgs , let confId = configuredId pkg , confSrcId confId /= pkgid , -- only executables - Just (CExeName _) <- [confCompName confId] + Just (CExeName _) <- [confCompName confId] , path <- planPackageExePaths pkg ] <> - -- Internal, assume the same stage - [ (WithStage solverPkgStage confId, path) + -- Internal dependencies (confSrcId confId == pkgid). + -- Here we assume the same stage. + [ (WithStage (solverPkgStage solverPkg) confId, path) | aid <- cc_exe_deps cc0 , let confId = annotatedIdToConfiguredId aid , confSrcId confId == pkgid @@ -1888,14 +1879,23 @@ elaborateInstallPlan } -- This is where the component id is computed. - cid = case elabBuildStyle elab0 of - BuildInplaceOnly{} -> - mkComponentId $ - case Cabal.componentNameString cname of - Nothing -> prettyShow pkgid - Just n -> prettyShow pkgid ++ "-" ++ prettyShow n - BuildAndInstall -> - hashedInstalledPackageId (packageHashInputs elab1) -- knot tied + -- For packages that either: + -- are in the project source package closure, or + -- do not have a source hash + -- we use the package id (plus the component name if there is one). + -- For the other packages, which have a source hash, we use a hash derived from the source hash + -- and the build configuration (computed by 'packageHashInputs'). + cid = + case elabPkgSourceHash elab1 of + -- If we have a source hash and the package is in the project closure, + -- we can use it to compute the component ID. + Just srchash | not (inProjectSourcePackagesClosure solverPkg) -> + hashedInstalledPackageId (packageHashInputs srchash elab1) -- knot tied + _otherwise -> + mkComponentId $ + case Cabal.componentNameString cname of + Nothing -> prettyShow pkgid + Just n -> prettyShow pkgid ++ "-" ++ prettyShow n cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} @@ -1905,6 +1905,7 @@ elaborateInstallPlan Just full -> full Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) lc_dep_map = Map.union external_lc_map lc_map + lc <- toLinkedComponent verbosity @@ -1917,7 +1918,7 @@ elaborateInstallPlan lc_dep_map -- \^ linked component map cc - -- \^ configured component + -- \^ configured component -- NB: elab is setup to be the correct form for an -- indefinite library, or a definite library with no holes. @@ -1950,15 +1951,14 @@ elaborateInstallPlan elab2 { elabInstallDirs = computeInstallDirs - storeDirLayout - defaultInstallDirs + (distStoreDirLayout distDirLayout) elab2 } -- 6. Construct the updated local maps let cc_map' = extendConfiguredComponentMap cc cc_map lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map + exe_map' = Map.insert cid (installedBinDirectory elab) exe_map return ((cc_map', lc_map', exe_map'), elab) where @@ -1967,9 +1967,9 @@ elaborateInstallPlan compSolverName = CD.componentNameToComponent cname -- External dependencies. I.e. dependencies of the component on components of other packages. - external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgLibDeps + external_lib_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) (solverPkgLibDeps solverPkg) - external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps + external_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) (solverPkgExeDeps solverPkg) external_exe_map = Map.fromList $ @@ -2008,14 +2008,6 @@ elaborateInstallPlan (Cabal.componentBuildInfo comp) ] - inplace_bin_dir elab = - binDirectoryFor - distDirLayout - elab - $ case Cabal.componentNameString cname of - Just n -> prettyShow n - Nothing -> "" - -- \| Given a 'SolverId' referencing a dependency on a library, return -- the 'ElaboratedPlanPackage' corresponding to the library. This -- returns at most one result. @@ -2025,36 +2017,11 @@ elaborateInstallPlan -> [ElaboratedPlanPackage] elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep - -- \| Given an 'ElaboratedPlanPackage', return the paths to where the - -- executables that this package represents would be installed. - -- The only case where multiple paths can be returned is the inplace - -- monolithic package one, since there can be multiple exes and each one - -- has its own directory. planPackageExePaths :: ElaboratedPlanPackage -> [FilePath] planPackageExePaths = - -- Pre-existing executables are assumed to be in PATH - -- already. In fact, this should be impossible. + -- Note: the packagedb only include libraries, so pre-installed packages cannot have executables to depend on. InstallPlan.foldPlanPackage (const []) $ \elab -> - let - executables :: [FilePath] - executables = - case elabPkgOrComp elab of - -- Monolithic mode: all exes of the package - ElabPackage _ -> - unUnqualComponentName . PD.exeName - <$> PD.executables (elabPkgDescription elab) - -- Per-component mode: just the selected exe - ElabComponent comp -> - case fmap - Cabal.componentNameString - (compComponentName comp) of - Just (Just n) -> [prettyShow n] - _ -> [""] - in - binDirectoryFor - distDirLayout - elab - <$> executables + [ installedBinDirectory elab ] elaborateSolverToPackage :: NE.NonEmpty NotPerComponentReason @@ -2089,8 +2056,7 @@ elaborateInstallPlan elab1 { elabInstallDirs = computeInstallDirs - storeDirLayout - defaultInstallDirs + (distStoreDirLayout distDirLayout) elab1 } @@ -2098,11 +2064,15 @@ elaborateInstallPlan Nothing -> emptyModuleShape Just e -> Ty.elabModuleShape e - pkgInstalledId - | shouldBuildInplaceOnly solverPkg = + -- See the equivalent code in buildComponent for explanation. + pkgInstalledId = + case elabPkgSourceHash elab of + -- If we have a source hash and the package is in the project closure, + -- we can use it to compute the component ID. + Just srchash | not (inProjectSourcePackagesClosure solverPkg) -> + hashedInstalledPackageId (packageHashInputs srchash elab) -- knot tied + _otherwise -> mkComponentId (prettyShow srcpkgPackageId) - | otherwise = - hashedInstalledPackageId (packageHashInputs elab) -- recursive use of elab -- Need to filter out internal dependencies, because they don't -- correspond to anything real anymore. @@ -2171,7 +2141,6 @@ elaborateInstallPlan } = elaboratedPackage where - compilers = fmap toolchainCompiler toolchains packageDbs = fmap toolchainPackageDBs toolchains elaboratedPackage = ElaboratedConfiguredPackage{..} @@ -2259,12 +2228,8 @@ elaborateInstallPlan elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes - elabLocalToProject = isLocalToProject solverPkg - - elabBuildStyle = - if shouldBuildInplaceOnly solverPkg - then BuildInplaceOnly OnDisk - else BuildAndInstall + elabIsSourcePackage = isProjectSourcePackage solverPkg + elabIsSourcePackageClosure = inProjectSourcePackagesClosure solverPkg elabPackageDbs = toolchainPackageDBs elabToolchain elabBuildPackageDBStack = buildAndRegisterDbs elabStage @@ -2281,19 +2246,10 @@ elaborateInstallPlan elabSetupPackageDBStack = buildAndRegisterDbs (prevStage elabStage) - -- Same as corePackageDbs but with the addition of the in-place packagedb. - inplacePackageDbs stage = corePackageDbs stage ++ [SpecificPackageDB (distDirectory "packagedb" prettyShow stage prettyShow (compilerId (getStage compilers stage)))] - -- The project packagedbs (typically the global packagedb but others can be added) followed by the store. - corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB storeDirLayout stage (getStage toolchains stage)] - - elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage - elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage - elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) + corePackageDbs stage = getStage packageDbs stage ++ [storePackageDB (distStoreDirLayout distDirLayout) stage (getStage toolchains stage)] - buildAndRegisterDbs stage - | shouldBuildInplaceOnly solverPkg = inplacePackageDbs stage - | otherwise = corePackageDbs stage + buildAndRegisterDbs stage = corePackageDbs stage elabPkgDescriptionOverride = srcpkgDescrOverride @@ -2405,15 +2361,26 @@ elaborateInstallPlan elabBenchmarkOptions = perPkgOptionList srcpkgPackageId packageConfigBenchmarkOptions - perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a - perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a - perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] + -- + -- Per-package options + -- + -- allPackageConfig applies to all packages + -- localPackageConfig applies to all project source packages + -- perPackageConfig applies to specific named packages + perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f) + + perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) + + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] perPkgOptionList pkgid f = lookupPerPkgOption pkgid f + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) @@ -2436,43 +2403,50 @@ elaborateInstallPlan where global = f allPackagesConfig local - | isLocalToProject pkg = + | isProjectSourcePackage pkg = f localPackagesConfig | otherwise = mempty - perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - - -- For this local build policy, every package that lives in a local source - -- dir (as opposed to a tarball), or depends on such a package, will be - -- built inplace into a shared dist dir. Tarball packages that depend on - -- source dir packages will also get unpacked locally. - shouldBuildInplaceOnly :: SolverPackage loc -> Bool - shouldBuildInplaceOnly pkg = + perpkg = foldMap f (Map.lookup (packageName pkg) perPackageConfig) + + + -- + -- Project source packages and their closure + -- + + -- Test if a solver package belongs to the closure of project source packages. + inProjectSourcePackagesClosure :: SolverPackage loc -> Bool + inProjectSourcePackagesClosure pkg = Set.member (solverId (ResolverPackage.Configured pkg)) - pkgsToBuildInplaceOnly - - -- The reverse dependencies of solver packages which match a package id in pkgLocalToProject. - pkgsToBuildInplaceOnly :: Set SolverId - pkgsToBuildInplaceOnly = + projectSourcePackagesClosure + + -- The set of all packages that are either local source packages, + -- or depend (directly or indirectly) on such packages. + -- This is a set of SolverIds, which are obtained from the packages in the solver plan + -- and checking if their package id or one of their dependencies' package ids + -- is in the set of project source packages. + projectSourcePackagesClosure :: Set SolverId + projectSourcePackagesClosure = Set.fromList [ solverId pkg | spkg <- SolverInstallPlan.toList solverPlan - , packageId spkg `elem` pkgsLocalToProject + , packageId spkg `elem` projectSourcePackages , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan [solverId spkg] ] - isLocalToProject :: Package pkg => pkg -> Bool - isLocalToProject pkg = + -- Test if a generic package belongs to the set of project source packages. + isProjectSourcePackage :: Package pkg => pkg -> Bool + isProjectSourcePackage pkg = Set.member (packageId pkg) - pkgsLocalToProject + projectSourcePackages - pkgsLocalToProject :: Set PackageId - pkgsLocalToProject = - Set.fromList (catMaybes (map shouldBeLocal localPackages)) - -- TODO: localPackages is a misnomer, it's all project packages - -- here is where we decide which ones will be local! + -- This is the set of all "local unpacked packages", which are packages that are unpacked in the project + -- directory. + projectSourcePackages :: Set PackageId + projectSourcePackages = + Set.fromList [ pkgId | Just pkgId <- map isLocalUnpackedPackage localPackages ] pkgsUseSharedLibrary :: Compiler -> Set PackageId pkgsUseSharedLibrary compiler = @@ -2591,10 +2565,14 @@ elaborateInstallPlan -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping -shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal (NamedPackage _ _) = +-- | If the given package specifier corresponds to a local unpacked package, +-- return its 'PackageId'. Otherwise, return 'Nothing'. +isLocalUnpackedPackage + :: PackageSpecifier (SourcePackage (PackageLocation loc)) + -> Maybe PackageId +isLocalUnpackedPackage (NamedPackage _ _) = Nothing -shouldBeLocal (SpecificSourcePackage pkg) = +isLocalUnpackedPackage (SpecificSourcePackage pkg) = case srcpkgSource pkg of LocalUnpackedPackage _ -> Just (packageId pkg) _ -> Nothing @@ -2699,28 +2677,14 @@ mkShapeMapping dpkg = -- The result may have several entries if this is an inplace build of a package -- with multiple executables. binDirectories - :: DistDirLayout - -> ElaboratedConfiguredPackage + :: ElaboratedConfiguredPackage -> [FilePath] -binDirectories layout package = case elabBuildStyle package of +binDirectories package = -- quick sanity check: no sense returning a bin directory if we're not going -- to put any executables in it, that will just clog up the PATH - _ | noExecutables -> [] - BuildAndInstall -> [installedBinDirectory package] - BuildInplaceOnly{} -> map (root ) $ case elabPkgOrComp package of - ElabComponent comp -> case compSolverName comp of - CD.ComponentExe n -> [prettyShow n] - _ -> [] - ElabPackage _ -> - map (prettyShow . PD.exeName) - . PD.executables - . elabPkgDescription - $ package + if noExecutables then [] else [installedBinDirectory package] where noExecutables = null . PD.executables . elabPkgDescription $ package - root = - distBuildDirectory layout (elabDistDirParams package) - "build" type InstS = Map (WithStage UnitId) ElaboratedPlanPackage type InstM a = State InstS a @@ -2732,12 +2696,6 @@ getComponentId (InstallPlan.PreExisting (WithStage _stage dipkg)) = IPI.installe getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab -extractElabBuildStyle - :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage - -> BuildStyle -extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab -extractElabBuildStyle _ = BuildAndInstall - -- When using Backpack, packages can have "holes" that need to be filled with concrete implementations. -- This function takes an initial install plan and creates additional plan entries for all the instantiated versions of packages @@ -2796,10 +2754,9 @@ extractElabBuildStyle _ = BuildAndInstall instantiateInstallPlan :: HasCallStack => StoreDirLayout - -> Staged InstallDirs.InstallDirTemplates -> ElaboratedInstallPlan -> LogProgress ElaboratedInstallPlan -instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do +instantiateInstallPlan storeDirLayout plan = do InstallPlan.new (Map.elems ready_map) where pkgs = InstallPlan.toList plan @@ -2810,21 +2767,21 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do :: Stage -> ComponentId -- \^ The id of the component being instantiated - -> Map ModuleName (Module, BuildStyle) + -> Map ModuleName Module -- \^ A mapping from module names (the "holes" or signatures in Backpack) - -- to the concrete modules (and their build styles) that should fill those + -- to the concrete modules that should fill those -- holes. - -> InstM (DefUnitId, BuildStyle) + -> InstM DefUnitId instantiateUnitId stage cid insts = gets (Map.lookup (WithStage stage uid)) >>= \case Nothing -> do r <- instantiateComponent uid (WithStage stage cid) insts modify (Map.insert (WithStage stage uid) r) - return (unsafeMkDefUnitId uid, extractElabBuildStyle r) - Just r -> - return (unsafeMkDefUnitId uid, extractElabBuildStyle r) + return (unsafeMkDefUnitId uid) + Just _ -> + return (unsafeMkDefUnitId uid) where - uid = mkDefUnitId cid (fmap fst insts) + uid = mkDefUnitId cid insts -- No need to InplaceT; the inplace-ness is properly computed for -- the ElaboratedPlanPackage, so that will implicitly pass it on @@ -2833,7 +2790,7 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do -- \^ The unit id to assign to the instantiated component -> WithStage ComponentId -- \^ The id of the component being instantiated - -> Map ModuleName (Module, BuildStyle) + -> Map ModuleName Module -- \^ A mapping from module names (the "holes" or signatures in Backpack) -- to the concrete modules (and their build styles) that should fill those -- holes. @@ -2849,15 +2806,13 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do case elabPkgOrComp elab0 of ElabPackage{} -> return planpkg ElabComponent comp -> do - deps <- traverse (fmap fst . instantiateUnit stage insts) (compLinkedLibDependencies comp) - let build_style = fold (fmap snd insts) + deps <- traverse (instantiateUnit stage insts) (compLinkedLibDependencies comp) let getDep (Module dep_uid _) = [dep_uid] elab1 = - fixupBuildStyle build_style $ elab0 { elabUnitId = uid , elabComponentId = cid - , elabIsCanonical = Map.null (fmap fst insts) + , elabIsCanonical = Map.null insts , elabPkgOrComp = ElabComponent comp @@ -2866,9 +2821,9 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do ++ ordNub ( map unDefUnitId - (deps ++ concatMap (getDep . fst) (Map.elems insts)) + (deps ++ concatMap getDep (Map.elems insts)) ) - , compInstantiatedWith = fmap fst insts + , compInstantiatedWith = insts } } return $ @@ -2877,7 +2832,6 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do { elabInstallDirs = computeInstallDirs storeDirLayout - defaultInstallDirs elab1 } @@ -2897,18 +2851,18 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do -- instantiateUnit :: Stage - -> Map ModuleName (Module, BuildStyle) - -- \^ A mapping from module names to their corresponding modules and build styles. + -> Map ModuleName Module + -- \^ A mapping from module names to their corresponding modules. -> OpenUnitId -- \^ The unit to instantiate. This can be: -- DefiniteUnitId uid: already fully instantiated (no holes). -- IndefFullUnitId cid insts: an indefinite unit (with holes), described by a component id and a mapping of holes to modules. - -> InstM (DefUnitId, BuildStyle) + -> InstM DefUnitId instantiateUnit _stage _subst (DefiniteUnitId def_uid) = -- This COULD actually, secretly, be an inplace package, but in -- that case it doesn't matter as it's already been recorded -- in the package that depends on this - return (def_uid, BuildAndInstall) + return def_uid instantiateUnit stage subst (IndefFullUnitId cid insts) = do insts' <- traverse (instantiateModule stage subst) insts instantiateUnitId stage cid insts' @@ -2917,19 +2871,19 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do -- and its associated BuildStyle. instantiateModule :: Stage - -> Map ModuleName (Module, BuildStyle) - -- \^ A mapping from module names to their corresponding modules and build styles. + -> Map ModuleName Module + -- \^ A mapping from module names to their corresponding modules. -> OpenModule -- \^ The module to substitute, which can be: -- OpenModuleVar mod_name: a hole (variable) named mod_name -- OpenModule uid mod_name: a module from a specific unit (uid). - -> InstM (Module, BuildStyle) + -> InstM Module instantiateModule _stage subst (OpenModuleVar mod_name) | Just m <- Map.lookup mod_name subst = return m | otherwise = error "substModule: non-closing substitution" instantiateModule stage subst (OpenModule uid mod_name) = do - (uid', build_style) <- instantiateUnit stage subst uid - return (Module uid' mod_name, build_style) + uid' <- instantiateUnit stage subst uid + return (Module uid' mod_name) indefiniteComponent :: ElaboratedConfiguredPackage @@ -2955,7 +2909,7 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do -- DefiniteUnitId (that's what substUnitId does!) new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid -> if Set.null (openUnitIdFreeHoles uid) - then fmap (DefiniteUnitId . fst) (instantiateUnit (elabStage epkg) Map.empty uid) + then fmap DefiniteUnitId (instantiateUnit (elabStage epkg) Map.empty uid) else return uid -- NB: no fixupBuildStyle needed here, as if the indefinite -- component depends on any inplace packages, it itself must @@ -2978,15 +2932,6 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs plan = do } } - fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _buildStyle (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly{}}) = elab - fixupBuildStyle buildStyle@(BuildInplaceOnly{}) elab = - elab - { elabBuildStyle = buildStyle - , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab - , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab - , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab - } ready_map = execState work Map.empty work = for_ pkgs $ \pkg -> @@ -3198,7 +3143,7 @@ availableSourceTargets elab = { availableTargetPackageId = packageId elab , availableTargetComponentName = cname , availableTargetStatus = status - , availableTargetLocalToProject = elabLocalToProject elab + , availableTargetLocalToProject = elabIsSourcePackage elab } fake = isFakeTarget cname , -- TODO: The goal of this test is to exclude "instantiated" @@ -3256,7 +3201,7 @@ availableSourceTargets elab = cname = componentName component buildable = PD.buildable (componentBuildInfo component) withinPlan = - elabLocalToProject elab + elabIsSourcePackage elab || case elabPkgOrComp elab of ElabComponent elabComponent -> compComponentName elabComponent == Just cname @@ -3425,7 +3370,6 @@ setRootTargets targetAction perPkgTargetsMap = elab { elabReplTarget = tgts , elabBuildHaddocks = False - , elabBuildStyle = BuildInplaceOnly InMemory } (Just tgts, TargetActionHaddock) -> foldr @@ -3505,7 +3449,6 @@ pruneInstallPlanPass1 pkgs | elabUnitId ecp `Set.member` all_desired_repl_targets = ecp { elabReplTarget = maybeToList (ComponentTarget <$> (elabComponentName ecp) <*> pure WholeComponent) - , elabBuildStyle = BuildInplaceOnly InMemory } | otherwise = ecp @@ -3742,14 +3685,15 @@ pruneInstallPlanPass2 pkgs = where -- We initially assume that all the dependencies are external (hence the boolean is always -- False) and here we correct the dependencies so the right packages are marked promised. - addInternal (cid, _) = (cid, (cid `Set.member` inMemoryTargets)) + -- addInternal (cid, _) = (cid, (cid `Set.member` inMemoryTargets)) + addInternal (cid, _) = (cid, False) libTargetsRequiredForRevDeps = [ c | Graph.nodeKey elab `Set.member` hasReverseLibDeps , let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent - , -- Don't enable building for anything which is being build in memory - elabBuildStyle elab /= BuildInplaceOnly InMemory + -- , -- Don't enable building for anything which is being build in memory + -- elabBuildStyle elab /= BuildInplaceOnly InMemory ] exeTargetsRequiredForRevDeps = -- TODO: allow requesting executable with different name @@ -3766,13 +3710,13 @@ pruneInstallPlanPass2 pkgs = availablePkgs = Set.fromList (map Graph.nodeKey pkgs) - inMemoryTargets :: Set ConfiguredId - inMemoryTargets = do - Set.fromList - [ configuredId pkg - | InstallPlan.Configured pkg <- pkgs - , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] - ] + -- inMemoryTargets :: Set ConfiguredId + -- inMemoryTargets = do + -- Set.fromList + -- [ configuredId pkg + -- | InstallPlan.Configured pkg <- pkgs + -- , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] + -- ] hasReverseLibDeps = Set.fromList @@ -3873,9 +3817,7 @@ newtype CannotPruneDependencies setupHsScriptOptions :: ElaboratedReadyPackage - -> ElaboratedInstallPlan -> ElaboratedSharedConfig - -> DistDirLayout -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> Bool @@ -3885,9 +3827,7 @@ setupHsScriptOptions -- be a separate component!!! setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) - plan ElaboratedSharedConfig{..} - distdir srcdir builddir isParallelBuild @@ -3921,7 +3861,7 @@ setupHsScriptOptions , -- note that the above adds the extra-prog-path directly following the elaborated -- dep paths, so that it overrides the normal path, but _not_ the elaborated extensions -- for build-tools-depends. - useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan + useExtraEnvOverrides = [] , useWin32CleanHack = False -- TODO: [required eventually] , forceExternalSetupMethod = isParallelBuild , setupCacheLock = Just cacheLock @@ -3942,18 +3882,6 @@ setupHsScriptOptions -- TODO: It is disappointing that we have to change the stage here getStage pkgConfigToolchains (prevStage elabStage) --- | To be used for the input for elaborateInstallPlan. --- --- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure. -userInstallDirTemplates - :: Compiler - -> IO InstallDirs.InstallDirTemplates -userInstallDirTemplates compiler = do - InstallDirs.defaultInstallDirs - (compilerFlavor compiler) - True -- user install - False -- unused - storePackageInstallDirs :: StoreDirLayout -> Stage @@ -3969,73 +3897,37 @@ storePackageInstallDirs' -> Toolchain -> UnitId -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs' - StoreDirLayout - { storePackageDirectory - , storeDirectory - } - stage - toolchain - unitid = - InstallDirs.InstallDirs{..} +storePackageInstallDirs' storeDirLayout stage toolchain unitid = + simplePackageInstallDirs $ storePackageDirectory storeDirLayout stage toolchain unitid + +simplePackageInstallDirs + :: FilePath + -> InstallDirs.InstallDirs FilePath +simplePackageInstallDirs prefix = + InstallDirs.InstallDirs{..} where - store = storeDirectory stage toolchain - prefix = storePackageDirectory stage toolchain unitid - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - -- Note: on macOS, we place libraries into - -- @store/lib@ to work around the load - -- command size limit of macOSs mach-o linker. - -- See also @PackageHash.hashedInstalledPackageIdVeryShort@ - dynlibdir - | buildOS == OSX = store "lib" - | otherwise = libdir - flibdir = libdir - libexecdir = prefix "libexec" - libexecsubdir = "" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" + bindir = prefix "bin" + libdir = prefix "lib" + libsubdir = "" + dynlibdir = libdir + flibdir = libdir + libexecdir = prefix "libexec" + libexecsubdir = "" + includedir = libdir "include" + datadir = prefix "share" + datasubdir = "" + docdir = datadir "doc" + mandir = datadir "man" + htmldir = docdir "html" + haddockdir = htmldir + sysconfdir = prefix "etc" computeInstallDirs :: StoreDirLayout - -> Staged InstallDirs.InstallDirTemplates -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath -computeInstallDirs storeDirLayout defaultInstallDirs elab = - if isInplaceBuildStyle (elabBuildStyle elab) - then -- use the ordinary default install dirs - - ( InstallDirs.absoluteInstallDirs - (elabPkgSourceId elab) - (elabUnitId elab) - (compilerInfo toolchainCompiler) - InstallDirs.NoCopyDest - toolchainPlatform - defaultInstallDirs' - ) - { -- absoluteInstallDirs sets these as 'undefined' but we have - -- to use them as "Setup.hs configure" args - InstallDirs.libsubdir = "" - , InstallDirs.libexecsubdir = "" - , InstallDirs.datasubdir = "" - } - else -- use special simplified install dirs - - storePackageInstallDirs' - storeDirLayout - (elabStage elab) - (elabToolchain elab) - (elabUnitId elab) - where - Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain elab - defaultInstallDirs' = getStage defaultInstallDirs (elabStage elab) +computeInstallDirs storeDirLayout elab = + simplePackageInstallDirs $ storePackageDirectory storeDirLayout (elabStage elab) (elabToolchain elab) (elabUnitId elab) -- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, @@ -4046,13 +3938,11 @@ setupHsConfigureFlags -- ^ How to transform a path which is relative to cabal-install cwd to one which -- is relative to the route of the package about to be compiled. The simplest way -- to do this is to convert the potentially relative path into an absolute path. - -> ElaboratedInstallPlan -> ElaboratedReadyPackage -> Cabal.CommonSetupFlags -> m Cabal.ConfigFlags setupHsConfigureFlags mkSymbolicPath - _plan (ReadyPackage elab@ElaboratedConfiguredPackage{..}) configCommonFlags = do -- explicitly clear, then our package db stack @@ -4339,7 +4229,7 @@ setupHsRegisterFlags -> FilePath -> Cabal.RegisterFlags setupHsRegisterFlags - ElaboratedConfiguredPackage{..} + _ _ common pkgConfFile = @@ -4348,9 +4238,7 @@ setupHsRegisterFlags , regPackageDB = mempty -- misfeature , regGenScript = mempty -- never use , regGenPkgConf = toFlag (Just (makeSymbolicPath pkgConfFile)) - , regInPlace = case elabBuildStyle of - BuildInplaceOnly{} -> toFlag True - BuildAndInstall -> toFlag False + , regInPlace = toFlag False , regPrintId = mempty -- never use } @@ -4446,63 +4334,57 @@ setupHsHaddockArgs elab = -- not replace installed packages with ghc-pkg. packageHashInputs - :: ElaboratedConfiguredPackage + :: HasCallStack + => PackageSourceHash + -> ElaboratedConfiguredPackage -> PackageHashInputs -packageHashInputs - elab@( ElaboratedConfiguredPackage - { elabPkgSourceHash = Just srchash - } - ) = - PackageHashInputs - { pkgHashPkgId = packageId elab - , pkgHashComponent - , pkgHashSourceHash = srchash - , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) - , pkgHashLibDeps - , pkgHashExeDeps - , pkgHashOtherConfig = packageHashConfigInputs elab - } - where - pkgHashComponent = - case elabPkgOrComp elab of - ElabPackage _ -> Nothing - ElabComponent comp -> Just (compSolverName comp) - pkgHashLibDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList - [confInstId c | (c, _promised) <- CD.select relevantDeps pkgLibDependencies] - ElabComponent comp -> - Set.fromList - [confInstId c | (c, _promised) <- compLibDependencies comp] - pkgHashExeDeps = - case elabPkgOrComp elab of - ElabPackage (ElaboratedPackage{..}) -> - Set.fromList - [ confInstId c - | WithStage _stage c <- CD.select relevantDeps pkgExeDependencies - ] - ElabComponent comp -> - Set.fromList - [ confInstId c - | WithStage _stage c <- compExeDependencies comp - ] +packageHashInputs srchash elab = + PackageHashInputs + { pkgHashPkgId = packageId elab + , pkgHashComponent + , pkgHashSourceHash = srchash + , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab) + , pkgHashLibDeps + , pkgHashExeDeps + , pkgHashOtherConfig = packageHashConfigInputs elab + } + where + pkgHashComponent = + case elabPkgOrComp elab of + ElabPackage _ -> Nothing + ElabComponent comp -> Just (compSolverName comp) + pkgHashLibDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [confInstId c | (c, _promised) <- CD.select relevantDeps pkgLibDependencies] + ElabComponent comp -> + Set.fromList + [confInstId c | (c, _promised) <- compLibDependencies comp] + pkgHashExeDeps = + case elabPkgOrComp elab of + ElabPackage (ElaboratedPackage{..}) -> + Set.fromList + [ confInstId c + | WithStage _stage c <- CD.select relevantDeps pkgExeDependencies + ] + ElabComponent comp -> + Set.fromList + [ confInstId c + | WithStage _stage c <- compExeDependencies comp + ] - -- Obviously the main deps are relevant - relevantDeps CD.ComponentLib = True - relevantDeps (CD.ComponentSubLib _) = True - relevantDeps (CD.ComponentFLib _) = True - relevantDeps (CD.ComponentExe _) = True - -- Setup deps can affect the Setup.hs behaviour and thus what is built - relevantDeps CD.ComponentSetup = True - -- However testsuites and benchmarks do not get installed and should not - -- affect the result, so we do not include them. - relevantDeps (CD.ComponentTest _) = False - relevantDeps (CD.ComponentBench _) = False -packageHashInputs pkg = - error $ - "packageHashInputs: only for packages with source hashes. " - ++ prettyShow (packageId pkg) + -- Obviously the main deps are relevant + relevantDeps CD.ComponentLib = True + relevantDeps (CD.ComponentSubLib _) = True + relevantDeps (CD.ComponentFLib _) = True + relevantDeps (CD.ComponentExe _) = True + -- Setup deps can affect the Setup.hs behaviour and thus what is built + relevantDeps CD.ComponentSetup = True + -- However testsuites and benchmarks do not get installed and should not + -- affect the result, so we do not include them. + relevantDeps (CD.ComponentTest _) = False + relevantDeps (CD.ComponentBench _) = False packageHashConfigInputs :: ElaboratedConfiguredPackage @@ -4562,45 +4444,10 @@ packageHashConfigInputs pkg = ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage pkg LBC.BuildOptions{..} = elabBuildOptions --- TODO: sanity checks: --- \* the installed package must have the expected deps etc --- \* the installed package must not be broken, valid dep closure - --- TODO: decide what to do if we encounter broken installed packages, --- since overwriting is never safe. - --- Path construction ------- - --- | The path to the directory that contains a specific executable. --- NB: For inplace NOT InstallPaths.bindir installDirs; for an --- inplace build those values are utter nonsense. So we --- have to guess where the directory is going to be. --- Fortunately this is "stable" part of Cabal API. --- But the way we get the build directory is A HORRIBLE --- HACK. -binDirectoryFor - :: DistDirLayout - -> ElaboratedConfiguredPackage - -> FilePath - -> FilePath -binDirectoryFor layout package exe = case elabBuildStyle package of - BuildAndInstall -> installedBinDirectory package - BuildInplaceOnly{} -> inplaceBinRoot layout package exe - --- package has been built and installed. +-- Where executables have been installed for this package installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath installedBinDirectory = InstallDirs.bindir . elabInstallDirs --- | The path to the @build@ directory for an inplace build. -inplaceBinRoot - :: DistDirLayout - -> ElaboratedConfiguredPackage - -> FilePath -inplaceBinRoot layout package = - distBuildDirectory layout (elabDistDirParams package) - "build" - -- FIXME: whathever -- -------------------------------------------------------------------------------- -- -- Configure --coverage-for flags diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index eb8b54c4327..42d5dc126ed 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -26,12 +26,11 @@ module Distribution.Client.ProjectPlanning.Types , elabOrderExeDependencies , elabSetupLibDependencies , elabPkgConfigDependencies - , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration - , dataDirsEnvironmentForPlan , elabPlanPackageName , elabConfiguredName , elabComponentName + , elabExeName , ElaboratedPackageOrComponent (..) , ElaboratedComponent (..) , ElaboratedPackage (..) @@ -39,9 +38,6 @@ module Distribution.Client.ProjectPlanning.Types , ElaboratedPlanPackage , ElaboratedSharedConfig (..) , ElaboratedReadyPackage - , BuildStyle (..) - , MemoryOrDisk (..) - , isInplaceBuildStyle , CabalFileText , NotPerComponentReason (..) , NotPerComponentBuildType (..) @@ -103,7 +99,6 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.ModuleName (ModuleName) import Distribution.Package import qualified Distribution.PackageDescription as Cabal -import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs (PathTemplate) @@ -127,7 +122,6 @@ import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion -import Distribution.Utils.Path (getSymbolicPath) import Distribution.Verbosity (normal) import Distribution.Version @@ -135,8 +129,8 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Distribution.Compat.Graph as Graph -import System.FilePath (()) import Text.PrettyPrint (colon, hsep, parens, text) +import qualified Distribution.PackageDescription as PD -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -190,15 +184,15 @@ showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode herald = ( hsep [ InstallPlan.renderPlanPackageTag pkg - , InstallPlan.foldPlanPackage (const mempty) in_mem pkg + -- , InstallPlan.foldPlanPackage (const mempty) in_mem pkg , pretty (packageId pkg) , parens (pretty (nodeKey pkg)) ] ) - in_mem elab = case elabBuildStyle elab of - BuildInplaceOnly InMemory -> parens (text "In Memory") - _ -> mempty + -- in_mem elab = case elabBuildStyle elab of + -- BuildInplaceOnly InMemory -> parens (text "In Memory") + -- _ -> mempty deps = InstallPlan.foldPlanPackage installed_deps local_deps pkg @@ -254,13 +248,10 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage , elabPkgSourceHash :: Maybe PackageSourceHash -- ^ The hash of the source, e.g. the tarball. We don't have this for -- local source dir packages. - , elabLocalToProject :: Bool - -- ^ Is this package one of the ones specified by location in the - -- project file? (As opposed to a dependency, or a named package pulled - -- in) - , elabBuildStyle :: BuildStyle - -- ^ Are we going to build and install this package to the store, or are - -- we going to build it and register it locally. + , elabIsSourcePackage :: Bool + -- FIXME + , elabIsSourcePackageClosure :: Bool + -- ^ Is this package in the closure of project source packages? , elabEnabledSpec :: ComponentRequestedSpec -- ^ Another way of phrasing 'pkgStanzasAvailable'. , elabStanzasAvailable :: OptionalStanzaSet @@ -291,9 +282,6 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage , elabSetupPackageDBStack :: PackageDBStackCWD , elabBuildPackageDBStack :: PackageDBStackCWD , elabRegisterPackageDBStack :: PackageDBStackCWD - , elabInplaceSetupPackageDBStack :: PackageDBStackCWD - , elabInplaceBuildPackageDBStack :: PackageDBStackCWD - , elabInplaceRegisterPackageDBStack :: PackageDBStackCWD , elabPkgDescriptionOverride :: Maybe CabalFileText , -- TODO: make per-component variants of these flags elabBuildOptions :: LBC.BuildOptions @@ -417,10 +405,7 @@ elabRequiresRegistration elab = -- that was built and installed into the same store folder -- as otherwise this will cause build failures once a -- target actually depends on lib:cpphs. - build_target - || ( elabBuildStyle elab == BuildAndInstall - && Cabal.hasPublicLib (elabPkgDescription elab) - ) + build_target || Cabal.hasPublicLib (elabPkgDescription elab) -- the next sub-condition below is currently redundant -- (see discussion in #5604 for more details), but it's -- being kept intentionally here as a safeguard because if @@ -451,64 +436,6 @@ elabRequiresRegistration elab = is_lib (CLibName _) = True is_lib _ = False --- | Construct the environment needed for the data files to work. --- This consists of a separate @*_datadir@ variable for each --- inplace package in the plan. -dataDirsEnvironmentForPlan - :: DistDirLayout - -> ElaboratedInstallPlan - -> [(String, Maybe FilePath)] -dataDirsEnvironmentForPlan distDirLayout = - catMaybes - . fmap - ( InstallPlan.foldPlanPackage - (const Nothing) - (dataDirEnvVarForPackage distDirLayout) - ) - . InstallPlan.toList - --- | Construct an environment variable that points --- the package's datadir to its correct location. --- This might be: --- * 'Just' the package's source directory plus the data subdirectory --- for inplace packages. --- * 'Nothing' for packages installed in the store (the path was --- already included in the package at install/build time). -dataDirEnvVarForPackage - :: DistDirLayout - -> ElaboratedConfiguredPackage - -> Maybe (String, Maybe FilePath) -dataDirEnvVarForPackage distDirLayout pkg = - case elabBuildStyle pkg of - BuildAndInstall -> Nothing - BuildInplaceOnly{} -> - Just - ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" - , Just dataDirPath - ) - where - srcPath (LocalUnpackedPackage path) = path - srcPath (LocalTarballPackage _path) = unpackedPath - srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath - srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath - srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout - -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc - srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = - error - "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" - unpackedPath = - distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg - rawDataDir = getSymbolicPath $ dataDir (elabPkgDescription pkg) - pkgDir = srcPath (elabPkgSourceLocation pkg) - dataDirPath - | null rawDataDir = - pkgDir - | otherwise = - pkgDir rawDataDir - --- NB: rawDataDir may be absolute, in which case --- () drops its first argument. - instance Package ElaboratedConfiguredPackage where packageId = elabPkgSourceId @@ -545,6 +472,20 @@ elabComponentName elab = ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this ElabComponent comp -> compComponentName comp +-- | The names of the executables provided by this package/component. +-- For a package, this is all the executables in the package. For a +-- component, this is either a singleton list (if the component is an +-- executable) or the empty list (otherwise). +elabExeName :: ElaboratedConfiguredPackage -> [String] +elabExeName elab = + case elabPkgOrComp elab of + ElabPackage _ -> + [ PD.unUnqualComponentName (PD.exeName exe) | exe <- PD.executables (elabPkgDescription elab) ] + ElabComponent comp -> + case compComponentName comp of + Just (CExeName name) -> [PD.unUnqualComponentName name] + _ -> [] + -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab @@ -696,38 +637,6 @@ pkgSetupLibDependencies pkg = where stage = prevStage (pkgStage pkg) --- | The cache files of all our inplace dependencies which, --- when updated, require us to rebuild. See #4202 for --- more details. Essentially, this is a list of filepaths --- that, if our dependencies get rebuilt, will themselves --- get updated. --- --- Note: the hash of these cache files gets built into --- the build cache ourselves, which means that we end --- up tracking transitive dependencies! --- --- Note: This tracks the "build" cache file, but not --- "registration" or "config" cache files. Why not? --- Arguably we should... --- --- Note: This is a bit of a hack, because it is not really --- the hashes of the SOURCES of our (transitive) dependencies --- that we should use to decide whether or not to rebuild, --- but the output BUILD PRODUCTS. The strategy we use --- here will never work if we want to implement unchanging --- rebuilds. -elabInplaceDependencyBuildCacheFiles - :: DistDirLayout - -> ElaboratedInstallPlan - -> ElaboratedConfiguredPackage - -> [FilePath] -elabInplaceDependencyBuildCacheFiles layout plan root_elab = - go =<< InstallPlan.directDeps plan (nodeKey root_elab) - where - go = InstallPlan.foldPlanPackage (const []) $ \elab -> do - guard (isInplaceBuildStyle (elabBuildStyle elab)) - return $ distPackageCacheFile layout (elabDistDirParams elab) "build" - -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" -- in question is actually a single component to be built. Arguably @@ -851,58 +760,6 @@ whyNotPerComponent = \case CuzNoBuildableComponents -> "there are no buildable components" CuzDisablePerComponent -> "you passed --disable-per-component" --- | This is used in the install plan to indicate how the package will be --- built. -data BuildStyle - = -- | The classic approach where the package is built, then the files - -- installed into some location and the result registered in a package db. - -- - -- If the package came from a tarball then it's built in a temp dir and - -- the results discarded. - BuildAndInstall - | -- | For 'OnDisk': The package is built, but the files are not installed anywhere, - -- rather the build dir is kept and the package is registered inplace. - -- - -- Such packages can still subsequently be installed. - -- - -- Typically 'BuildAndInstall' packages will only depend on other - -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. - -- - -- For 'InMemory': Built in-memory only using GHC multi-repl, they are not built or installed - -- anywhere on disk. BuildInMemory packages can't be depended on by BuildAndInstall nor BuildInplaceOnly packages - -- (because they don't exist on disk) but can depend on other BuildStyles. - -- - -- At the moment @'BuildInplaceOnly' 'InMemory'@ is only used by the 'repl' command. - -- - -- We use single constructor 'BuildInplaceOnly' as for most cases - -- inplace packages are handled similarly. - BuildInplaceOnly MemoryOrDisk - deriving (Eq, Ord, Show, Generic) - --- | How 'BuildInplaceOnly' component is built. -data MemoryOrDisk - = OnDisk - | InMemory - deriving (Eq, Ord, Show, Generic) - --- Note: order of 'BuildStyle' and 'MemoryOrDisk' matters for 'Semigroup' / 'Monoid' instances - -isInplaceBuildStyle :: BuildStyle -> Bool -isInplaceBuildStyle (BuildInplaceOnly{}) = True -isInplaceBuildStyle BuildAndInstall = False - -instance Binary MemoryOrDisk -instance Structured MemoryOrDisk - -instance Semigroup BuildStyle where - -- 'BuildAndInstall' i.e. the smallest / first constructor is the unit. - (<>) = max - -instance Monoid BuildStyle where - mempty = BuildAndInstall - -instance Binary BuildStyle -instance Structured BuildStyle type CabalFileText = LBS.ByteString From 1cf47fa96b1e083c7c20fb831ce07df2eb978643 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 15 Dec 2025 18:16:55 +0800 Subject: [PATCH 093/122] use compilers "Target platform" string --- .../src/Distribution/Client/DistDirLayout.hs | 21 ++++++++++++------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 4a0b41f38dd..4bc2a151aef 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -42,9 +42,9 @@ import Distribution.Package import Distribution.Simple.Compiler ( PackageDBCWD , PackageDBX (..) - - , showCompilerIdWithAbi ) +import Distribution.Simple.Compiler (Compiler(..)) +import qualified Data.Map as Map -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained @@ -184,8 +184,7 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distBuildDirectory params = distBuildRootDirectory prettyShow (distParamStage params) - prettyShow (toolchainPlatform (distParamToolchain params)) - showCompilerIdWithAbi (toolchainCompiler (distParamToolchain params)) + betterPlatform (distParamToolchain params) prettyShow (distParamUnitId params) distUnpackedSrcRootDirectory :: FilePath @@ -195,6 +194,7 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir = distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory prettyShow pkgid + -- we shouldn't get name clashes so this should be fine: distDownloadSrcDirectory :: FilePath distDownloadSrcDirectory = distUnpackedSrcRootDirectory @@ -235,10 +235,7 @@ defaultStoreDirLayout storeRoot = where storeDirectory :: Stage -> Toolchain -> FilePath storeDirectory stage toolchain = - storeRoot - prettyShow stage - prettyShow (toolchainPlatform toolchain) - showCompilerIdWithAbi (toolchainCompiler toolchain) + storeRoot prettyShow stage betterPlatform toolchain storePackageDirectory :: Stage -> Toolchain -> UnitId -> FilePath storePackageDirectory stage toolchain ipkgid = @@ -260,6 +257,14 @@ defaultStoreDirLayout storeRoot = storeIncomingLock stage toolchain unitid = storeIncomingDirectory stage toolchain prettyShow unitid <.> "lock" +-- | This returns the platform triple in the same string representation used by the compiler e.g. x86_64-unknown-linux. +-- If the compiler does not have a "Target platform" property, it falls back to pretty printing the Platform value in +-- the toolchain. +betterPlatform :: Toolchain -> String +betterPlatform toolchain = + fromMaybe (prettyShow (toolchainPlatform toolchain)) + $ Map.lookup "Target platform" (compilerProperties (toolchainCompiler toolchain)) + defaultCabalDirLayout :: IO CabalDirLayout defaultCabalDirLayout = mkCabalDirLayout Nothing Nothing From 37774f95486eea30bedd37b3c7abd8eb90560501 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 22 Dec 2025 18:12:34 +0800 Subject: [PATCH 094/122] Remove configFlagError --- Cabal/src/Distribution/Simple/Setup/Config.hs | 4 ---- cabal-install/src/Distribution/Client/Config.hs | 1 - cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs | 2 -- cabal-install/src/Distribution/Client/ProjectPlanning.hs | 1 - 4 files changed, 8 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 8cc041be852..21e455f0cc8 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -206,8 +206,6 @@ data ConfigFlags = ConfigFlags , configExactConfiguration :: Flag Bool -- ^ All direct dependencies and flags are provided on the command line by -- the user via the '--dependency' and '--flags' options. - , configFlagError :: Flag String - -- ^ Halt and show an error message indicating an error in flag assignment , configRelocatable :: Flag Bool -- ^ Enable relocatable package built , configDebugInfo :: Flag DebugInfoLevel @@ -320,7 +318,6 @@ instance Eq ConfigFlags where && equal configCoverage && equal configLibCoverage && equal configExactConfiguration - && equal configFlagError && equal configRelocatable && equal configDebugInfo && equal configDumpBuildInfo @@ -367,7 +364,6 @@ defaultConfigFlags progDb = , configCoverage = Flag False , configLibCoverage = NoFlag , configExactConfiguration = Flag False - , configFlagError = NoFlag , configRelocatable = Flag False , configDebugInfo = Flag NoDebugInfo , configDumpBuildInfo = NoFlag diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 97acd7064de..13f4b4918e3 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -544,7 +544,6 @@ instance Semigroup SavedConfig where , configCoverage = combine configCoverage , configLibCoverage = combine configLibCoverage , configExactConfiguration = combine configExactConfiguration - , configFlagError = combine configFlagError , configRelocatable = combine configRelocatable , configUseResponseFiles = combine configUseResponseFiles , configDumpBuildInfo = combine configDumpBuildInfo diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 18f8f6aed64..224ff5f85dc 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1147,7 +1147,6 @@ convertToLegacyAllPackageConfig , configLibCoverage = mempty -- TODO: don't merge , configExactConfiguration = mempty , configBenchmarks = mempty - , configFlagError = mempty -- TODO: ??? , configRelocatable = mempty , configDebugInfo = mempty , configUseResponseFiles = mempty @@ -1223,7 +1222,6 @@ convertToLegacyPerPackageConfig PackageConfig{..} = , configLibCoverage = packageConfigCoverage -- TODO: don't merge , configExactConfiguration = mempty , configBenchmarks = packageConfigBenchmarks - , configFlagError = mempty -- TODO: ??? , configRelocatable = packageConfigRelocatable , configDebugInfo = packageConfigDebugInfo , configUseResponseFiles = mempty diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d13e3db369b..89104cc3948 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -4070,7 +4070,6 @@ setupHsConfigureFlags ElabComponent _ -> mempty configExactConfiguration = toFlag True - configFlagError = mempty -- TODO: [research required] appears not to be implemented configScratchDir = mempty -- never use configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist From 6c6a11788baac6565c23e92d0951914188eb6d4c Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 23 Dec 2025 15:01:04 +0800 Subject: [PATCH 095/122] elabAbsoluteInstallDirs to be split: elabAbsoluteInstallDirs, centralize logic for bin directories --- Cabal/src/Distribution/Simple/InstallDirs.hs | 6 ++- .../src/Distribution/Client/CmdInstall.hs | 19 +++---- .../src/Distribution/Client/CmdListBin.hs | 7 +-- .../src/Distribution/Client/CmdRun.hs | 11 ++-- .../Client/ProjectBuilding/UnpackedPackage.hs | 2 +- .../Distribution/Client/ProjectPlanOutput.hs | 4 +- .../Distribution/Client/ProjectPlanning.hs | 53 +++++-------------- .../Client/ProjectPlanning/Types.hs | 52 +++++++++++++++++- 8 files changed, 88 insertions(+), 66 deletions(-) diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index 6916ebcf77d..62b0edcb40f 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -71,6 +71,7 @@ import System.FilePath , takeDirectory , () ) +import GHC.Stack (HasCallStack) #ifdef mingw32_HOST_OS import qualified Prelude @@ -143,7 +144,7 @@ combineInstallDirs combine a b = , sysconfdir = sysconfdir a `combine` sysconfdir b } -appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs :: HasCallStack => (a -> a -> a) -> InstallDirs a -> InstallDirs a appendSubdirs append dirs = dirs { libdir = libdir dirs `append` libsubdir dirs @@ -312,7 +313,8 @@ substituteInstallDirTemplates env dirs = dirs' -- substituting for all the variables in the abstract paths, to get real -- absolute path. absoluteInstallDirs - :: PackageIdentifier + :: HasCallStack + => PackageIdentifier -> UnitId -> CompilerInfo -> CopyDest diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 8152b298533..1633c37c8f0 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -95,8 +95,8 @@ import Distribution.Client.ProjectPlanning , ElaboratedPlanPackage , Stage (..) , Toolchain (..) + , WithStage (..) , configToolchainExSafe - , storePackageInstallDirs' ) import Distribution.Client.RebuildMonad ( runRebuild @@ -256,6 +256,7 @@ import System.FilePath , (<.>) , () ) +import Distribution.Client.ProjectPlanning.Types (elabBinDir) -- | Check or check then install an exe. The check is to see if the overwrite -- policy allows installation. @@ -274,7 +275,6 @@ type InstallAction = data InstallCfg = InstallCfg { verbosity :: Verbosity - , baseCtx :: ProjectBaseContext , buildCtx :: ProjectBuildContext , stage :: Stage , toolchain :: Toolchain @@ -519,7 +519,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors printPlan verbosity baseCtx buildCtx - let installCfg = InstallCfg verbosity baseCtx buildCtx Host toolchain configFlags clientInstallFlags + let installCfg = InstallCfg verbosity buildCtx Host toolchain configFlags clientInstallFlags let dryRun = @@ -923,17 +923,18 @@ constructProjectBuildContext verbosity baseCtx targetSelectors = do -- actually perform its installation. prepareExeInstall :: InstallCfg -> IO InstallExe prepareExeInstall - InstallCfg{verbosity, baseCtx, buildCtx, stage, toolchain, installConfigFlags, installClientFlags} = do + InstallCfg{verbosity, buildCtx, stage, toolchain, installConfigFlags, installClientFlags} = do installPath <- defaultInstallPath - let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx - + let plan = elaboratedPlanToExecute buildCtx prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix installConfigFlags)) suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix installConfigFlags)) mkUnitBinDir :: UnitId -> FilePath - mkUnitBinDir = - InstallDirs.bindir - . storePackageInstallDirs' storeDirLayout stage toolchain + mkUnitBinDir unitId = + case InstallPlan.lookup plan (WithStage stage unitId) of + Just (InstallPlan.Configured elab) -> elabBinDir elab + Just _ -> error "Expected an ElaboratedConfiguredPackage!" + Nothing -> error "UnitId not found in plan!" mkExeName :: UnqualComponentName -> FilePath mkExeName exe = unUnqualComponentName exe <.> exeExtension (toolchainPlatform toolchain) diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index da62869bc47..4a1b69728f7 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -58,7 +58,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.Errors import qualified Distribution.Client.InstallPlan as IP -import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Utils.LogProgress (runLogProgress) @@ -207,10 +206,8 @@ listbinAction flags args globalFlags = do Toolchain{toolchainPlatform = plat} = elabToolchain elab -- here and in PlanOutput, - -- use binDirectoryFor? - bin_file' s = InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat - - flib_file' s = InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + bin_file' s = elabBinDir elab prettyShow s <.> exeExtension plat + flib_file' s = elabBinDir elab ("lib" ++ prettyShow s) <.> dllExtension plat moved_bin_file s = fromMaybe (bin_file' s) (movedExePath selectedComponent distDirLayout elaboratedSharedConfig elab) diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 9f6806bf94c..3e269668187 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -55,14 +55,11 @@ import qualified Distribution.Client.ProjectOrchestration as Orchestration (targ import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , ElaboratedPackageOrComponent (..) , WithStage (..) - , installedBinDirectory - ) -import Distribution.Client.ProjectPlanning.Types - ( ElaboratedPackageOrComponent (..) + , elabBinDir , elabExeDependencyPaths ) - import Distribution.Client.ScriptUtils ( AcceptNoTargets (..) , TargetContext (..) @@ -301,7 +298,7 @@ runAction flags targetAndArgs globalFlags = dieWithException verbosity $ MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - let defaultExePath = installedBinDirectory pkg exeName + let defaultExePath = elabBinDir pkg exeName exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) let dryRun = @@ -319,7 +316,7 @@ runAction flags targetAndArgs globalFlags = , let pkg_descr = elabPkgDescription pkg , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr , let thisExeBI = PD.buildInfo thisExe = - [ installedBinDirectory pkg depExeNm + [ elabBinDir pkg depExeNm | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI , let depExeNm = unUnqualComponentName depExe ] diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index fdec0bed578..1852ed1c4c6 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -577,7 +577,7 @@ copyPkgFiles verbosity pkg runCopy tmpDir = do -- the store knows which dir will be the final store entry. let prefix = normalise $ - dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + dropDrive (InstallDirs.prefix (elabAbsoluteInstallDirs pkg)) entryDir = tmpDirNormalised prefix -- if there weren't anything to build, it might be that directory is not created diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 5a93f70c551..37eb08245bf 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -272,13 +272,13 @@ encodePlanAsJson _distDirLayout elaboratedInstallPlan elaboratedSharedConfig = bin_file' s = ["bin-file" J..= J.String bin] where - bin = InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat + bin = elabBinDir elab prettyShow s <.> exeExtension plat flib_file' :: (Pretty a, Show a) => a -> [J.Pair] flib_file' s = ["bin-file" J..= J.String bin] where - bin = InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat + bin = InstallDirs.flibdir (elabAbsoluteInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat comp2str :: ComponentDeps.Component -> String comp2str = prettyShow diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 89104cc3948..52aba71cb24 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -38,6 +38,7 @@ module Distribution.Client.ProjectPlanning ElaboratedInstallPlan , ElaboratedInstalledPackageInfo , ElaboratedConfiguredPackage (..) + , ElaboratedPackageOrComponent (..) , ElaboratedPlanPackage , ElaboratedSharedConfig (..) , ElaboratedReadyPackage @@ -50,6 +51,7 @@ module Distribution.Client.ProjectPlanning , elabOrderExeDependencies , elabLibDependencies , elabExeDependencies + , elabExeDependencyPaths -- * Reading the project configuration -- $readingTheProjectConfiguration @@ -99,11 +101,11 @@ module Distribution.Client.ProjectPlanning , packageHashInputs -- * Path construction - , installedBinDirectory , binDirectories - , storePackageInstallDirs - , storePackageInstallDirs' + , elabBinDir , elabDistDirParams + , elabExePath + , elabAbsoluteInstallDirs -- * Toolchain , configToolchainExSafe @@ -1958,7 +1960,7 @@ elaborateInstallPlan -- 6. Construct the updated local maps let cc_map' = extendConfiguredComponentMap cc cc_map lc_map' = extendLinkedComponentMap lc lc_map - exe_map' = Map.insert cid (installedBinDirectory elab) exe_map + exe_map' = Map.insert cid (elabBinDir elab) exe_map return ((cc_map', lc_map', exe_map'), elab) where @@ -2021,7 +2023,7 @@ elaborateInstallPlan planPackageExePaths = -- Note: the packagedb only include libraries, so pre-installed packages cannot have executables to depend on. InstallPlan.foldPlanPackage (const []) $ \elab -> - [ installedBinDirectory elab ] + [ elabBinDir elab ] elaborateSolverToPackage :: NE.NonEmpty NotPerComponentReason @@ -2682,7 +2684,7 @@ binDirectories binDirectories package = -- quick sanity check: no sense returning a bin directory if we're not going -- to put any executables in it, that will just clog up the PATH - if noExecutables then [] else [installedBinDirectory package] + if noExecutables then [] else [elabBinDir package] where noExecutables = null . PD.executables . elabPkgDescription $ package @@ -3882,29 +3884,11 @@ setupHsScriptOptions -- TODO: It is disappointing that we have to change the stage here getStage pkgConfigToolchains (prevStage elabStage) -storePackageInstallDirs - :: StoreDirLayout - -> Stage - -> Toolchain - -> InstalledPackageId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs storeDirLayout stage toolchain ipkgid = - storePackageInstallDirs' storeDirLayout stage toolchain $ newSimpleUnitId ipkgid - -storePackageInstallDirs' - :: StoreDirLayout - -> Stage - -> Toolchain - -> UnitId - -> InstallDirs.InstallDirs FilePath -storePackageInstallDirs' storeDirLayout stage toolchain unitid = - simplePackageInstallDirs $ storePackageDirectory storeDirLayout stage toolchain unitid - simplePackageInstallDirs :: FilePath - -> InstallDirs.InstallDirs FilePath + -> InstallDirs.InstallDirTemplates simplePackageInstallDirs prefix = - InstallDirs.InstallDirs{..} + InstallDirs.toPathTemplate <$> InstallDirs.InstallDirs{..} where bindir = prefix "bin" libdir = prefix "lib" @@ -3925,7 +3909,7 @@ simplePackageInstallDirs prefix = computeInstallDirs :: StoreDirLayout -> ElaboratedConfiguredPackage - -> InstallDirs.InstallDirs FilePath + -> InstallDirs.InstallDirTemplates computeInstallDirs storeDirLayout elab = simplePackageInstallDirs $ storePackageDirectory storeDirLayout (elabStage elab) (elabToolchain elab) (elabUnitId elab) @@ -3950,8 +3934,6 @@ setupHsConfigureFlags configPackageDBs <- (traverse . traverse . traverse) mkSymbolicPath (Nothing : map Just elabBuildPackageDBStack) return Cabal.ConfigFlags{..} where - Toolchain{toolchainCompiler} = elabToolchain - Cabal.ConfigFlags { configVanillaLib , configSharedLib @@ -4013,7 +3995,7 @@ setupHsConfigureFlags ["-hide-all-packages"] elabProgramArgs configProgramPathExtra = toNubList elabProgramPathExtra - configHcFlavor = toFlag (compilerFlavor toolchainCompiler) + configHcFlavor = toFlag (compilerFlavor (toolchainCompiler elabToolchain)) configHcPath = mempty -- we use configProgramPaths instead configHcPkg = mempty -- we use configProgramPaths instead configDumpBuildInfo = toFlag elabDumpBuildInfo @@ -4027,10 +4009,7 @@ setupHsConfigureFlags configProgPrefix = maybe mempty toFlag elabProgPrefix configProgSuffix = maybe mempty toFlag elabProgSuffix - configInstallDirs = - fmap - (toFlag . InstallDirs.toPathTemplate) - elabInstallDirs + configInstallDirs = toFlag <$> elabInstallDirs -- we only use configDependencies, unless we're talking to an old Cabal -- in which case we use configConstraints @@ -4074,7 +4053,7 @@ setupHsConfigureFlags configUserInstall = mempty -- don't rely on defaults configPrograms_ = mempty -- never use, shouldn't exist configUseResponseFiles = mempty - configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported toolchainCompiler + configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported (toolchainCompiler elabToolchain) configIgnoreBuildTools = mempty cidToGivenComponent :: ConfiguredId -> GivenComponent @@ -4443,10 +4422,6 @@ packageHashConfigInputs pkg = ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage pkg LBC.BuildOptions{..} = elabBuildOptions --- Where executables have been installed for this package -installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath -installedBinDirectory = InstallDirs.bindir . elabInstallDirs - -- FIXME: whathever -- -------------------------------------------------------------------------------- -- -- Configure --coverage-for flags diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 42d5dc126ed..7b0a3157381 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -68,6 +68,10 @@ module Distribution.Client.ProjectPlanning.Types -- * Setup script , SetupScriptStyle (..) + , elabRegistrationPackageDb + , elabAbsoluteInstallDirs + , elabExePath + , elabBinDir ) where import Distribution.Client.Compat.Prelude @@ -124,6 +128,7 @@ import Distribution.Types.PackageDescription (PackageDescription (..)) import Distribution.Types.PkgconfigVersion import Distribution.Verbosity (normal) import Distribution.Version +import Distribution.Utils.Path (()) import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE @@ -131,6 +136,7 @@ import qualified Data.Map as Map import qualified Distribution.Compat.Graph as Graph import Text.PrettyPrint (colon, hsep, parens, text) import qualified Distribution.PackageDescription as PD +import GHC.Stack (HasCallStack) -- | The combination of an elaborated install plan plus a -- 'ElaboratedSharedConfig' contains all the details necessary to be able @@ -297,7 +303,7 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage , elabExtraIncludeDirs :: [FilePath] , elabProgPrefix :: Maybe PathTemplate , elabProgSuffix :: Maybe PathTemplate - , elabInstallDirs :: InstallDirs.InstallDirs FilePath + , elabInstallDirs :: InstallDirs.InstallDirTemplates , elabHaddockHoogle :: Bool , elabHaddockHtml :: Bool , elabHaddockHtmlLocation :: Maybe String @@ -486,6 +492,21 @@ elabExeName elab = Just (CExeName name) -> [PD.unUnqualComponentName name] _ -> [] +elabBinDir :: ElaboratedConfiguredPackage -> FilePath +elabBinDir = InstallDirs.bindir . elabAbsoluteInstallDirs + +-- | The path to the executable for this package/component. +-- FIXME: it does not include configProgPrefix/configProgSuffix +elabExePath :: ElaboratedConfiguredPackage -> FilePath +elabExePath elab = + elabBinDir elab exeName + where + exeNames = elabExeName elab + exeName = + case exeNames of + [name] -> name + _ -> error $ "elabExePath: expected exactly one executable name, got: " ++ show exeNames + -- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'. elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String elabConfiguredName verbosity elab @@ -629,6 +650,35 @@ elabSetupLibDependencies elab = -- Custom setups not supported for components. ElabComponent _ -> [] +elabRegistrationPackageDb + :: HasCallStack + => ElaboratedConfiguredPackage + -> FilePath +elabRegistrationPackageDb elab = + case registrationPackageDB (elabRegisterPackageDBStack elab) of + SpecificPackageDB db -> db + _ -> error "elabRegistrationPackageDb: elabRegisterPackageDB is not a SpecificPackageDB" + +-- | The absolute install dirs for this package/component. +-- NOTE: to be entirely honest, we do not really know these paths. This is because the copy +-- is done by Cabal and we do not have a way to obtain the final paths other than +-- computing them ourselves here. We could hijack the copy process just like we do for +-- register; that would make these paths the source of truth. +elabAbsoluteInstallDirs + :: HasCallStack + => ElaboratedConfiguredPackage + -> InstallDirs.InstallDirs FilePath +elabAbsoluteInstallDirs elab = + InstallDirs.absoluteInstallDirs + (elabPkgSourceId elab) + (elabUnitId elab) + (compilerInfo toolchainCompiler) + (InstallDirs.CopyToDb (elabRegistrationPackageDb elab)) + toolchainPlatform + (elabInstallDirs elab) + where + Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain elab + pkgSetupLibDependencies :: ElaboratedPackage -> [WithStage ConfiguredId] pkgSetupLibDependencies pkg = map (WithStage stage . fst) $ From 0ff7eb06e1c24e2e79be78effebe811aba0d2b2a Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 23 Dec 2025 15:01:04 +0800 Subject: [PATCH 096/122] Replace store copy mechanistm with a simple install into registration packagedb --- .../Client/ProjectBuilding/UnpackedPackage.hs | 133 +++--------------- .../Distribution/Client/ProjectPlanning.hs | 87 ++++++++---- 2 files changed, 85 insertions(+), 135 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 1852ed1c4c6..d2b7b739406 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -18,13 +18,11 @@ module Distribution.Client.ProjectBuilding.UnpackedPackage import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.ProjectBuilding.Types import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.Store import Distribution.Client.DistDirLayout import Distribution.Client.JobControl @@ -61,7 +59,6 @@ import Distribution.Simple.Compiler ( PackageDBStackCWD , coercePackageDBStack ) -import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo ( ComponentName (..) , LibraryName (..) @@ -80,19 +77,16 @@ import Distribution.Utils.Path hiding import Distribution.Version import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 import qualified Data.List.NonEmpty as NE import Control.Exception (Handler (..), SomeAsyncException, catches) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, removeDirectoryRecursive, renameDirectory, renameFile) -import System.FilePath (dropDrive, normalise, takeDirectory, (), makeRelative) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist, removeFile) +import System.FilePath (takeDirectory, ()) import System.IO (Handle, IOMode (AppendMode), withFile) import System.Semaphore (SemaphoreName (..)) import Distribution.Client.Errors -import Distribution.Compat.Directory (listDirectory) import qualified Distribution.Compat.Graph as Graph @@ -115,7 +109,7 @@ data PackageBuildingPhase | PBBuildPhase {runBuild :: IO ()} | PBHaddockPhase {runHaddock :: IO ()} | PBInstallPhase - { runCopy :: FilePath -> IO () + { runCopy :: Cabal.CopyDest -> IO () , runRegister :: PackageDBStackCWD -> Cabal.RegisterOptions @@ -346,10 +340,17 @@ buildAndRegisterUnpackedPackage -> (Version -> [String]) -> IO () setup cmd getCommonFlags flags args = - withLogging $ \mLogFileHandle -> + withLogging $ \mLogFileHandle -> do + let opts = scriptOptions { useLoggingHandle = mLogFileHandle } + info verbosity $ + "Running setup command: " + ++ unwords + ( "useExtraPathEnv" + : useExtraPathEnv opts + ) setupWrapper verbosity - scriptOptions { useLoggingHandle = mLogFileHandle } + opts (Just (elabPkgDescription pkg)) cmd getCommonFlags @@ -460,34 +461,17 @@ buildAndInstallUnpackedPackage PBInstallPhase{runCopy, runRegister} -> do noticeProgress ProgressInstalling - let storeDirLayout = distStoreDirLayout distDirLayout - storeFile = storeDirectory storeDirLayout (elabStage pkg) (elabToolchain pkg) - finalEntryDir = storePackageDirectory storeDirLayout (elabStage pkg) (elabToolchain pkg) uid - incomingDir = storeIncomingDirectory storeDirLayout (elabStage pkg) (elabToolchain pkg) - - withTempDirectory verbosity incomingDir "new" $ \incomingTmpDir -> do - -- Write all store entry files within the temp dir and return the prefix. - (incomingEntryDir, otherFiles) <- copyPkgFiles verbosity pkg runCopy incomingTmpDir - - if elabRequiresRegistration pkg then - void $ runRegister - (elabRegisterPackageDBStack pkg) - Cabal.defaultRegisterOptions - { Cabal.registerMultiInstance = True - , Cabal.registerSuppressFilesCheck = True - } - else - info verbosity $ "registerPkg: elab does NOT require registration for " ++ prettyShow uid - - removeDirectoryRecursive finalEntryDir `catch` \(_ :: IOException) -> - return () -- ignore all IO exceptions, likely the dir did not exist - - renameDirectory incomingEntryDir finalEntryDir - - for_ otherFiles $ \file -> do - let finalStoreFile = storeFile makeRelative (normalise (incomingTmpDir dropDrive storeFile)) file - createDirectoryIfMissing True (takeDirectory finalStoreFile) - renameFile file finalStoreFile + runCopy (Cabal.CopyToDb (elabRegistrationPackageDb pkg)) + + if elabRequiresRegistration pkg then + void $ runRegister + (elabRegisterPackageDBStack pkg) + Cabal.defaultRegisterOptions + { Cabal.registerMultiInstance = True + , Cabal.registerSuppressFilesCheck = True + } + else + info verbosity $ "registerPkg: elab does NOT require registration for " ++ prettyShow uid -- No tests on install PBTestPhase{} -> return () @@ -559,80 +543,9 @@ buildAndInstallUnpackedPackage exists <- doesFileExist logFile when exists $ removeFile logFile --- | The copy part of the installation phase when doing build-and-install -copyPkgFiles - :: Verbosity - -> ElaboratedConfiguredPackage - -> (FilePath -> IO ()) - -- ^ The 'runCopy' function which invokes ./Setup copy for the - -- given filepath - -> FilePath - -- ^ The temporary dir file path - -> IO (FilePath, [FilePath]) -copyPkgFiles verbosity pkg runCopy tmpDir = do - let tmpDirNormalised = normalise tmpDir - runCopy tmpDirNormalised - -- Note that the copy command has put the files into - -- @$tmpDir/$prefix@ so we need to return this dir so - -- the store knows which dir will be the final store entry. - let prefix = - normalise $ - dropDrive (InstallDirs.prefix (elabAbsoluteInstallDirs pkg)) - entryDir = tmpDirNormalised prefix - - -- if there weren't anything to build, it might be that directory is not created - -- the @setup Cabal.copyCommand@ above might do nothing. - -- https://github.com/haskell/cabal/issues/4130 - createDirectoryIfMissingVerbose verbosity True entryDir - - case elabPkgSourceHash pkg of - Nothing -> return () - Just srchash -> do - let hashFileName = entryDir "cabal-hash.txt" - outPkgHashInputs = renderPackageHashInputs (packageHashInputs srchash pkg) - - info verbosity $ - "creating file with the inputs used to compute the package hash: " ++ hashFileName - - LBS.writeFile hashFileName outPkgHashInputs - - debug verbosity "Package hash inputs:" - traverse_ - (debug verbosity . ("> " ++)) - (lines $ LBS.Char8.unpack outPkgHashInputs) - - -- Ensure that there are no files in `tmpDir`, that are - -- not in `entryDir`. While this breaks the - -- prefix-relocatable property of the libraries, it is - -- necessary on macOS to stay under the load command limit - -- of the macOS mach-o linker. See also - -- @PackageHash.hashedInstalledPackageIdVeryShort@. - -- - -- We also normalise paths to ensure that there are no - -- different representations for the same path. Like / and - -- \\ on windows under msys. - otherFiles <- - filter (not . isPrefixOf entryDir) - <$> listFilesRecursive tmpDirNormalised - -- Here's where we could keep track of the installed files - -- ourselves if we wanted to by making a manifest of the - -- files in the tmp dir. - return (entryDir, otherFiles) - where - listFilesRecursive :: FilePath -> IO [FilePath] - listFilesRecursive path = do - files <- fmap (path ) <$> (listDirectory path) - allFiles <- for files $ \file -> do - isDir <- doesDirectoryExist file - if isDir - then listFilesRecursive file - else return [file] - return (concat allFiles) -------------------------------------------------------------------------------- - -- * Exported Utils - -------------------------------------------------------------------------------- {- FOURMOLU_DISABLE -} diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 52aba71cb24..d046b476660 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -217,6 +217,7 @@ import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape import Distribution.Simple.Utils +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version @@ -248,7 +249,7 @@ import Distribution.Solver.Types.ResolverPackage (solverId) import qualified Distribution.Solver.Types.ResolverPackage as ResolverPackage import GHC.Stack (HasCallStack) import System.Directory (getCurrentDirectory) -import System.FilePath +import System.FilePath (takeDirectory) import qualified Text.PrettyPrint as Disp -- $readingTheProjectConfiguration @@ -3884,34 +3885,72 @@ setupHsScriptOptions -- TODO: It is disappointing that we have to change the stage here getStage pkgConfigToolchains (prevStage elabStage) +-- lib/package.conf.d/array-0.5.8.0-78fc.conf +-- ^^^ this needs to be platform specific +-- lib/x86_64-linux-ghc-9.12.2-5a14/libHSarray-0.5.8.0-78fc-ghc9.12.2.so +-- lib/x86_64-linux-ghc-9.12.2-5a14/array-0.5.8.0-78fc/Data/ +-- lib/x86_64-linux-ghc-9.12.2-5a14/array-0.5.8.0-78fc/libHSarray-0.5.8.0-78fc.a + +-- what I have now + +-- _build/stage1/store/build/x86_64-unknown-linux/lib/alex-3.5.4.0-alex/share/AlexTemplate.hs +-- _build/stage1/store/build/x86_64-unknown-linux/package.conf.d/bin/alex + +-- _build/stage1/store/build/x86_64-unknown-linux/lib/directory-1.3.10.0/libHSdirectory-1.3.10.0.a +-- _build/stage1/store/build/x86_64-unknown-linux/lib/directory-1.3.10.0/share/doc/LICENSE +-- _build/stage1/store/build/x86_64-unknown-linux/lib/directory-1.3.10.0/System/Directory.hi +-- _build/stage1/store/build/x86_64-unknown-linux/package.conf.d/array-0.5.8.0.conf + + + +-- build for x86_64-unknown-linux: + +-- bin/ghc +-- bin/x86_64-unknown-linux-ghc (symlink to lib/x86_64-unknown-linux/bin/ghc) +-- lib/settings +-- lib/x86_64-unknown-linux/target (new target file) +-- lib/x86_64-unknown-linux/bin/ghc +-- lib/x86_64-unknown-linux/lib/array-0.5.8.0/libHSarray-0.5.8.0.a +-- lib/x86_64-unknown-linux/lib/libHSarray-0.5.8.0-ghcX.Y.Z.so +-- lib/x86_64-unknown-linux/lib/package.conf.d/array-0.5.8.0.conf +-- +-- TODO: +-- - test bindist with _build/stage2/{bin,lib} +-- - make package.conf entries relative +-- - use platform string from ghc --info rather than cabal's own version + simplePackageInstallDirs :: FilePath + -> UnitId -> InstallDirs.InstallDirTemplates -simplePackageInstallDirs prefix = +simplePackageInstallDirs pkgroot libname = InstallDirs.toPathTemplate <$> InstallDirs.InstallDirs{..} where - bindir = prefix "bin" - libdir = prefix "lib" - libsubdir = "" - dynlibdir = libdir - flibdir = libdir - libexecdir = prefix "libexec" - libexecsubdir = "" - includedir = libdir "include" - datadir = prefix "share" - datasubdir = "" - docdir = datadir "doc" - mandir = datadir "man" - htmldir = docdir "html" - haddockdir = htmldir - sysconfdir = prefix "etc" + prefix = pkgroot + bindir = pkgroot "bin" + libdir = pkgroot "lib" prettyShow libname + libsubdir = "" + dynlibdir = pkgroot "lib" + flibdir = pkgroot "lib" + libexecdir = pkgroot "lib" prettyShow libname "libexec" + libexecsubdir = "" + includedir = pkgroot "lib" prettyShow libname "include" + datadir = pkgroot "lib" prettyShow libname "share" + datasubdir = "" + docdir = pkgroot "lib" prettyShow libname "share/doc" + mandir = pkgroot "lib" prettyShow libname "share/man" + htmldir = pkgroot "lib" prettyShow libname "share/doc/html" + haddockdir = pkgroot "lib" prettyShow libname "share/doc/html" + sysconfdir = pkgroot "etc" computeInstallDirs :: StoreDirLayout -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirTemplates computeInstallDirs storeDirLayout elab = - simplePackageInstallDirs $ storePackageDirectory storeDirLayout (elabStage elab) (elabToolchain elab) (elabUnitId elab) + simplePackageInstallDirs pkgroot (elabUnitId elab) + where + pkgroot = takeDirectory (storePackageDBPath storeDirLayout (elabStage elab) (elabToolchain elab)) -- TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, @@ -3941,11 +3980,9 @@ setupHsConfigureFlags , configDynExe , configFullyStaticExe , configGHCiLib - , -- , configProfExe -- overridden - configProfLib + , configProfLib , configProfShared - , -- , configProf -- overridden - configProfDetail + , configProfDetail , configProfLibDetail , configCoverage , configLibCoverage @@ -4192,12 +4229,12 @@ setupHsCopyFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig -> Cabal.CommonSetupFlags - -> FilePath + -> Cabal.CopyDest -> Cabal.CopyFlags -setupHsCopyFlags _ _ common destdir = +setupHsCopyFlags _ _ common dest = Cabal.CopyFlags { copyCommonFlags = common - , copyDest = toFlag (InstallDirs.CopyTo destdir) + , copyDest = toFlag dest } setupHsRegisterFlags From 602728d2cb4b587b65aaa83dc5be7fd22288f221 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Tue, 27 Jan 2026 17:15:11 +0800 Subject: [PATCH 097/122] Improve logging for program invocations with response file --- Cabal/src/Distribution/Simple/Program.hs | 19 +++++++++++++++++++ Cabal/src/Distribution/Simple/Program/Ar.hs | 19 +++++-------------- Cabal/src/Distribution/Simple/Program/Ld.hs | 14 ++------------ .../Simple/Program/ResponseFile.hs | 2 +- 4 files changed, 27 insertions(+), 27 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index 0609d17c613..eb18de973f6 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -128,6 +128,8 @@ module Distribution.Simple.Program , cppProgram , pkgConfigProgram , hpcProgram + , runProgramWithResponseFile + , runProgramCwdWithResponseFile ) where import Distribution.Compat.Prelude @@ -142,6 +144,7 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Path import Distribution.Verbosity +import Distribution.Simple.Program.ResponseFile (withResponseFile) -- | Runs the given configured program. runProgram @@ -247,3 +250,19 @@ getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = Just configuredProg -> getProgramInvocationOutput verbosity $ programInvocationCwd mbWorkDir configuredProg args + +runProgramWithResponseFile :: Verbosity -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () +runProgramWithResponseFile verbosity prog args1 args2 = do + infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 + withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> + runProgram verbosity prog $ args1 ++ ['@' : path] + where + rfName = programId prog ++ ".rsp" + +runProgramCwdWithResponseFile :: Verbosity -> Maybe (SymbolicPath CWD (Dir to)) -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () +runProgramCwdWithResponseFile verbosity mbWorkDir prog args1 args2 = do + infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 + withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> + runProgramCwd verbosity mbWorkDir prog $ args1 ++ ['@' : path] + where + rfName = programId prog ++ ".rsp" diff --git a/Cabal/src/Distribution/Simple/Program/Ar.hs b/Cabal/src/Distribution/Simple/Program/Ar.hs index 2e9b432385f..4fc18c6c210 100644 --- a/Cabal/src/Distribution/Simple/Program/Ar.hs +++ b/Cabal/src/Distribution/Simple/Program/Ar.hs @@ -28,12 +28,8 @@ import Distribution.Compat.CopyFile (filesEqual) import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program - ( ProgramInvocation - , arProgram - , requireProgram - ) -import Distribution.Simple.Program.ResponseFile - ( withResponseFile + ( arProgram + , requireProgram, runProgramCwdWithResponseFile ) import Distribution.Simple.Program.Run ( multiStageProgramInvocation @@ -45,8 +41,7 @@ import Distribution.Simple.Setup.Config ( configUseResponseFiles ) import Distribution.Simple.Utils - ( defaultTempFileOptions - , dieWithLocation' + ( dieWithLocation' , withTempDirectoryCwd ) import Distribution.System @@ -140,10 +135,6 @@ createArLibArchive verbosity lbi targetPath files = do dashLSupported = arDashLSupported (compiler lbi) - invokeWithResponseFile :: FilePath -> ProgramInvocation - invokeWithResponseFile atFile = - (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile]) - if oldVersionManualOverride || responseArgumentsNotSupported then sequence_ @@ -154,8 +145,8 @@ createArLibArchive verbosity lbi targetPath files = do (initial, middle, final) (map getSymbolicPath files) ] - else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ - \path -> runProgramInvocation verbosity $ invokeWithResponseFile path + else + runProgramCwdWithResponseFile verbosity mbWorkDir arProg (simpleArgs ++ extraArgs) (map getSymbolicPath files) unless ( hostArch == Arm -- See #1537 diff --git a/Cabal/src/Distribution/Simple/Program/Ld.hs b/Cabal/src/Distribution/Simple/Program/Ld.hs index 00ed5d182d7..262b68910dd 100644 --- a/Cabal/src/Distribution/Simple/Program/Ld.hs +++ b/Cabal/src/Distribution/Simple/Program/Ld.hs @@ -24,9 +24,6 @@ import Distribution.Simple.Flag ( fromFlagOrDefault ) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) -import Distribution.Simple.Program.ResponseFile - ( withResponseFile - ) import Distribution.Simple.Program.Run ( ProgramInvocation , multiStageProgramInvocation @@ -39,9 +36,6 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Setup.Config ( configUseResponseFiles ) -import Distribution.Simple.Utils - ( defaultTempFileOptions - ) import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity @@ -50,6 +44,7 @@ import Distribution.Verbosity import System.Directory ( renameFile ) +import Distribution.Simple.Program (runProgramCwdWithResponseFile) -- | Call @ld -r@ to link a bunch of object files together. combineObjectFiles @@ -83,10 +78,6 @@ combineObjectFiles verbosity lbi ldProg target files = do middle = ld middleArgs final = ld finalArgs - invokeWithResponseFile :: FilePath -> ProgramInvocation - invokeWithResponseFile atFile = - ld $ simpleArgs ++ ['@' : atFile] - oldVersionManualOverride = fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi -- Whether ghc's ar supports response files is a good proxy for @@ -104,7 +95,6 @@ combineObjectFiles verbosity lbi ldProg target files = do if oldVersionManualOverride || responseArgumentsNotSupported then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files) - else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $ - \path -> runProgramInvocation verbosity $ invokeWithResponseFile path + else runProgramCwdWithResponseFile verbosity (mbWorkDirLBI lbi) ldProg simpleArgs (map getSymbolicPath files) where tmpfile = target <.> "tmp" -- perhaps should use a proper temp file diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index eaf53ab5a5b..b392fa27833 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -40,7 +40,7 @@ withResponseFile _verbosity tmpFileOpts fileNameTemplate encoding arguments f = traverse_ (hSetEncoding hf) encoding let responseContents = unlines $ - map escapeResponseFileArg $ + map escapeResponseFileArg arguments hPutStr hf responseContents hClose hf From 795e048b6e348b51e98c991a028d9a18a38477ff Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 Jan 2026 16:35:36 +0800 Subject: [PATCH 098/122] improve logging --- Cabal/src/Distribution/Simple/Program.hs | 12 ++- Cabal/src/Distribution/Simple/Utils.hs | 100 ++++++++++++++---- .../src/Distribution/Client/SetupWrapper.hs | 67 +++++------- .../src/Distribution/Client/Utils.hs | 60 ++--------- 4 files changed, 124 insertions(+), 115 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index eb18de973f6..ee7db75079f 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -130,6 +130,7 @@ module Distribution.Simple.Program , hpcProgram , runProgramWithResponseFile , runProgramCwdWithResponseFile + , logInvoke ) where import Distribution.Compat.Prelude @@ -253,7 +254,7 @@ getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = runProgramWithResponseFile :: Verbosity -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () runProgramWithResponseFile verbosity prog args1 args2 = do - infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 + logInvoke verbosity (programPath prog) (args1 ++ args2) withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> runProgram verbosity prog $ args1 ++ ['@' : path] where @@ -261,8 +262,15 @@ runProgramWithResponseFile verbosity prog args1 args2 = do runProgramCwdWithResponseFile :: Verbosity -> Maybe (SymbolicPath CWD (Dir to)) -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () runProgramCwdWithResponseFile verbosity mbWorkDir prog args1 args2 = do - infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 + logInvoke verbosity (programPath prog) (args1 ++ args2) withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> runProgramCwd verbosity mbWorkDir prog $ args1 ++ ['@' : path] where rfName = programId prog ++ ".rsp" + +-- | Log the invocation of a program +-- This is defined here to provide a common styling for all invocations +-- throughout Cabal. +logInvoke :: Verbosity -> FilePath -> [String] -> IO () +logInvoke verbosity path args = + infoNoWrap verbosity $ unwords ("Running:" : path : args) \ No newline at end of file diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 204f3b1dac7..cb98cb48fce 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -136,6 +136,9 @@ module Distribution.Simple.Utils -- * environment variables , isInSearchPath , addLibraryPath + , withEnv + , withEnvOverrides + , withExtraPathEnv -- * modification time , moreRecentFile @@ -209,6 +212,7 @@ module Distribution.Simple.Utils import Distribution.Compat.Async (waitCatch, withAsyncNF) import Distribution.Compat.CopyFile +import Distribution.Compat.Environment import Distribution.Compat.FilePath as FilePath import Distribution.Compat.Internal.TempFile import Distribution.Compat.Lens (Lens', over) @@ -304,6 +308,7 @@ import GitHash , tGitInfoCwdTry ) #endif +import Control.Monad (zipWithM_) #if MIN_VERSION_base(4,21,0) import Control.Exception.Context @@ -913,23 +918,6 @@ maybeExit cmd = do exitcode <- cmd unless (exitcode == ExitSuccess) $ exitWith exitcode --- | Log a command execution (that's typically about to happen) --- at info level, and log working directory and environment overrides --- at debug level if specified. -logCommand :: Verbosity -> Process.CreateProcess -> IO () -logCommand verbosity cp = do - infoNoWrap verbosity $ - "Running: " <> case Process.cmdspec cp of - Process.ShellCommand sh -> sh - Process.RawCommand path args -> Process.showCommandForUser path args - case Process.env cp of - Just env -> debugNoWrap verbosity $ "with environment: " ++ show env - Nothing -> return () - case Process.cwd cp of - Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd - Nothing -> return () - hFlush stdout - -- | Execute the given command with the given arguments, exiting -- with the same exit code if the command fails. rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO () @@ -980,7 +968,6 @@ rawSystemProcAction -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) -> IO (ExitCode, a) rawSystemProcAction verbosity cp action = withFrozenCallStack $ do - logCommand verbosity cp (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do a <- action mStdin mStdout mStderr exitcode <- Process.waitForProcess p @@ -2072,3 +2059,80 @@ stripCommonPrefix (x : xs) (y : ys) | x == y = stripCommonPrefix xs ys | otherwise = y : ys stripCommonPrefix _ ys = ys + +-- | Executes the action with an environment variable set to some +-- value. +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnv :: Verbosity -> String -> String -> IO a -> IO a +withEnv verbosity k v m = do + info verbosity $ "Setting environment variable: " ++ k ++ "=" ++ v + mb_old <- lookupEnv k + setEnv k v + m `Exception.finally` setOrUnsetEnv k mb_old + +-- | Executes the action with a list of environment variables and +-- corresponding overrides, where +-- +-- * @'Just' v@ means \"set the environment variable's value to @v@\". +-- * 'Nothing' means \"unset the environment variable\". +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnvOverrides :: Verbosity -> [(String, Maybe FilePath)] -> IO a -> IO a +withEnvOverrides verbosity overrides m = do + logExtraProgramOverrideEnv verbosity overrides + mb_olds <- traverse lookupEnv envVars + traverse_ (uncurry setOrUnsetEnv) overrides + m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds + where + envVars :: [String] + envVars = map fst overrides + +setOrUnsetEnv :: String -> Maybe String -> IO () +setOrUnsetEnv var Nothing = unsetEnv var +setOrUnsetEnv var (Just val) = setEnv var val + +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: Verbosity -> [FilePath] -> IO a -> IO a +withExtraPathEnv verbosity paths m = do + logExtraProgramSearchPath verbosity paths + oldPathSplit <- getSearchPath + let newPath :: String + newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath :: String + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p + | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + +logExtraProgramSearchPath + :: Verbosity + -> [FilePath] + -> IO () +logExtraProgramSearchPath verbosity extraPaths = + info verbosity . unlines $ + "Including the following directories in PATH:" + : map ("- " ++) extraPaths + +logExtraProgramOverrideEnv + :: Verbosity + -> [(String, Maybe String)] + -> IO () +logExtraProgramOverrideEnv verbosity extraEnv = + info verbosity . unlines $ + "Including the following environment variable overrides:" + : [ "- " ++ case mbVal of + Nothing -> "unset " ++ var + Just val -> var ++ "=" ++ val + | (var, mbVal) <- extraEnv + ] diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index b343680754d..368a26a1e0f 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -78,6 +78,7 @@ import Distribution.Simple.Program , getDbProgramOutputCwd , getProgramSearchPath , ghcProgram + , logInvoke , runDbProgramCwd ) import Distribution.Simple.Program.Db @@ -536,20 +537,14 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs = d flags extraArgs --- ------------------------------------------------------------ - +-------------------------------------------------------------- -- * Internal SetupMethod - --- ------------------------------------------------------------ +-------------------------------------------------------------- -- | Run a Setup script by directly invoking the @Cabal@ library. internalSetupMethod :: SetupRunner internalSetupMethod verbosity options bt args = do - info verbosity $ - "Using internal setup method with build-type " - ++ show bt - ++ " and args:\n " - ++ unwords args + info verbosity $ "Using internal setup method with build-type " ++ show bt -- NB: we do not set the working directory of the process here, because -- we will instead pass the -working-dir flag when invoking the Setup script. -- Note that the Setup script is guaranteed to support this flag, because @@ -558,9 +553,9 @@ internalSetupMethod verbosity options bt args = do -- In the future, it would be desirable to also stop relying on the following -- pieces of process-global state, as this would allow us to use this internal -- setup method in concurrent contexts. - withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ - withExtraPathEnv (useExtraPathEnv options) $ - withEnvOverrides (useExtraEnvOverrides options) $ + withEnv verbosity "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ + withExtraPathEnv verbosity (useExtraPathEnv options) $ + withEnvOverrides verbosity (useExtraEnvOverrides options) $ buildTypeAction bt args buildTypeAction :: BuildType -> ([String] -> IO ()) @@ -574,7 +569,7 @@ buildTypeAction Custom = error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do - info verbosity $ unwords (path : args) + logInvoke verbosity path args case useLoggingHandle options of Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle @@ -591,12 +586,10 @@ invoke verbosity path args options = do ] ++ progOverrideEnv progDb - let loggingHandle = case useLoggingHandle options of - Nothing -> Inherit - Just hdl -> UseHandle hdl + let loggingHandle = maybe Inherit UseHandle (useLoggingHandle options) cp = (proc path args) - { Process.cwd = fmap getSymbolicPath $ useWorkingDir options + { Process.cwd = getSymbolicPath <$> useWorkingDir options , Process.env = env , Process.std_out = loggingHandle , Process.std_err = loggingHandle @@ -604,11 +597,9 @@ invoke verbosity path args options = do } maybeExit $ rawSystemProc verbosity cp --- ------------------------------------------------------------ - +-------------------------------------------------------------- -- * Self-Exec SetupMethod - --- ------------------------------------------------------------ +-------------------------------------------------------------- selfExecSetupMethod :: SetupRunner selfExecSetupMethod verbosity options bt args0 = do @@ -618,11 +609,8 @@ selfExecSetupMethod verbosity options bt args0 = do , "--" ] ++ args0 - info verbosity $ - "Using self-exec internal setup method with build-type " - ++ show bt - ++ " and args:\n " - ++ unwords args + info verbosity $ "Using self-exec internal setup method with build-type " ++ show bt + -- no need to log the command line here, invoke will do it path <- getExecutablePath invoke verbosity path args options @@ -678,10 +666,8 @@ getExternalSetupMethod -> BuildType -> IO (Version, SetupMethod, SetupScriptOptions) getExternalSetupMethod verbosity options pkg bt = do - debug verbosity $ "Using external setup method with build-type " ++ show bt - debug verbosity $ - "Using explicit dependencies: " - ++ show (useDependenciesExclusive options) + info verbosity $ "Using external setup method with build-type " ++ show bt + debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options) createDirectoryIfMissingVerbose verbosity True $ i setupDir (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion @@ -857,13 +843,12 @@ getExternalSetupMethod verbosity options pkg bt = do let customSetupHooks = workingDir options "SetupHooks.hs" useHs <- doesFileExist customSetupHooks - unless (useHs) $ + unless useHs $ die' verbosity "Using 'build-type: Hooks' but there is no SetupHooks.hs file." copyFileVerbose verbosity customSetupHooks (i setupHooks) rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) --- rewriteFileLBS verbosity hooksHs hooksScript updateSetupScript cabalLibVersion _ = rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) @@ -1082,9 +1067,7 @@ getExternalSetupMethod verbosity options pkg bt = do (compiler, progdb, options'') <- configureToolchains options' pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - (program, extraOpts) = - case compilerFlavor compiler of - _ -> (ghcProgram, ["-threaded"]) + extraOpts = ["-threaded"] cabalDep = maybe [] @@ -1137,11 +1120,11 @@ getExternalSetupMethod verbosity options pkg bt = do ] , ghcOptExtra = extraOpts , ghcOptExtensions = toNubListR $ - if bt == Custom || any (isBasePkgId . snd) selectedDeps - then [] - else [ Simple.DisableExtension Simple.ImplicitPrelude ] - -- Pass -WNoImplicitPrelude to avoid depending on base - -- when compiling a Simple Setup.hs file. + [ Simple.DisableExtension Simple.ImplicitPrelude + | not (bt == Custom || any (isBasePkgId . snd) selectedDeps) + ] + -- Pass -WNoImplicitPrelude to avoid depending on base + -- when compiling a Simple Setup.hs file. , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler } let ghcCmdLine = renderGhcOptions compiler platform ghcOptions @@ -1149,7 +1132,7 @@ getExternalSetupMethod verbosity options pkg bt = do rewriteFileEx verbosity (i cppMacrosFile) $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) case useLoggingHandle options of - Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine + Nothing -> runDbProgramCwd verbosity mbWorkDir ghcProgram progdb ghcCmdLine -- If build logging is enabled, redirect compiler output to -- the log file. Just logHandle -> do @@ -1157,7 +1140,7 @@ getExternalSetupMethod verbosity options pkg bt = do getDbProgramOutputCwd verbosity mbWorkDir - program + ghcProgram progdb ghcCmdLine hPutStr logHandle output diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index 07db71a9f9d..ddb649bd21c 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -71,7 +71,7 @@ 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) +import Distribution.Simple.Utils (dieWithException, findPackageDesc, noticeNoWrap, info) import Distribution.Utils.Path ( CWD , FileOrDir (..) @@ -124,6 +124,12 @@ import qualified System.IO.Error as IOError import qualified Data.Set as Set import Distribution.Simple.PackageDescription (readGenericPackageDescription) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) +import Distribution.Simple.Program.Find (logExtraProgramSearchPath, logExtraProgramOverrideEnv) +import Distribution.Utils + ( withEnv + , withEnvOverrides + , withExtraPathEnv + ) -- | 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] @@ -175,58 +181,6 @@ withTempFileName tmpDir template action = (\(name, _) -> removeExistingFile name) (\(name, h) -> hClose h >> action name) --- | Executes the action with an environment variable set to some --- value. --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnv :: String -> String -> IO a -> IO a -withEnv k v m = do - mb_old <- lookupEnv k - setEnv k v - m `Exception.finally` setOrUnsetEnv k mb_old - --- | Executes the action with a list of environment variables and --- corresponding overrides, where --- --- * @'Just' v@ means \"set the environment variable's value to @v@\". --- * 'Nothing' means \"unset the environment variable\". --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a -withEnvOverrides overrides m = do - mb_olds <- traverse lookupEnv envVars - traverse_ (uncurry setOrUnsetEnv) overrides - m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds - where - envVars :: [String] - envVars = map fst overrides - -setOrUnsetEnv :: String -> Maybe String -> IO () -setOrUnsetEnv var Nothing = unsetEnv var -setOrUnsetEnv var (Just val) = setEnv var val - --- | Executes the action, increasing the PATH environment --- in some way --- --- Warning: This operation is NOT thread-safe, because the --- environment variables are a process-global concept. -withExtraPathEnv :: [FilePath] -> IO a -> IO a -withExtraPathEnv paths m = do - oldPathSplit <- getSearchPath - let newPath :: String - newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) - oldPath :: String - oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit - -- TODO: This is a horrible hack to work around the fact that - -- setEnv can't take empty values as an argument - mungePath p - | p == "" = "/dev/null" - | otherwise = p - setEnv "PATH" newPath - m `Exception.finally` setEnv "PATH" oldPath - -- | Log directory change in 'make' compatible syntax logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a logDirChange _ Nothing m = m From 6bfa8aea33d64337212c44117b326f241911348f Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 Jan 2026 18:27:31 +0800 Subject: [PATCH 099/122] Make sense of ./configure script invocation --- Cabal/src/Distribution/Make.hs | 5 +- Cabal/src/Distribution/Simple.hs | 7 +- .../Distribution/Simple/ConfigureScript.hs | 215 ++++-------------- Cabal/src/Distribution/Simple/Setup/Config.hs | 14 +- .../src/Distribution/Client/Utils.hs | 2 +- 5 files changed, 52 insertions(+), 191 deletions(-) diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs index 1568abaac60..3a22bfd07cb 100644 --- a/Cabal/src/Distribution/Make.hs +++ b/Cabal/src/Distribution/Make.hs @@ -131,10 +131,7 @@ configureAction flags args = do let verbosity = fromFlag $ configVerbosity flags mbWorkDir = flagToMaybe $ configWorkingDir flags rawSystemExit verbosity mbWorkDir "sh" $ - "configure" - : configureArgs backwardsCompatHack flags - where - backwardsCompatHack = True + "configure" : configureArgs flags copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs index 3a7ffbfdf39..b16ab8e1597 100644 --- a/Cabal/src/Distribution/Simple.hs +++ b/Cabal/src/Distribution/Simple.hs @@ -939,7 +939,6 @@ autoconfUserHooks = runConfigureScript flags (flagAssignment lbi) - (withPrograms lbi) (hostPlatform lbi) pbi <- getHookedBuildInfo verbosity mbWorkDir (buildDir lbi) sanityCheckHookedBuildInfo verbosity pkg_descr pbi @@ -1002,16 +1001,14 @@ autoconfSetupHooks = -> IO () post_conf_pkg ( SetupHooks.PostConfPackageInputs - { SetupHooks.localBuildConfig = - LBC.LocalBuildConfig{LBC.withPrograms = progs} - , SetupHooks.packageBuildDescr = + { SetupHooks.packageBuildDescr = LBC.PackageBuildDescr { LBC.configFlags = cfg , LBC.flagAssignment = flags , LBC.hostPlatform = plat } } - ) = runConfigureScript cfg flags progs plat + ) = runConfigureScript cfg flags plat pre_conf_comp :: SetupHooks.PreConfComponentInputs diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index 6374d510c55..e7709078b65 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -28,7 +28,6 @@ import Distribution.Simple.Configure (findDistPrefOrDefault) import Distribution.Simple.Errors import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program -import Distribution.Simple.Program.Db import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Simple.Utils @@ -43,170 +42,71 @@ import qualified System.FilePath as FilePath import System.FilePath (normalise, splitDrive) #endif import Distribution.Compat.Directory (makeAbsolute) -import Distribution.Compat.Environment (getEnvironment) -import Distribution.Compat.GetShortPathName (getShortPathName) - -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Map as Map runConfigureScript :: ConfigFlags -> FlagAssignment - -> ProgramDb -> Platform -- ^ host platform -> IO () -runConfigureScript cfg flags programDb hp = do +runConfigureScript cfg flags hp = do let commonCfg = configCommonFlags cfg verbosity = fromFlag $ setupVerbosity commonCfg + dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg + let build_dir = dist_dir makeRelativePathEx "build" mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg - configureScriptPath = packageRoot commonCfg "configure" + build_in = interpretSymbolicPath mbWorkDir build_dir + + let configureScriptPath = packageRoot commonCfg "configure" confExists <- doesFileExist configureScriptPath unless confExists $ dieWithException verbosity (ConfigureScriptNotFound configureScriptPath) - configureFile <- - makeAbsolute $ configureScriptPath - env <- getEnvironment - (ccProg, ccFlags) <- configureCCompiler verbosity programDb - ccProgShort <- getShortPathName ccProg - -- The C compiler's compilation and linker flags (e.g. - -- "C compiler flags" and "Gcc Linker flags" from GHC) have already - -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS - -- to ccFlags - -- We don't try and tell configure which ld to use, as we don't have - -- a way to pass its flags too - - -- Do not presume the CXX compiler is available, but it always will be after 9.4. - (mcxxProgShort, mcxxFlags) <- do - mprog <- needProgram verbosity gppProgram programDb - case mprog of - Just (p, _) -> do - let pInv = programInvocation p [] - let cxxProg = progInvokePath pInv - let cxxFlags = progInvokeArgs pInv - cxxProgShort <- getShortPathName cxxProg - return (Just cxxProgShort, Just cxxFlags) - Nothing -> return (Nothing, Nothing) - - let configureFile' = toUnix configureFile - -- autoconf is fussy about filenames, and has a set of forbidden - -- characters that can't appear in the build directory, etc: - -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions - -- - -- This has caused hard-to-debug failures in the past (#5368), so we - -- detect some cases early and warn with a clear message. Windows's - -- use of backslashes is problematic here, so we'll switch to - -- slashes, but we do still want to fail on backslashes in POSIX - -- paths. - -- - -- TODO: We don't check for colons, tildes or leading dashes. We - -- also should check the builddir's path, destdir, and all other - -- paths as well. - for_ badAutoconfCharacters $ \(c, cname) -> - when (c `elem` FilePath.dropDrive configureFile') $ - warn verbosity $ - concat - [ "The path to the './configure' script, '" - , configureFile' - , "', contains the character '" - , [c] - , "' (" - , cname - , ")." - , " This may cause the script to fail with an obscure error, or for" - , " building the package to fail later." - ] - - let - -- Convert a flag name to name of environment variable to represent its - -- value for the configure script. - flagEnvVar :: FlagName -> String - flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) - where - f c - | isAlphaNum c = c - | otherwise = '_' - -- A map from such env vars to every flag name and value where the name - -- name maps to that that env var. - cabalFlagMap :: Map String (NonEmpty (FlagName, Bool)) - cabalFlagMap = - Map.fromListWith - (<>) - [ (flagEnvVar flag, (flag, bool) :| []) - | (flag, bool) <- unFlagAssignment flags - ] - -- A map from env vars to flag names to the single flag we will go with - cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <- - flip Map.traverseWithKey cabalFlagMap $ \envVar -> \case - -- No conflict: no problem - singleFlag :| [] -> pure singleFlag - -- Conflict: warn and discard all but first - collidingFlags@(firstFlag :| _ : _) -> do - let quote s = "'" ++ s ++ "'" - toName = quote . unFlagName . fst - renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags - warn verbosity $ - unwords - [ "Flags" - , renderedList - , "all map to the same environment variable" - , quote envVar - , "causing a collision." - , "The value first flag" - , toName firstFlag - , "will be used." - ] - pure firstFlag + configureFile <- toUnix <$> makeAbsolute configureScriptPath - let cabalFlagEnv = - [ (envVar, Just val) - | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted - , let val = if bool then "1" else "0" - ] - ++ [ - ( "CABAL_FLAGS" - , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags] - ) - ] - let extraPath = fromNubList $ configProgramPathExtra cfg - let mkFlagsEnv fs var = maybe (unwords fs) (++ (" " ++ unwords fs)) (lookup var env) - spSep = [FilePath.searchPathSeparator] - pathEnv = - maybe - (intercalate spSep extraPath) - ((intercalate spSep extraPath ++ spSep) ++) - $ lookup "PATH" env - overEnv = - ("CFLAGS", Just (mkFlagsEnv ccFlags "CFLAGS")) - : [("CXXFLAGS", Just (mkFlagsEnv cxxFlags "CXXFLAGS")) | Just cxxFlags <- [mcxxFlags]] - ++ [("PATH", Just pathEnv) | not (null extraPath)] - ++ cabalFlagEnv - maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = - configureFile' - : args - ++ ["CC=" ++ ccProgShort] - ++ ["CXX=" ++ cxxProgShort | Just cxxProgShort <- [mcxxProgShort]] - ++ maybeHostFlag - shProg = simpleProgram "sh" - progDb <- prependProgramSearchPath verbosity extraPath [] emptyProgramDb - shConfiguredProg <- - lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb - case shConfiguredProg of - Just sh -> do - let build_in = interpretSymbolicPath mbWorkDir build_dir - createDirectoryIfMissing True build_in + createDirectoryIfMissing True build_in + withExtraPathEnv verbosity extraPath $ + withEnvOverrides verbosity envOverrides $ do + logInvoke verbosity configureFile args runProgramInvocation verbosity $ - (programInvocation (sh{programOverrideEnv = overEnv}) args') + (simpleProgramInvocation configureFile args) { progInvokeCwd = Just build_in } - Nothing -> dieWithException verbosity NotFoundMsg + where - args = configureArgs backwardsCompatHack cfg - backwardsCompatHack = False + cc = foldMap ("CC=" <>) $ lookup "gcc" (configProgramPaths cfg) + cc_flags = foldMap (("CC_FLAGS=" <>) . unwords) $ lookup "gcc" (configProgramArgs cfg) + cxx = foldMap ("CXX=" <>) $ lookup "gpp" (configProgramPaths cfg) + cxx_flags = foldMap (("CXX_FLAGS=" <>) . unwords) $ lookup "gpp" (configProgramArgs cfg) + ghc = foldMap ("GHC=" <>) $ lookup "ghc" (configProgramPaths cfg) + ghc_pkg = foldMap ("GHC_PKG=" <>) $ lookup "ghc-pkg" (configProgramPaths cfg) + + -- Convert a flag name to name of environment variable to represent its + -- value for the configure script. + flagEnvVar :: FlagName -> String + flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag) + where + f c + | isAlphaNum c = c + | otherwise = '_' + + -- A map from such env vars to every flag name and value where the name + -- name maps to that that env var. + cabalFlagMap = + [ (flagEnvVar flag, Just $ if bool then "1" else "0") + | (flag, bool) <- unFlagAssignment flags + ] + + cabalFlagEnv = + [( "CABAL_FLAGS" + , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags] + )] + + extraPath = fromNubList $ configProgramPathExtra cfg + envOverrides = cabalFlagMap ++ cabalFlagEnv + maybeHostFlag = ["--host=" ++ show (pretty hp) | hp /= buildPlatform] + args = configureArgs cfg ++ [cc, cc_flags, cxx, cxx_flags, ghc, ghc_pkg] ++ maybeHostFlag -- | Convert Windows path to Unix ones toUnix :: String -> String @@ -220,28 +120,3 @@ toUnix s = let tmp = normalise s #else toUnix s = intercalate "/" $ FilePath.splitDirectories s #endif - -badAutoconfCharacters :: [(Char, String)] -badAutoconfCharacters = - [ (' ', "space") - , ('\t', "tab") - , ('\n', "newline") - , ('\0', "null") - , ('"', "double quote") - , ('#', "hash") - , ('$', "dollar sign") - , ('&', "ampersand") - , ('\'', "single quote") - , ('(', "left bracket") - , (')', "right bracket") - , ('*', "star") - , (';', "semicolon") - , ('<', "less-than sign") - , ('=', "equals sign") - , ('>', "greater-than sign") - , ('?', "question mark") - , ('[', "left square bracket") - , ('\\', "backslash") - , ('`', "backtick") - , ('|', "pipe") - ] diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 21e455f0cc8..78e463e8df7 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -1062,9 +1062,9 @@ instance Semigroup ConfigFlags where -- | Arguments to pass to a @configure@ script, e.g. generated by -- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags = - hc_flag +configureArgs :: ConfigFlags -> [String] +configureArgs flags = + optFlag "with-compiler" configHcPath ++ optFlag "with-hc-pkg" configHcPkg ++ optFlag' "prefix" prefix ++ optFlag' "bindir" bindir @@ -1074,14 +1074,6 @@ configureArgs bcHack flags = ++ optFlag' "sysconfdir" sysconfdir ++ configConfigureArgs flags where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] - (NoFlag, NoFlag) -> [] - hc_flag_name - -- TODO kill off this bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" optFlag name config_field = case config_field flags of Flag p -> ["--" ++ name ++ "=" ++ p] NoFlag -> [] diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index ddb649bd21c..128c76ec221 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -125,7 +125,7 @@ import qualified Data.Set as Set import Distribution.Simple.PackageDescription (readGenericPackageDescription) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) import Distribution.Simple.Program.Find (logExtraProgramSearchPath, logExtraProgramOverrideEnv) -import Distribution.Utils +import Distribution.Simple.Utils ( withEnv , withEnvOverrides , withExtraPathEnv From 0364e21a8c948cd19b85d092ffd61e370f66bd95 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 Jan 2026 18:25:22 +0800 Subject: [PATCH 100/122] move log files --- .../src/Distribution/Client/DistDirLayout.hs | 5 +++-- .../Client/ProjectBuilding/UnpackedPackage.hs | 21 +++++++------------ 2 files changed, 11 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 4bc2a151aef..53010b72b69 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -22,6 +22,7 @@ module Distribution.Client.DistDirLayout , CabalDirLayout (..) , mkCabalDirLayout , defaultCabalDirLayout + , betterPlatform ) where import Distribution.Client.Compat.Prelude @@ -40,10 +41,10 @@ import Distribution.Package , UnitId ) import Distribution.Simple.Compiler - ( PackageDBCWD + ( Compiler(..) + , PackageDBCWD , PackageDBX (..) ) -import Distribution.Simple.Compiler (Compiler(..)) import qualified Data.Map as Map -- | Information which can be used to construct the path to diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index d2b7b739406..89ed54d10c2 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -341,13 +341,7 @@ buildAndRegisterUnpackedPackage -> IO () setup cmd getCommonFlags flags args = withLogging $ \mLogFileHandle -> do - let opts = scriptOptions { useLoggingHandle = mLogFileHandle } - info verbosity $ - "Running setup command: " - ++ unwords - ( "useExtraPathEnv" - : useExtraPathEnv opts - ) + let opts = scriptOptions{useLoggingHandle = mLogFileHandle} setupWrapper verbosity opts @@ -414,7 +408,7 @@ buildAndInstallUnpackedPackage verbosity distDirLayout maybe_semaphore - buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} + buildSettings@BuildTimeSettings{buildSettingNumJobs} registerLock cacheLock pkgshared @@ -506,8 +500,6 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg - Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain pkg - dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component @@ -530,9 +522,12 @@ buildAndInstallUnpackedPackage mlogFile :: Maybe FilePath mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid) + Just + $ distDirectory distDirLayout + "logs" + prettyShow (elabStage pkg) + betterPlatform (elabToolchain pkg) + prettyShow (elabUnitId pkg) initLogFile :: IO () initLogFile = From 8c0c0e79bf208de5e6aa7d89d86acf6f6f067cd4 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 Jan 2026 18:24:03 +0800 Subject: [PATCH 101/122] style changes --- Cabal/src/Distribution/Simple/Configure.hs | 20 ++++++++------------ Cabal/src/Distribution/Simple/Program/Db.hs | 2 +- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 00229a4f8db..042352809d5 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -422,7 +422,7 @@ findDistPref -- ^ override \"dist\" prefix -> IO (SymbolicPath Pkg (Dir Dist)) findDistPref defDistPref overrideDistPref = do - envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + envDistPref <- parseEnvDistPref <$> lookupEnv "CABAL_BUILDDIR" return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) where parseEnvDistPref env = @@ -705,7 +705,7 @@ computeLocalBuildConfig cfg comp programDb = do -- rely on them. By the time that bug was fixed, ghci had -- been changed to read shared libraries instead of archive -- files (see next code block). - notElem (GHC.compilerBuildWay comp) [DynWay, ProfDynWay] + GHC.compilerBuildWay comp `notElem` [DynWay, ProfDynWay] _ -> False withGHCiLib_ <- @@ -1141,13 +1141,9 @@ finalCheckPackage -- Check languages and extensions -- TODO: Move this into a helper function. let langlist = - nub $ - catMaybes $ - map - defaultLanguage - (enabledBuildInfos pkg_descr enabled) + nub $ mapMaybe defaultLanguage (enabledBuildInfos pkg_descr enabled) let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ + unless (null langs) $ dieWithException verbosity $ UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs) let extlist = @@ -1156,14 +1152,14 @@ finalCheckPackage allExtensions (enabledBuildInfos pkg_descr enabled) let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ + unless (null exts) $ dieWithException verbosity $ UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (map prettyShow exts) -- Check foreign library build requirements let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs - when (not (null unsupportedFLibs)) $ + unless (null unsupportedFLibs) $ dieWithException verbosity $ CantFindForeignLibraries unsupportedFLibs @@ -1536,7 +1532,7 @@ dependencySatisfiable else Satisfied internalDepSatisfiable = - let missingLibraries = (NES.toSet sublibs) `Set.difference` packageLibraries + let missingLibraries = NES.toSet sublibs `Set.difference` packageLibraries in case nonEmpty $ Set.toList missingLibraries of Nothing -> Satisfied Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' @@ -2842,7 +2838,7 @@ checkRelocatable verbosity pkg lbi = traverse_ (doCheck $ getSymbolicPath pkgr) ipkgs where doCheck pkgr ipkg - | maybe False (== pkgr) (IPI.pkgRoot ipkg) = + | (Just pkgr ==) (IPI.pkgRoot ipkg) = for_ (IPI.libraryDirs ipkg) $ \libdir -> do -- When @prefix@ is not under @pkgroot@, -- @shortRelativePath prefix pkgroot@ will return a path with diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs index bc5d0714aa3..68476773df5 100644 --- a/Cabal/src/Distribution/Simple/Program/Db.hs +++ b/Cabal/src/Distribution/Simple/Program/Db.hs @@ -428,7 +428,7 @@ configureUnconfiguredProgram verbosity prog progdb = do , programVersion = version , programDefaultArgs = [] , programOverrideArgs = userSpecifiedArgs prog progdb - , programOverrideEnv = [("PATH", Just newPath)] ++ progOverrideEnv progdb + , programOverrideEnv = ("PATH", Just newPath) : progOverrideEnv progdb , programProperties = Map.empty , programLocation = location , programMonitorFiles = triedLocations From ade97ae097f5d05656d5edc275b0405a8d98a0c1 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Thu, 29 Jan 2026 16:50:41 +0800 Subject: [PATCH 102/122] fixup! Make sense of ./configure script invocation --- .../Distribution/Simple/ConfigureScript.hs | 45 +++++++++++++------ Cabal/src/Distribution/Simple/Setup/Config.hs | 12 ++++- .../src/Distribution/Client/GlobalFlags.hs | 1 + 3 files changed, 43 insertions(+), 15 deletions(-) diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index e7709078b65..c0d0404f4bc 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -37,11 +36,11 @@ import Distribution.Utils.Path -- Base import System.Directory (createDirectoryIfMissing, doesFileExist) -import qualified System.FilePath as FilePath #ifdef mingw32_HOST_OS import System.FilePath (normalise, splitDrive) #endif import Distribution.Compat.Directory (makeAbsolute) +import qualified System.FilePath as FilePath runConfigureScript :: ConfigFlags @@ -59,29 +58,31 @@ runConfigureScript cfg flags hp = do mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg build_in = interpretSymbolicPath mbWorkDir build_dir + putStrLn $ "[runConfigureScript] commonCfg= " ++ show commonCfg let configureScriptPath = packageRoot commonCfg "configure" + + putStrLn $ "[runConfigureScript] configureScriptPath = " ++ configureScriptPath + confExists <- doesFileExist configureScriptPath unless confExists $ dieWithException verbosity (ConfigureScriptNotFound configureScriptPath) + configureFile <- toUnix <$> makeAbsolute configureScriptPath + putStrLn $ "[runConfigureScript] configureFile = " ++ configureFile + putStrLn $ "[runConfigureScript] arg = " ++ unwords args createDirectoryIfMissing True build_in withExtraPathEnv verbosity extraPath $ withEnvOverrides verbosity envOverrides $ do logInvoke verbosity configureFile args runProgramInvocation verbosity $ - (simpleProgramInvocation configureFile args) + -- We call `sh configure` rather than `configure` because on Windows you + -- cannot run a shell script (there is no such thing as she-bang) + (simpleProgramInvocation "sh" (configureFile : args)) { progInvokeCwd = Just build_in } where - cc = foldMap ("CC=" <>) $ lookup "gcc" (configProgramPaths cfg) - cc_flags = foldMap (("CC_FLAGS=" <>) . unwords) $ lookup "gcc" (configProgramArgs cfg) - cxx = foldMap ("CXX=" <>) $ lookup "gpp" (configProgramPaths cfg) - cxx_flags = foldMap (("CXX_FLAGS=" <>) . unwords) $ lookup "gpp" (configProgramArgs cfg) - ghc = foldMap ("GHC=" <>) $ lookup "ghc" (configProgramPaths cfg) - ghc_pkg = foldMap ("GHC_PKG=" <>) $ lookup "ghc-pkg" (configProgramPaths cfg) - -- Convert a flag name to name of environment variable to represent its -- value for the configure script. flagEnvVar :: FlagName -> String @@ -103,12 +104,28 @@ runConfigureScript cfg flags hp = do , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags] )] + progEnv = + [( "CC" + , canonicalisePathSeparator <$> lookup "gcc" (configProgramPaths cfg) + ), + ( "CXX" + , canonicalisePathSeparator <$> lookup "gpp" (configProgramPaths cfg) + ), + ( "GHC" + , canonicalisePathSeparator <$> lookup "ghc" (configProgramPaths cfg) + ), + ( "GHC_PKG" + , canonicalisePathSeparator <$> lookup "ghc-pkg" (configProgramPaths cfg) + ) + ] + extraPath = fromNubList $ configProgramPathExtra cfg - envOverrides = cabalFlagMap ++ cabalFlagEnv - maybeHostFlag = ["--host=" ++ show (pretty hp) | hp /= buildPlatform] - args = configureArgs cfg ++ [cc, cc_flags, cxx, cxx_flags, ghc, ghc_pkg] ++ maybeHostFlag + envOverrides = cabalFlagMap ++ cabalFlagEnv ++ progEnv + args = + configureArgs cfg ++ ["--host=" <> prettyShow hp, "--build=" <> prettyShow buildPlatform] -- | Convert Windows path to Unix ones +-- Julian: it is incomplete toUnix :: String -> String #ifdef mingw32_HOST_OS toUnix s = let tmp = normalise s @@ -118,5 +135,5 @@ toUnix s = let tmp = normalise s parts = FilePath.splitDirectories rest in l ++ intercalate "/" parts #else -toUnix s = intercalate "/" $ FilePath.splitDirectories s +toUnix s = s #endif diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs index 78e463e8df7..fd2a341175f 100644 --- a/Cabal/src/Distribution/Simple/Setup/Config.hs +++ b/Cabal/src/Distribution/Simple/Setup/Config.hs @@ -40,6 +40,7 @@ module Distribution.Simple.Setup.Config , configureArgs , configureOptions , installDirsOptions + , canonicalisePathSeparator ) where import Distribution.Compat.Prelude hiding (get) @@ -72,6 +73,8 @@ import Distribution.Utils.Path import Distribution.Verbosity import qualified Text.PrettyPrint as Disp +import qualified System.FilePath as FP.Native +import qualified System.FilePath.Posix as FP.Posix -- ------------------------------------------------------------ @@ -1075,7 +1078,7 @@ configureArgs flags = ++ configConfigureArgs flags where optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] + Flag p -> ["--" ++ name ++ "=" ++ canonicalisePathSeparator p] NoFlag -> [] optFlag' name config_field = optFlag @@ -1084,3 +1087,10 @@ configureArgs flags = . config_field . configInstallDirs ) + +canonicalisePathSeparator :: FilePath -> FilePath +canonicalisePathSeparator = map replaceSeparator + where + replaceSeparator c + | FP.Native.isPathSeparator c = FP.Posix.pathSeparator + | otherwise = c diff --git a/cabal-install/src/Distribution/Client/GlobalFlags.hs b/cabal-install/src/Distribution/Client/GlobalFlags.hs index a1aef03a8ee..554eff9297d 100644 --- a/cabal-install/src/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/src/Distribution/Client/GlobalFlags.hs @@ -287,6 +287,7 @@ initSecureRepo -- ^ Callback -> IO a initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do + putStrLn $ "**initSecureRepo** cabalPath = " ++ show cachePath requiresBootstrap <- withRepo [] Sec.requiresBootstrap mirrors <- From 2c789b31eda36b14e52ff5345364996a9a372a9c Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 3 Feb 2026 17:19:47 +0800 Subject: [PATCH 103/122] fixup! Make sense of ./configure script invocation --- .../Distribution/Simple/ConfigureScript.hs | 29 +++++++++++++++++-- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index c0d0404f4bc..1dc5bcac510 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -30,7 +30,7 @@ import Distribution.Simple.Program import Distribution.Simple.Setup.Common import Distribution.Simple.Setup.Config import Distribution.Simple.Utils -import Distribution.System (Platform, buildPlatform) +import Distribution.System (Platform(..), OS(..), buildPlatform) import Distribution.Utils.NubList import Distribution.Utils.Path @@ -40,7 +40,6 @@ import System.Directory (createDirectoryIfMissing, doesFileExist) import System.FilePath (normalise, splitDrive) #endif import Distribution.Compat.Directory (makeAbsolute) -import qualified System.FilePath as FilePath runConfigureScript :: ConfigFlags @@ -122,7 +121,31 @@ runConfigureScript cfg flags hp = do extraPath = fromNubList $ configProgramPathExtra cfg envOverrides = cabalFlagMap ++ cabalFlagEnv ++ progEnv args = - configureArgs cfg ++ ["--host=" <> prettyShow hp, "--build=" <> prettyShow buildPlatform] + configureArgs cfg ++ ["--host=" <> platformToTriple hp, "--build=" <> platformToTriple buildPlatform] + + +platformToTriple :: Platform -> String +platformToTriple (Platform arch os) = prettyShow arch <> "-" <> fromOS os + where + fromOS Linux = "unknown-linux" + fromOS Windows = "unknown-mingw32" + fromOS OSX = "apple-darwin" + fromOS FreeBSD = "unknown-freebsd" + fromOS OpenBSD = "unknown-openbsd" + fromOS NetBSD = "unknown-netbsd" + fromOS DragonFly = "unknown-dragonflybsd" + fromOS Solaris = "sun-solaris" + fromOS AIX = "ibm-aix" + fromOS HPUX = "hp-hpux" + fromOS IRIX = "sgi-irix" + fromOS HaLVM = "unknown-halvm" + fromOS Hurd = "unknown-gnu" + fromOS IOS = "apple-ios" + fromOS Android = "unknown-linux-android" + fromOS Ghcjs = "javascript-unknown-ghcjs" + fromOS Wasi = "wasm32-unknown-wasi" + fromOS Haiku = "unknown-haiku" + fromOS (OtherOS otheros) = "unknown-" <> otheros -- | Convert Windows path to Unix ones -- Julian: it is incomplete From 1cf28208f1a7fcd6082a9eb3e88644a00b7a4feb Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 5 Feb 2026 13:41:14 +0800 Subject: [PATCH 104/122] Fix platformToTriple --- Cabal/src/Distribution/Simple/ConfigureScript.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index 1dc5bcac510..64e9352a6e3 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -142,8 +142,8 @@ platformToTriple (Platform arch os) = prettyShow arch <> "-" <> fromOS os fromOS Hurd = "unknown-gnu" fromOS IOS = "apple-ios" fromOS Android = "unknown-linux-android" - fromOS Ghcjs = "javascript-unknown-ghcjs" - fromOS Wasi = "wasm32-unknown-wasi" + fromOS Ghcjs = "unknown-ghcjs" + fromOS Wasi = "unknown-wasi" fromOS Haiku = "unknown-haiku" fromOS (OtherOS otheros) = "unknown-" <> otheros From 6a36bb75a98f07f550f73ebd4904a66627ea3d3f Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 5 Feb 2026 19:15:41 +0800 Subject: [PATCH 105/122] Revert "move log files" This reverts commit 5573deaa8a9161257cf73912f85d44a90dace28b. --- .../src/Distribution/Client/DistDirLayout.hs | 5 ++--- .../Client/ProjectBuilding/UnpackedPackage.hs | 21 ++++++++++++------- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 53010b72b69..4bc2a151aef 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -22,7 +22,6 @@ module Distribution.Client.DistDirLayout , CabalDirLayout (..) , mkCabalDirLayout , defaultCabalDirLayout - , betterPlatform ) where import Distribution.Client.Compat.Prelude @@ -41,10 +40,10 @@ import Distribution.Package , UnitId ) import Distribution.Simple.Compiler - ( Compiler(..) - , PackageDBCWD + ( PackageDBCWD , PackageDBX (..) ) +import Distribution.Simple.Compiler (Compiler(..)) import qualified Data.Map as Map -- | Information which can be used to construct the path to diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 89ed54d10c2..d2b7b739406 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -341,7 +341,13 @@ buildAndRegisterUnpackedPackage -> IO () setup cmd getCommonFlags flags args = withLogging $ \mLogFileHandle -> do - let opts = scriptOptions{useLoggingHandle = mLogFileHandle} + let opts = scriptOptions { useLoggingHandle = mLogFileHandle } + info verbosity $ + "Running setup command: " + ++ unwords + ( "useExtraPathEnv" + : useExtraPathEnv opts + ) setupWrapper verbosity opts @@ -408,7 +414,7 @@ buildAndInstallUnpackedPackage verbosity distDirLayout maybe_semaphore - buildSettings@BuildTimeSettings{buildSettingNumJobs} + buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock pkgshared @@ -500,6 +506,8 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg + Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain pkg + dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component @@ -522,12 +530,9 @@ buildAndInstallUnpackedPackage mlogFile :: Maybe FilePath mlogFile = - Just - $ distDirectory distDirLayout - "logs" - prettyShow (elabStage pkg) - betterPlatform (elabToolchain pkg) - prettyShow (elabUnitId pkg) + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid) initLogFile :: IO () initLogFile = From 23b685d0eb24c6b2688f403578fe45447919b355 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 5 Feb 2026 19:17:16 +0800 Subject: [PATCH 106/122] Revert "improve logging" This reverts commit 7c1cd1094745678c901e1122af1054f58d921823. --- Cabal/src/Distribution/Simple/Program.hs | 12 +-- Cabal/src/Distribution/Simple/Utils.hs | 100 ++++-------------- .../src/Distribution/Client/SetupWrapper.hs | 67 +++++++----- .../src/Distribution/Client/Utils.hs | 58 ++++++++-- 4 files changed, 114 insertions(+), 123 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index ee7db75079f..eb18de973f6 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -130,7 +130,6 @@ module Distribution.Simple.Program , hpcProgram , runProgramWithResponseFile , runProgramCwdWithResponseFile - , logInvoke ) where import Distribution.Compat.Prelude @@ -254,7 +253,7 @@ getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = runProgramWithResponseFile :: Verbosity -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () runProgramWithResponseFile verbosity prog args1 args2 = do - logInvoke verbosity (programPath prog) (args1 ++ args2) + infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> runProgram verbosity prog $ args1 ++ ['@' : path] where @@ -262,15 +261,8 @@ runProgramWithResponseFile verbosity prog args1 args2 = do runProgramCwdWithResponseFile :: Verbosity -> Maybe (SymbolicPath CWD (Dir to)) -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () runProgramCwdWithResponseFile verbosity mbWorkDir prog args1 args2 = do - logInvoke verbosity (programPath prog) (args1 ++ args2) + infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> runProgramCwd verbosity mbWorkDir prog $ args1 ++ ['@' : path] where rfName = programId prog ++ ".rsp" - --- | Log the invocation of a program --- This is defined here to provide a common styling for all invocations --- throughout Cabal. -logInvoke :: Verbosity -> FilePath -> [String] -> IO () -logInvoke verbosity path args = - infoNoWrap verbosity $ unwords ("Running:" : path : args) \ No newline at end of file diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index cb98cb48fce..204f3b1dac7 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -136,9 +136,6 @@ module Distribution.Simple.Utils -- * environment variables , isInSearchPath , addLibraryPath - , withEnv - , withEnvOverrides - , withExtraPathEnv -- * modification time , moreRecentFile @@ -212,7 +209,6 @@ module Distribution.Simple.Utils import Distribution.Compat.Async (waitCatch, withAsyncNF) import Distribution.Compat.CopyFile -import Distribution.Compat.Environment import Distribution.Compat.FilePath as FilePath import Distribution.Compat.Internal.TempFile import Distribution.Compat.Lens (Lens', over) @@ -308,7 +304,6 @@ import GitHash , tGitInfoCwdTry ) #endif -import Control.Monad (zipWithM_) #if MIN_VERSION_base(4,21,0) import Control.Exception.Context @@ -918,6 +913,23 @@ maybeExit cmd = do exitcode <- cmd unless (exitcode == ExitSuccess) $ exitWith exitcode +-- | Log a command execution (that's typically about to happen) +-- at info level, and log working directory and environment overrides +-- at debug level if specified. +logCommand :: Verbosity -> Process.CreateProcess -> IO () +logCommand verbosity cp = do + infoNoWrap verbosity $ + "Running: " <> case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path args -> Process.showCommandForUser path args + case Process.env cp of + Just env -> debugNoWrap verbosity $ "with environment: " ++ show env + Nothing -> return () + case Process.cwd cp of + Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd + Nothing -> return () + hFlush stdout + -- | Execute the given command with the given arguments, exiting -- with the same exit code if the command fails. rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO () @@ -968,6 +980,7 @@ rawSystemProcAction -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) -> IO (ExitCode, a) rawSystemProcAction verbosity cp action = withFrozenCallStack $ do + logCommand verbosity cp (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do a <- action mStdin mStdout mStderr exitcode <- Process.waitForProcess p @@ -2059,80 +2072,3 @@ stripCommonPrefix (x : xs) (y : ys) | x == y = stripCommonPrefix xs ys | otherwise = y : ys stripCommonPrefix _ ys = ys - --- | Executes the action with an environment variable set to some --- value. --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnv :: Verbosity -> String -> String -> IO a -> IO a -withEnv verbosity k v m = do - info verbosity $ "Setting environment variable: " ++ k ++ "=" ++ v - mb_old <- lookupEnv k - setEnv k v - m `Exception.finally` setOrUnsetEnv k mb_old - --- | Executes the action with a list of environment variables and --- corresponding overrides, where --- --- * @'Just' v@ means \"set the environment variable's value to @v@\". --- * 'Nothing' means \"unset the environment variable\". --- --- Warning: This operation is NOT thread-safe, because current --- environment is a process-global concept. -withEnvOverrides :: Verbosity -> [(String, Maybe FilePath)] -> IO a -> IO a -withEnvOverrides verbosity overrides m = do - logExtraProgramOverrideEnv verbosity overrides - mb_olds <- traverse lookupEnv envVars - traverse_ (uncurry setOrUnsetEnv) overrides - m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds - where - envVars :: [String] - envVars = map fst overrides - -setOrUnsetEnv :: String -> Maybe String -> IO () -setOrUnsetEnv var Nothing = unsetEnv var -setOrUnsetEnv var (Just val) = setEnv var val - --- | Executes the action, increasing the PATH environment --- in some way --- --- Warning: This operation is NOT thread-safe, because the --- environment variables are a process-global concept. -withExtraPathEnv :: Verbosity -> [FilePath] -> IO a -> IO a -withExtraPathEnv verbosity paths m = do - logExtraProgramSearchPath verbosity paths - oldPathSplit <- getSearchPath - let newPath :: String - newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) - oldPath :: String - oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit - -- TODO: This is a horrible hack to work around the fact that - -- setEnv can't take empty values as an argument - mungePath p - | p == "" = "/dev/null" - | otherwise = p - setEnv "PATH" newPath - m `Exception.finally` setEnv "PATH" oldPath - -logExtraProgramSearchPath - :: Verbosity - -> [FilePath] - -> IO () -logExtraProgramSearchPath verbosity extraPaths = - info verbosity . unlines $ - "Including the following directories in PATH:" - : map ("- " ++) extraPaths - -logExtraProgramOverrideEnv - :: Verbosity - -> [(String, Maybe String)] - -> IO () -logExtraProgramOverrideEnv verbosity extraEnv = - info verbosity . unlines $ - "Including the following environment variable overrides:" - : [ "- " ++ case mbVal of - Nothing -> "unset " ++ var - Just val -> var ++ "=" ++ val - | (var, mbVal) <- extraEnv - ] diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 368a26a1e0f..b343680754d 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -78,7 +78,6 @@ import Distribution.Simple.Program , getDbProgramOutputCwd , getProgramSearchPath , ghcProgram - , logInvoke , runDbProgramCwd ) import Distribution.Simple.Program.Db @@ -537,14 +536,20 @@ setupWrapper verbosity options mpkg cmd getCommonFlags getFlags getExtraArgs = d flags extraArgs --------------------------------------------------------------- +-- ------------------------------------------------------------ + -- * Internal SetupMethod --------------------------------------------------------------- + +-- ------------------------------------------------------------ -- | Run a Setup script by directly invoking the @Cabal@ library. internalSetupMethod :: SetupRunner internalSetupMethod verbosity options bt args = do - info verbosity $ "Using internal setup method with build-type " ++ show bt + info verbosity $ + "Using internal setup method with build-type " + ++ show bt + ++ " and args:\n " + ++ unwords args -- NB: we do not set the working directory of the process here, because -- we will instead pass the -working-dir flag when invoking the Setup script. -- Note that the Setup script is guaranteed to support this flag, because @@ -553,9 +558,9 @@ internalSetupMethod verbosity options bt args = do -- In the future, it would be desirable to also stop relying on the following -- pieces of process-global state, as this would allow us to use this internal -- setup method in concurrent contexts. - withEnv verbosity "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ - withExtraPathEnv verbosity (useExtraPathEnv options) $ - withEnvOverrides verbosity (useExtraEnvOverrides options) $ + withEnv "HASKELL_DIST_DIR" (getSymbolicPath $ useDistPref options) $ + withExtraPathEnv (useExtraPathEnv options) $ + withEnvOverrides (useExtraEnvOverrides options) $ buildTypeAction bt args buildTypeAction :: BuildType -> ([String] -> IO ()) @@ -569,7 +574,7 @@ buildTypeAction Custom = error "buildTypeAction Custom" invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () invoke verbosity path args options = do - logInvoke verbosity path args + info verbosity $ unwords (path : args) case useLoggingHandle options of Nothing -> return () Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle @@ -586,10 +591,12 @@ invoke verbosity path args options = do ] ++ progOverrideEnv progDb - let loggingHandle = maybe Inherit UseHandle (useLoggingHandle options) + let loggingHandle = case useLoggingHandle options of + Nothing -> Inherit + Just hdl -> UseHandle hdl cp = (proc path args) - { Process.cwd = getSymbolicPath <$> useWorkingDir options + { Process.cwd = fmap getSymbolicPath $ useWorkingDir options , Process.env = env , Process.std_out = loggingHandle , Process.std_err = loggingHandle @@ -597,9 +604,11 @@ invoke verbosity path args options = do } maybeExit $ rawSystemProc verbosity cp --------------------------------------------------------------- +-- ------------------------------------------------------------ + -- * Self-Exec SetupMethod --------------------------------------------------------------- + +-- ------------------------------------------------------------ selfExecSetupMethod :: SetupRunner selfExecSetupMethod verbosity options bt args0 = do @@ -609,8 +618,11 @@ selfExecSetupMethod verbosity options bt args0 = do , "--" ] ++ args0 - info verbosity $ "Using self-exec internal setup method with build-type " ++ show bt - -- no need to log the command line here, invoke will do it + info verbosity $ + "Using self-exec internal setup method with build-type " + ++ show bt + ++ " and args:\n " + ++ unwords args path <- getExecutablePath invoke verbosity path args options @@ -666,8 +678,10 @@ getExternalSetupMethod -> BuildType -> IO (Version, SetupMethod, SetupScriptOptions) getExternalSetupMethod verbosity options pkg bt = do - info verbosity $ "Using external setup method with build-type " ++ show bt - debug verbosity $ "Using explicit dependencies: " ++ show (useDependenciesExclusive options) + debug verbosity $ "Using external setup method with build-type " ++ show bt + debug verbosity $ + "Using explicit dependencies: " + ++ show (useDependenciesExclusive options) createDirectoryIfMissingVerbose verbosity True $ i setupDir (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion @@ -843,12 +857,13 @@ getExternalSetupMethod verbosity options pkg bt = do let customSetupHooks = workingDir options "SetupHooks.hs" useHs <- doesFileExist customSetupHooks - unless useHs $ + unless (useHs) $ die' verbosity "Using 'build-type: Hooks' but there is no SetupHooks.hs file." copyFileVerbose verbosity customSetupHooks (i setupHooks) rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) +-- rewriteFileLBS verbosity hooksHs hooksScript updateSetupScript cabalLibVersion _ = rewriteFileLBS verbosity (i setupHs) (buildTypeScript cabalLibVersion) @@ -1067,7 +1082,9 @@ getExternalSetupMethod verbosity options pkg bt = do (compiler, progdb, options'') <- configureToolchains options' pkgDbs <- traverse (traverse (makeRelativeToDirS mbWorkDir)) (coercePackageDBStack (usePackageDB options'')) let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion - extraOpts = ["-threaded"] + (program, extraOpts) = + case compilerFlavor compiler of + _ -> (ghcProgram, ["-threaded"]) cabalDep = maybe [] @@ -1120,11 +1137,11 @@ getExternalSetupMethod verbosity options pkg bt = do ] , ghcOptExtra = extraOpts , ghcOptExtensions = toNubListR $ - [ Simple.DisableExtension Simple.ImplicitPrelude - | not (bt == Custom || any (isBasePkgId . snd) selectedDeps) - ] - -- Pass -WNoImplicitPrelude to avoid depending on base - -- when compiling a Simple Setup.hs file. + if bt == Custom || any (isBasePkgId . snd) selectedDeps + then [] + else [ Simple.DisableExtension Simple.ImplicitPrelude ] + -- Pass -WNoImplicitPrelude to avoid depending on base + -- when compiling a Simple Setup.hs file. , ghcOptExtensionMap = Map.fromList . Simple.compilerExtensions $ compiler } let ghcCmdLine = renderGhcOptions compiler platform ghcOptions @@ -1132,7 +1149,7 @@ getExternalSetupMethod verbosity options pkg bt = do rewriteFileEx verbosity (i cppMacrosFile) $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps) case useLoggingHandle options of - Nothing -> runDbProgramCwd verbosity mbWorkDir ghcProgram progdb ghcCmdLine + Nothing -> runDbProgramCwd verbosity mbWorkDir program progdb ghcCmdLine -- If build logging is enabled, redirect compiler output to -- the log file. Just logHandle -> do @@ -1140,7 +1157,7 @@ getExternalSetupMethod verbosity options pkg bt = do getDbProgramOutputCwd verbosity mbWorkDir - ghcProgram + program progdb ghcCmdLine hPutStr logHandle output diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs index 128c76ec221..8c1979e3cb7 100644 --- a/cabal-install/src/Distribution/Client/Utils.hs +++ b/cabal-install/src/Distribution/Client/Utils.hs @@ -124,12 +124,6 @@ import qualified System.IO.Error as IOError import qualified Data.Set as Set import Distribution.Simple.PackageDescription (readGenericPackageDescription) import Distribution.Types.GenericPackageDescription (GenericPackageDescription) -import Distribution.Simple.Program.Find (logExtraProgramSearchPath, logExtraProgramOverrideEnv) -import Distribution.Simple.Utils - ( withEnv - , withEnvOverrides - , withExtraPathEnv - ) -- | 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] @@ -181,6 +175,58 @@ withTempFileName tmpDir template action = (\(name, _) -> removeExistingFile name) (\(name, h) -> hClose h >> action name) +-- | Executes the action with an environment variable set to some +-- value. +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnv :: String -> String -> IO a -> IO a +withEnv k v m = do + mb_old <- lookupEnv k + setEnv k v + m `Exception.finally` setOrUnsetEnv k mb_old + +-- | Executes the action with a list of environment variables and +-- corresponding overrides, where +-- +-- * @'Just' v@ means \"set the environment variable's value to @v@\". +-- * 'Nothing' means \"unset the environment variable\". +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a +withEnvOverrides overrides m = do + mb_olds <- traverse lookupEnv envVars + traverse_ (uncurry setOrUnsetEnv) overrides + m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds + where + envVars :: [String] + envVars = map fst overrides + +setOrUnsetEnv :: String -> Maybe String -> IO () +setOrUnsetEnv var Nothing = unsetEnv var +setOrUnsetEnv var (Just val) = setEnv var val + +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: [FilePath] -> IO a -> IO a +withExtraPathEnv paths m = do + oldPathSplit <- getSearchPath + let newPath :: String + newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath :: String + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p + | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + -- | Log directory change in 'make' compatible syntax logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a logDirChange _ Nothing m = m From e953b1356e7460abea9cf86506c317f3b58cb7cb Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 5 Feb 2026 19:17:28 +0800 Subject: [PATCH 107/122] Revert "Improve logging for program invocations with response file" This reverts commit bd938108de8254e78352639f55dcb0c44c2a88c6. --- Cabal/src/Distribution/Simple/Program.hs | 19 ------------------- Cabal/src/Distribution/Simple/Program/Ar.hs | 19 ++++++++++++++----- Cabal/src/Distribution/Simple/Program/Ld.hs | 14 ++++++++++++-- .../Simple/Program/ResponseFile.hs | 2 +- 4 files changed, 27 insertions(+), 27 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs index eb18de973f6..0609d17c613 100644 --- a/Cabal/src/Distribution/Simple/Program.hs +++ b/Cabal/src/Distribution/Simple/Program.hs @@ -128,8 +128,6 @@ module Distribution.Simple.Program , cppProgram , pkgConfigProgram , hpcProgram - , runProgramWithResponseFile - , runProgramCwdWithResponseFile ) where import Distribution.Compat.Prelude @@ -144,7 +142,6 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Path import Distribution.Verbosity -import Distribution.Simple.Program.ResponseFile (withResponseFile) -- | Runs the given configured program. runProgram @@ -250,19 +247,3 @@ getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = Just configuredProg -> getProgramInvocationOutput verbosity $ programInvocationCwd mbWorkDir configuredProg args - -runProgramWithResponseFile :: Verbosity -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () -runProgramWithResponseFile verbosity prog args1 args2 = do - infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 - withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> - runProgram verbosity prog $ args1 ++ ['@' : path] - where - rfName = programId prog ++ ".rsp" - -runProgramCwdWithResponseFile :: Verbosity -> Maybe (SymbolicPath CWD (Dir to)) -> ConfiguredProgram -> [ProgArg] -> [String] -> IO () -runProgramCwdWithResponseFile verbosity mbWorkDir prog args1 args2 = do - infoNoWrap verbosity $ unwords $ ["Running:", programPath prog] ++ args1 ++ args2 - withResponseFile verbosity defaultTempFileOptions rfName Nothing args2 $ \path -> - runProgramCwd verbosity mbWorkDir prog $ args1 ++ ['@' : path] - where - rfName = programId prog ++ ".rsp" diff --git a/Cabal/src/Distribution/Simple/Program/Ar.hs b/Cabal/src/Distribution/Simple/Program/Ar.hs index 4fc18c6c210..2e9b432385f 100644 --- a/Cabal/src/Distribution/Simple/Program/Ar.hs +++ b/Cabal/src/Distribution/Simple/Program/Ar.hs @@ -28,8 +28,12 @@ import Distribution.Compat.CopyFile (filesEqual) import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program - ( arProgram - , requireProgram, runProgramCwdWithResponseFile + ( ProgramInvocation + , arProgram + , requireProgram + ) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile ) import Distribution.Simple.Program.Run ( multiStageProgramInvocation @@ -41,7 +45,8 @@ import Distribution.Simple.Setup.Config ( configUseResponseFiles ) import Distribution.Simple.Utils - ( dieWithLocation' + ( defaultTempFileOptions + , dieWithLocation' , withTempDirectoryCwd ) import Distribution.System @@ -135,6 +140,10 @@ createArLibArchive verbosity lbi targetPath files = do dashLSupported = arDashLSupported (compiler lbi) + invokeWithResponseFile :: FilePath -> ProgramInvocation + invokeWithResponseFile atFile = + (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile]) + if oldVersionManualOverride || responseArgumentsNotSupported then sequence_ @@ -145,8 +154,8 @@ createArLibArchive verbosity lbi targetPath files = do (initial, middle, final) (map getSymbolicPath files) ] - else - runProgramCwdWithResponseFile verbosity mbWorkDir arProg (simpleArgs ++ extraArgs) (map getSymbolicPath files) + else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ + \path -> runProgramInvocation verbosity $ invokeWithResponseFile path unless ( hostArch == Arm -- See #1537 diff --git a/Cabal/src/Distribution/Simple/Program/Ld.hs b/Cabal/src/Distribution/Simple/Program/Ld.hs index 262b68910dd..00ed5d182d7 100644 --- a/Cabal/src/Distribution/Simple/Program/Ld.hs +++ b/Cabal/src/Distribution/Simple/Program/Ld.hs @@ -24,6 +24,9 @@ import Distribution.Simple.Flag ( fromFlagOrDefault ) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) +import Distribution.Simple.Program.ResponseFile + ( withResponseFile + ) import Distribution.Simple.Program.Run ( ProgramInvocation , multiStageProgramInvocation @@ -36,6 +39,9 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Setup.Config ( configUseResponseFiles ) +import Distribution.Simple.Utils + ( defaultTempFileOptions + ) import Distribution.Utils.Path import Distribution.Verbosity ( Verbosity @@ -44,7 +50,6 @@ import Distribution.Verbosity import System.Directory ( renameFile ) -import Distribution.Simple.Program (runProgramCwdWithResponseFile) -- | Call @ld -r@ to link a bunch of object files together. combineObjectFiles @@ -78,6 +83,10 @@ combineObjectFiles verbosity lbi ldProg target files = do middle = ld middleArgs final = ld finalArgs + invokeWithResponseFile :: FilePath -> ProgramInvocation + invokeWithResponseFile atFile = + ld $ simpleArgs ++ ['@' : atFile] + oldVersionManualOverride = fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi -- Whether ghc's ar supports response files is a good proxy for @@ -95,6 +104,7 @@ combineObjectFiles verbosity lbi ldProg target files = do if oldVersionManualOverride || responseArgumentsNotSupported then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files) - else runProgramCwdWithResponseFile verbosity (mbWorkDirLBI lbi) ldProg simpleArgs (map getSymbolicPath files) + else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $ + \path -> runProgramInvocation verbosity $ invokeWithResponseFile path where tmpfile = target <.> "tmp" -- perhaps should use a proper temp file diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index b392fa27833..eaf53ab5a5b 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs @@ -40,7 +40,7 @@ withResponseFile _verbosity tmpFileOpts fileNameTemplate encoding arguments f = traverse_ (hSetEncoding hf) encoding let responseContents = unlines $ - map escapeResponseFileArg + map escapeResponseFileArg $ arguments hPutStr hf responseContents hClose hf From 9b0cab4d2d80c994bb3f22adf5c6956591bec0cd Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 5 Feb 2026 19:30:28 +0800 Subject: [PATCH 108/122] Revert fixes --- .../Distribution/Simple/ConfigureScript.hs | 1 - Cabal/src/Distribution/Simple/Utils.hs | 83 +++++++++++++++++++ 2 files changed, 83 insertions(+), 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index 64e9352a6e3..f9735e4ee5c 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -73,7 +73,6 @@ runConfigureScript cfg flags hp = do createDirectoryIfMissing True build_in withExtraPathEnv verbosity extraPath $ withEnvOverrides verbosity envOverrides $ do - logInvoke verbosity configureFile args runProgramInvocation verbosity $ -- We call `sh configure` rather than `configure` because on Windows you -- cannot run a shell script (there is no such thing as she-bang) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 204f3b1dac7..8507da8c27c 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -205,6 +205,10 @@ module Distribution.Simple.Utils , isAbsoluteOnAnyPlatform , isRelativeOnAnyPlatform , exceptionWithCallStackPrefix + + , withEnv + , withEnvOverrides + , withExtraPathEnv ) where import Distribution.Compat.Async (waitCatch, withAsyncNF) @@ -237,6 +241,8 @@ import qualified Paths_Cabal (version) import Distribution.Parsec import Distribution.Pretty +import Distribution.Compat.Environment +import Control.Monad (zipWithM_) import qualified Data.ByteString.Lazy as BS import Data.Typeable @@ -2072,3 +2078,80 @@ stripCommonPrefix (x : xs) (y : ys) | x == y = stripCommonPrefix xs ys | otherwise = y : ys stripCommonPrefix _ ys = ys + +-- | Executes the action with an environment variable set to some +-- value. +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnv :: Verbosity -> String -> String -> IO a -> IO a +withEnv verbosity k v m = do + info verbosity $ "Setting environment variable: " ++ k ++ "=" ++ v + mb_old <- lookupEnv k + setEnv k v + m `Exception.finally` setOrUnsetEnv k mb_old + +-- | Executes the action with a list of environment variables and +-- corresponding overrides, where +-- +-- * @'Just' v@ means \"set the environment variable's value to @v@\". +-- * 'Nothing' means \"unset the environment variable\". +-- +-- Warning: This operation is NOT thread-safe, because current +-- environment is a process-global concept. +withEnvOverrides :: Verbosity -> [(String, Maybe FilePath)] -> IO a -> IO a +withEnvOverrides verbosity overrides m = do + logExtraProgramOverrideEnv verbosity overrides + mb_olds <- traverse lookupEnv envVars + traverse_ (uncurry setOrUnsetEnv) overrides + m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds + where + envVars :: [String] + envVars = map fst overrides + +setOrUnsetEnv :: String -> Maybe String -> IO () +setOrUnsetEnv var Nothing = unsetEnv var +setOrUnsetEnv var (Just val) = setEnv var val + +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: Verbosity -> [FilePath] -> IO a -> IO a +withExtraPathEnv verbosity paths m = do + logExtraProgramSearchPath verbosity paths + oldPathSplit <- getSearchPath + let newPath :: String + newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath :: String + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p + | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + +logExtraProgramSearchPath + :: Verbosity + -> [FilePath] + -> IO () +logExtraProgramSearchPath verbosity extraPaths = + info verbosity . unlines $ + "Including the following directories in PATH:" + : map ("- " ++) extraPaths + +logExtraProgramOverrideEnv + :: Verbosity + -> [(String, Maybe String)] + -> IO () +logExtraProgramOverrideEnv verbosity extraEnv = + info verbosity . unlines $ + "Including the following environment variable overrides:" + : [ "- " ++ case mbVal of + Nothing -> "unset " ++ var + Just val -> var ++ "=" ++ val + | (var, mbVal) <- extraEnv + ] From a3759bb7faccad25b18c65bb07b049c24fbc69cd Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 11 Feb 2026 11:39:28 +0800 Subject: [PATCH 109/122] Fix default dynlibdir --- Cabal/src/Distribution/Simple/InstallDirs.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs index 62b0edcb40f..4f8e0db4641 100644 --- a/Cabal/src/Distribution/Simple/InstallDirs.hs +++ b/Cabal/src/Distribution/Simple/InstallDirs.hs @@ -223,7 +223,7 @@ defaultInstallDirs' False _comp userInstall _hasLibs = do , bindir = "$prefix" "bin" , libdir = installLibDir , libsubdir = "$abi" "$libname" - , dynlibdir = "$abi" + , dynlibdir = installLibDir "$abi" , libexecsubdir = "$abi" "$pkgid" , flibdir = "$libdir" , libexecdir = case buildOS of From 7045a18d95bd645b2a6bee686355f6c9d86a3218 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 13 Feb 2026 17:38:31 +1000 Subject: [PATCH 110/122] Fix build on windows --- Cabal/src/Distribution/Simple/ConfigureScript.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs index f9735e4ee5c..54d58b75ac2 100644 --- a/Cabal/src/Distribution/Simple/ConfigureScript.hs +++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs @@ -38,6 +38,7 @@ import Distribution.Utils.Path import System.Directory (createDirectoryIfMissing, doesFileExist) #ifdef mingw32_HOST_OS import System.FilePath (normalise, splitDrive) +import qualified System.FilePath as FilePath #endif import Distribution.Compat.Directory (makeAbsolute) From 935788c449ed3e0c38ec82ab03a6479dc1b20d55 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Wed, 28 Jan 2026 18:25:22 +0800 Subject: [PATCH 111/122] move log files --- .../src/Distribution/Client/DistDirLayout.hs | 5 +++-- .../Client/ProjectBuilding/UnpackedPackage.hs | 21 +++++++------------ 2 files changed, 11 insertions(+), 15 deletions(-) diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 4bc2a151aef..53010b72b69 100644 --- a/cabal-install/src/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs @@ -22,6 +22,7 @@ module Distribution.Client.DistDirLayout , CabalDirLayout (..) , mkCabalDirLayout , defaultCabalDirLayout + , betterPlatform ) where import Distribution.Client.Compat.Prelude @@ -40,10 +41,10 @@ import Distribution.Package , UnitId ) import Distribution.Simple.Compiler - ( PackageDBCWD + ( Compiler(..) + , PackageDBCWD , PackageDBX (..) ) -import Distribution.Simple.Compiler (Compiler(..)) import qualified Data.Map as Map -- | Information which can be used to construct the path to diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index d2b7b739406..89ed54d10c2 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -341,13 +341,7 @@ buildAndRegisterUnpackedPackage -> IO () setup cmd getCommonFlags flags args = withLogging $ \mLogFileHandle -> do - let opts = scriptOptions { useLoggingHandle = mLogFileHandle } - info verbosity $ - "Running setup command: " - ++ unwords - ( "useExtraPathEnv" - : useExtraPathEnv opts - ) + let opts = scriptOptions{useLoggingHandle = mLogFileHandle} setupWrapper verbosity opts @@ -414,7 +408,7 @@ buildAndInstallUnpackedPackage verbosity distDirLayout maybe_semaphore - buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} + buildSettings@BuildTimeSettings{buildSettingNumJobs} registerLock cacheLock pkgshared @@ -506,8 +500,6 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg - Toolchain{toolchainCompiler, toolchainPlatform} = elabToolchain pkg - dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component @@ -530,9 +522,12 @@ buildAndInstallUnpackedPackage mlogFile :: Maybe FilePath mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile toolchainCompiler toolchainPlatform pkgid uid) + Just + $ distDirectory distDirLayout + "logs" + prettyShow (elabStage pkg) + betterPlatform (elabToolchain pkg) + prettyShow (elabUnitId pkg) initLogFile :: IO () initLogFile = From fdedd1e774ade8aabd7c84914f847faa48f23795 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 18 Feb 2026 17:54:47 +0800 Subject: [PATCH 112/122] Fix FreeBSD build failure after log file disambiguation --- .../Client/ProjectBuilding/UnpackedPackage.hs | 29 ++++++++++++++----- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index 89ed54d10c2..ba3cfc8f86d 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -408,7 +408,7 @@ buildAndInstallUnpackedPackage verbosity distDirLayout maybe_semaphore - buildSettings@BuildTimeSettings{buildSettingNumJobs} + buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock pkgshared @@ -522,12 +522,27 @@ buildAndInstallUnpackedPackage mlogFile :: Maybe FilePath mlogFile = - Just - $ distDirectory distDirLayout - "logs" - prettyShow (elabStage pkg) - betterPlatform (elabToolchain pkg) - prettyShow (elabUnitId pkg) + case buildSettingLogFile of + Nothing -> Nothing + -- TODO: we ignore mkLogFile, because that would require us to fix the templating + -- and add support for '$stage'. Part of the templating is in Cabal (the library), + -- so doing that properly might require some refactoring and careful thought. + -- + -- It also means we introduce a regression here and the user can't really overwrite + -- the log destination anymore. + -- + -- Last but not least, removing the @Nothing -> Nothing@ case would trigger a bug on + -- FreeBSD, because 'getSetupMethod' would always pick the 'SelfExecMethod', which + -- then on FreeBSD would try to execute @_build/cabal/bin/cabal@ and fail, because + -- it just changed the CWD to a source directory. This needs further investigation. + -- + -- An alternative patch was constructed here: https://github.com/stable-haskell/cabal/commit/604cab98c9a599953c7d95e4f37af449d5357577 + Just _ -> Just + $ distDirectory distDirLayout + "logs" + prettyShow (elabStage pkg) + betterPlatform (elabToolchain pkg) + prettyShow (elabUnitId pkg) initLogFile :: IO () initLogFile = From f6be0e0ff45bc546b6397adbb1ece1c36c4b890d Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 23 Feb 2026 17:19:39 +0800 Subject: [PATCH 113/122] Reinstate file monitor tracking for installed packages Restore the file monitor mechanism to track already-built packages, using the same approach previously established for in-place builds. This also replaces `phaseImprovePlan`, which improved the elaborated plan by matching source packages against installed store entries. Key changes: - Restore file monitor updates in `buildAndInstallUnpackedPackage`: source files, inplace dependency build cache files, and registration - Simplify `BuildStatusBuild` by dropping the `Maybe InstalledPackageInfo` field, which is now tracked via the registration file monitor instead - Simplify `checkPackageFileMonitorChanged` accordingly - Remove `phaseImprovePlan` and store entry matching from the plan rebuild phase; `rebuildInstallPlan` now returns a 4-tuple instead of 5 --- .../src/Distribution/Client/CmdFreeze.hs | 2 +- .../src/Distribution/Client/CmdGenBounds.hs | 2 +- .../src/Distribution/Client/CmdTarget.hs | 2 +- .../Distribution/Client/ProjectBuilding.hs | 43 ++++-- .../ProjectBuilding/PackageFileMonitor.hs | 76 +++++----- .../Client/ProjectBuilding/Types.hs | 9 +- .../Client/ProjectBuilding/UnpackedPackage.hs | 141 ++++++++++++++---- .../Client/ProjectOrchestration.hs | 12 +- .../Distribution/Client/ProjectPlanning.hs | 67 +-------- .../Client/ProjectPlanning/Types.hs | 33 ++++ cabal-install/tests/IntegrationTests2.hs | 2 +- 11 files changed, 234 insertions(+), 155 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index cd0c562c73d..946790e906c 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -137,7 +137,7 @@ freezeAction flags extraArgs globalFlags = do } <- establishProjectBaseContext verbosity cliConfig OtherCommand - (_, elaboratedPlan, _, totalIndexState, activeRepos) <- + (elaboratedPlan, _, totalIndexState, activeRepos) <- rebuildInstallPlan verbosity distDirLayout diff --git a/cabal-install/src/Distribution/Client/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 06f07fdff18..73eee567760 100644 --- a/cabal-install/src/Distribution/Client/CmdGenBounds.hs +++ b/cabal-install/src/Distribution/Client/CmdGenBounds.hs @@ -95,7 +95,7 @@ genBoundsAction flags targetStrings globalFlags = let ProjectBaseContext{distDirLayout, projectConfig, localPackages} = baseCtx -- Step 1: Create the install plan for the project. - (_, elaboratedPlan, _, _, _) <- + (elaboratedPlan, _, _, _) <- rebuildInstallPlan verbosity distDirLayout diff --git a/cabal-install/src/Distribution/Client/CmdTarget.hs b/cabal-install/src/Distribution/Client/CmdTarget.hs index 943c285d3e8..b1b6918366c 100644 --- a/cabal-install/src/Distribution/Client/CmdTarget.hs +++ b/cabal-install/src/Distribution/Client/CmdTarget.hs @@ -156,7 +156,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do } <- establishProjectBaseContext verbosity cliConfig OtherCommand - (_, elaboratedPlan, _, _, _) <- + (elaboratedPlan, _, _, _) <- rebuildInstallPlan verbosity distDirLayout diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 9b50f568bc4..a64c5500ec4 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -205,8 +205,13 @@ rebuildTargetsDryRun distDirLayout = -> [BuildStatus] -> FilePath -> IO BuildStatus - dryRunTarballPkg _pkg _depsBuildStatus tarball = - return (BuildStatusUnpack tarball) + dryRunTarballPkg pkg depsBuildStatus tarball = do + exists <- doesDirectoryExist srcdir + if exists + then dryRunLocalPkg pkg depsBuildStatus srcdir + else return (BuildStatusUnpack tarball) + where + srcdir = distUnpackedSrcDirectory distDirLayout (packageId pkg) dryRunLocalPkg :: ElaboratedConfiguredPackage @@ -216,18 +221,30 @@ rebuildTargetsDryRun distDirLayout = dryRunLocalPkg pkg depsBuildStatus srcdir = do -- Go and do lots of I/O, reading caches and probing files to work out -- if anything has changed + change <- checkPackageFileMonitorChanged packageFileMonitor pkg srcdir depsBuildStatus + case change of -- It did change, giving us 'BuildStatusRebuild' info on why - Left rebuild -> + Left rebuild -> do + putStrLn $ + "Package " + ++ prettyShow (packageId pkg) + ++ " needs to be rebuilt because: " + ++ show rebuild return (BuildStatusRebuild srcdir rebuild) -- No changes, the package is up to date. Use the saved build results. - Right buildResult -> + Right buildResult -> do + putStrLn $ + "Package " + ++ prettyShow (packageId pkg) + ++ " is up to date with build result: " + ++ show buildResult return (BuildStatusUpToDate buildResult) where packageFileMonitor :: PackageFileMonitor @@ -352,6 +369,7 @@ rebuildTargets downloadMap registerLock cacheLock + installPlan sharedPackageConfig pkg pkgBuildStatus @@ -490,6 +508,7 @@ rebuildTarget -> AsyncFetchMap -> Lock -> Lock + -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> ElaboratedReadyPackage -> BuildStatus @@ -502,6 +521,7 @@ rebuildTarget downloadMap registerLock cacheLock + installPlan sharedPackageConfig rpkg@(ReadyPackage pkg) pkgBuildStatus @@ -556,12 +576,12 @@ rebuildTarget rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult rebuildPhase buildStatus srcdir = do info verbosity $ "[rebuildPhase] Rebuilding " ++ prettyShow (nodeKey pkg) ++ " in " ++ prettyShow srcdir ++ " with rebuild reason " ++ show buildStatus - buildAndInstall srcdir (makeSymbolicPath builddir) + buildAndInstall buildStatus srcdir (makeSymbolicPath builddir) where builddir = distBuildDirectory (elabDistDirParams pkg) - buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult - buildAndInstall srcdir builddir = do + buildAndInstall :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult + buildAndInstall buildStatus srcdir builddir = do info verbosity $ "[buildAndInstall] Building and installing " ++ prettyShow (nodeKey pkg) buildAndInstallUnpackedPackage verbosity @@ -570,8 +590,10 @@ rebuildTarget buildSettings registerLock cacheLock + installPlan sharedPackageConfig rpkg + buildStatus srcdir builddir @@ -669,7 +691,8 @@ withTarballLocalDirectory -> PackageId -> DistDirParams -> Maybe CabalFileText - -> ( SymbolicPath CWD (Dir Pkg) -- Source directory + -> ( BuildStatusRebuild + -> SymbolicPath CWD (Dir Pkg) -- Source directory -> SymbolicPath Pkg (Dir Dist) -- Build directory -> IO a ) @@ -697,7 +720,9 @@ withTarballLocalDirectory srcrootdir pkgid dparams - buildPkg (makeSymbolicPath srcdir) builddir + + -- FIXME: boh? + buildPkg (BuildStatusConfigure MonitorFirstRun) (makeSymbolicPath srcdir) builddir where srcrootdir = distUnpackedSrcRootDirectory distDirLayout srcdir = distUnpackedSrcDirectory distDirLayout pkgid diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs index 9b99f422021..ec50e3d0ff0 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs @@ -157,59 +157,53 @@ checkPackageFileMonitorChanged -- so depsBuildStatus is just needed for the changes in the content -- of dependencies. | any buildStatusRequiresBuild depsBuildStatus -> do - regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) + return (Left (BuildStatusBuild BuildReasonDepsRebuilt)) | otherwise -> do buildChanged <- checkFileMonitorChanged pkgFileMonitorBuild srcdir buildComponents - regChanged <- - checkFileMonitorChanged - pkgFileMonitorReg - srcdir - () - let mreg = changedToMaybe regChanged - case (buildChanged, regChanged) of - (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> - return (Left (BuildStatusBuild mreg buildReason)) + case buildChanged of + MonitorChanged (MonitoredValueChanged prevBuildComponents) -> + return (Left (BuildStatusBuild buildReason)) where buildReason = BuildReasonExtraTargets prevBuildComponents - (MonitorChanged monitorReason, _) -> - return (Left (BuildStatusBuild mreg buildReason)) + MonitorChanged monitorReason -> + return (Left (BuildStatusBuild buildReason)) where buildReason = BuildReasonFilesChanged monitorReason' monitorReason' = fmap (const ()) monitorReason - (MonitorUnchanged _ _, MonitorChanged monitorReason) -> - -- this should only happen if the file is corrupt or been - -- manually deleted. We don't want to bother with another - -- phase just for this, so we'll reregister by doing a build. - return (Left (BuildStatusBuild Nothing buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - (MonitorUnchanged _ _, MonitorUnchanged _ _) - | pkgHasEphemeralBuildTargets pkg -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonEphemeralTargets - (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> - return $ - Right - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = Nothing - } - where - (docsResult, testsResult) = buildResult + MonitorUnchanged (docsResult, testsResult) _ -> + if elabRequiresRegistration pkg then do + regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () + case regChanged of + MonitorChanged monitorReason -> + -- this should only happen if the file is corrupt or been + -- manually deleted. We don't want to bother with another + -- phase just for this, so we'll reregister by doing a build. + return (Left (BuildStatusBuild (BuildReasonFilesChanged monitorReason))) + MonitorUnchanged _ _ + | pkgHasEphemeralBuildTargets pkg -> + return (Left (BuildStatusBuild BuildReasonEphemeralTargets)) + | otherwise -> + return $ + Right + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } + else + return $ + Right + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } where (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - changedToMaybe :: MonitorChanged a b -> Maybe b - changedToMaybe (MonitorChanged _) = Nothing - changedToMaybe (MonitorUnchanged x _) = Just x updatePackageConfigFileMonitor :: PackageFileMonitor @@ -266,7 +260,7 @@ updatePackageBuildFileMonitor -- that it's /only/ the value that changed not any files that changed. buildComponents' = case pkgBuildStatus of - BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) -> + BuildStatusBuild (BuildReasonExtraTargets prevBuildComponents) -> buildComponents `Set.union` prevBuildComponents _ -> buildComponents diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs index 148dbb1e759..3fa85ade318 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -27,7 +27,6 @@ import Distribution.Client.Types (DocsResult, TestsResult) import Distribution.Client.ProjectPlanning.Types (ElaboratedConfiguredPackage, ElaboratedPlanPackage) import qualified Distribution.Compat.Graph as Graph -import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -73,6 +72,7 @@ data BuildStatus -- So this package can be put into the 'InstallPlan.Installed' state -- and it does not need to be built. BuildStatusUpToDate BuildResult + deriving (Show) -- | Which 'BuildStatus' values indicate we'll have to do some build work of -- some sort. In particular we use this as part of checking if any of a @@ -103,12 +103,7 @@ data BuildStatusRebuild BuildStatusConfigure (MonitorChangedReason ()) | -- | The configuration has not changed but the build phase needs to be -- rerun. We record the reason the (re)build is needed. - -- - -- The optional registration info here tells us if we've registered the - -- package already, or if we still need to do that after building. - -- @Just Nothing@ indicates that we know that no registration is - -- necessary (e.g., executable.) - BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason + BuildStatusBuild BuildReason deriving (Show) data BuildReason diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index ba3cfc8f86d..845e5efbbd3 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -79,7 +79,7 @@ import Distribution.Version import qualified Data.ByteString as BS import qualified Data.List.NonEmpty as NE -import Control.Exception (Handler (..), SomeAsyncException, catches) +import Control.Exception (Handler (..), SomeAsyncException, catches, onException) import System.Directory (canonicalizePath, createDirectoryIfMissing, doesFileExist, removeFile) import System.FilePath (takeDirectory, ()) import System.IO (Handle, IOMode (AppendMode), withFile) @@ -89,6 +89,13 @@ import System.Semaphore (SemaphoreName (..)) import Distribution.Client.Errors import qualified Distribution.Compat.Graph as Graph +import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.PackageDescription (BuildType(..)) +import qualified Distribution.PackageDescription as PD +import Distribution.Client.FileMonitor (monitorFileHashed, beginUpdateFileMonitor) +import Distribution.Client.SourceFiles (needElaboratedConfiguredPackage) +import Distribution.Client.SrcDist (allPackageSourceFiles) +import Distribution.Client.RebuildMonad (execRebuild) -- | Each unpacked package is processed in the following phases: -- @@ -399,8 +406,10 @@ buildAndInstallUnpackedPackage -> BuildTimeSettings -> Lock -> Lock + -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> ElaboratedReadyPackage + -> BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult @@ -411,11 +420,14 @@ buildAndInstallUnpackedPackage buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock + plan pkgshared rpkg@(ReadyPackage pkg) + buildStatus srcdir builddir = do createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPath (Just srcdir) builddir) + createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory distDirLayout dparams) -- TODO: [code cleanup] deal consistently with talking to older -- Setup.hs versions, much like we do for ghc, with a proper @@ -430,6 +442,11 @@ buildAndInstallUnpackedPackage initLogFile + let docsResult = DocsNotTried + testsResult = TestsNotTried + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + buildAndRegisterUnpackedPackage verbosity distDirLayout @@ -444,35 +461,90 @@ buildAndInstallUnpackedPackage mlogFile $ \case PBConfigurePhase{runConfigure} -> do - noticeProgress ProgressStarting - runConfigure + whenReconfigure $ do + noticeProgress ProgressStarting + runConfigure + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor (getSymbolicPath srcdir) pkg PBBuildPhase{runBuild} -> do - noticeProgress ProgressBuilding - runBuild + whenRebuild $ do + noticeProgress ProgressBuilding + timestamp <- beginUpdateFileMonitor + runBuild + -- Be sure to invalidate the cache if building throws an exception! + -- If not, we'll abort execution with a stale recompilation cache. + -- See ghc#24926 for an example of how this can go wrong. + `onException` invalidatePackageRegFileMonitor packageFileMonitor + + let listSimple = + execRebuild (getSymbolicPath srcdir) (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity (getSymbolicPath srcdir) + ifNullThen m m' = do + xs <- m + if null xs then m' else return xs + + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ + | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + listSdist `ifNullThen` listSimple + | otherwise -> + listSimple + + let dep_monitors = + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + plan + pkg + + updatePackageBuildFileMonitor + packageFileMonitor + (getSymbolicPath srcdir) + timestamp + pkg + buildStatus + (monitors ++ dep_monitors) + buildResult + PBHaddockPhase{runHaddock} -> do noticeProgress ProgressHaddock runHaddock PBInstallPhase{runCopy, runRegister} -> do - noticeProgress ProgressInstalling - - runCopy (Cabal.CopyToDb (elabRegistrationPackageDb pkg)) - - if elabRequiresRegistration pkg then - void $ runRegister - (elabRegisterPackageDBStack pkg) - Cabal.defaultRegisterOptions - { Cabal.registerMultiInstance = True - , Cabal.registerSuppressFilesCheck = True - } - else - info verbosity $ "registerPkg: elab does NOT require registration for " ++ prettyShow uid - - -- No tests on install - PBTestPhase{} -> return () - -- No bench on install - PBBenchPhase{} -> return () - -- No repl on install - PBReplPhase{} -> return () + -- NOTE: We re-copy and re-register if we rebuild. It seems to make sense. + whenRebuild $ do + noticeProgress ProgressInstalling + + runCopy (Cabal.CopyToDb (elabRegistrationPackageDb pkg)) + + if elabRequiresRegistration pkg then do + ipi <- runRegister + (elabRegisterPackageDBStack pkg) + Cabal.defaultRegisterOptions + { Cabal.registerMultiInstance = True + , Cabal.registerSuppressFilesCheck = True + } + updatePackageRegFileMonitor packageFileMonitor (getSymbolicPath srcdir) (Just ipi) + else + info verbosity $ "registerPkg: elab does NOT require registration for " ++ prettyShow uid + + PBTestPhase{runTest} -> runTest + PBBenchPhase{runBench} -> runBench + PBReplPhase{runRepl} -> runRepl -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right -- thing. Although we do copy into an image dir and do the move into the @@ -484,10 +556,6 @@ buildAndInstallUnpackedPackage -- 'withWin32SelfUpgrade' dance, but it would be necessary for a -- shared bin dir. - -- TODO: [required feature] docs and test phases - let docsResult = DocsNotTried - testsResult = TestsNotTried - noticeProgress ProgressCompleted return @@ -500,6 +568,21 @@ buildAndInstallUnpackedPackage uid = installedUnitId rpkg pkgid = packageId rpkg + dparams = elabDistDirParams pkg + packageFileMonitor = newPackageFileMonitor distDirLayout dparams + + whenReconfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + , -- NB: we have to build the test/bench suite! + null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = + return () + | otherwise = action + dispname :: String dispname = case elabPkgOrComp pkg of -- Packages built altogether, instead of per component diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index d1bf91be6f9..69f85429863 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -189,14 +189,13 @@ import Distribution.Simple.PackageIndex (InstalledPackageIndex) import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose - , debugNoWrap , dieWithException , infoNoWrap , installExecutableFile , notice , noticeNoWrap , ordNub - , warn + , warn, info ) import Distribution.Types.Flag ( FlagAssignment @@ -353,7 +352,7 @@ withInstallPlan -- everything in the project. This is independent of any specific targets -- the user has asked for. -- - (elaboratedPlan, _, elaboratedShared, _, _) <- + (elaboratedPlan, elaboratedShared, _, _) <- rebuildInstallPlan verbosity distDirLayout @@ -380,7 +379,7 @@ runProjectPreBuildPhase -- everything in the project. This is independent of any specific targets -- the user has asked for. -- - (elaboratedPlan, _, elaboratedShared, _, _) <- + (elaboratedPlan, elaboratedShared, _, _) <- rebuildInstallPlan verbosity distDirLayout @@ -409,7 +408,8 @@ runProjectPreBuildPhase improveInstallPlanWithUpToDatePackages pkgsBuildStatus elaboratedPlan' - debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + + info verbosity (InstallPlan.showInstallPlan elaboratedPlan'') return ProjectBuildContext @@ -1249,7 +1249,7 @@ printPlan BuildStatusConfigure (MonitoredValueChanged _) -> "configuration changed" BuildStatusConfigure mreason -> showMonitorChangedReason mreason - BuildStatusBuild _ buildreason -> case buildreason of + BuildStatusBuild buildreason -> case buildreason of BuildReasonDepsRebuilt -> "dependency rebuilt" BuildReasonFilesChanged mreason -> showMonitorChangedReason mreason diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index d046b476660..bb7f8672c89 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -146,7 +146,6 @@ import Distribution.Client.ProjectPlanning.Types as Ty 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.Toolchain import Distribution.Client.Types @@ -161,10 +160,6 @@ import Distribution.CabalSpecVersion import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum import Distribution.Utils.NubList -import Distribution.Utils.Path hiding - ( (<.>) - , () - ) import qualified Hackage.Security.Client as Sec @@ -638,8 +633,7 @@ rebuildInstallPlan -> [PackageSpecifier UnresolvedSourcePackage] -> Maybe InstalledPackageIndex -> IO - ( ElaboratedInstallPlan -- with store packages - , ElaboratedInstallPlan -- with source packages + ( ElaboratedInstallPlan , ElaboratedSharedConfig , IndexUtils.TotalIndexState , IndexUtils.ActiveRepos @@ -695,17 +689,7 @@ rebuildInstallPlan phaseMaintainPlanOutputs elaboratedPlan elaboratedShared return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) - -- \| Given the 'InstalledPackageIndex' for a nix-style package store, and an - -- 'ElaboratedInstallPlan', replace configured source packages by installed - -- packages from the store whenever they exist. - -- - -- The improved plan changes each time we install something, whereas - -- the underlying elaborated plan only changes when input config - -- changes, so it's worth caching them separately. - improvedPlan <- phaseImprovePlan elaboratedPlan - liftIO $ info verbosity (render (text "Improved install plan:" $$ text (showElaboratedInstallPlan improvedPlan))) - - return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) + return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) where fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan" fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes" @@ -961,41 +945,6 @@ rebuildInstallPlan elaboratedPlan elaboratedShared - -- Improve the elaborated install plan. The elaborated plan consists - -- mostly of source packages (with full nix-style hashed ids). Where - -- corresponding installed packages already exist in the store, replace - -- them in the plan. - -- - -- Note that we do monitor the store's package db here, so we will redo - -- this improvement phase when the db changes -- including as a result of - -- executing a plan and installing things. - -- - phaseImprovePlan - :: ElaboratedInstallPlan - -> Rebuild ElaboratedInstallPlan - phaseImprovePlan elaboratedPlan = liftIO $ do - info verbosity "Improving the install plan using the package store..." - InstallPlan.installedM canBeImproved elaboratedPlan - where - -- Only packages that do not depend on source packages can be cached - canBeImproved elab = do - info verbosity ("Checking if " ++ prettyShow (installedUnitId elab) ++ " is already installed...") - isPresent <- doesStoreEntryExist - distStoreDirLayout - (elabStage elab) - (elabToolchain elab) - (installedUnitId elab) - if isPresent then - if elabIsSourcePackageClosure elab then do - info verbosity (prettyShow (installedUnitId elab) ++ " is already present but I will not reuse it because it depends on source packages.") - return False - else do - info verbosity (prettyShow (installedUnitId elab) ++ " is already present and can be reused.") - return True - else do - info verbosity (prettyShow (installedUnitId elab) ++ " is not present in the store.") - return False - -- | If a 'PackageSpecifier' refers to a single package, return Just that -- package. reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO () @@ -2068,7 +2017,7 @@ elaborateInstallPlan Just e -> Ty.elabModuleShape e -- See the equivalent code in buildComponent for explanation. - pkgInstalledId = + pkgInstalledId = case elabPkgSourceHash elab of -- If we have a source hash and the package is in the project closure, -- we can use it to compute the component ID. @@ -2366,7 +2315,7 @@ elaborateInstallPlan -- -- Per-package options - -- + -- -- allPackageConfig applies to all packages -- localPackageConfig applies to all project source packages -- perPackageConfig applies to specific named packages @@ -2376,14 +2325,14 @@ elaborateInstallPlan perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f) - + perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a] perPkgOptionList pkgid f = lookupPerPkgOption pkgid f - + perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f) - + perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f) - + perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f) perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 7b0a3157381..4192c782c6b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -26,6 +26,7 @@ module Distribution.Client.ProjectPlanning.Types , elabOrderExeDependencies , elabSetupLibDependencies , elabPkgConfigDependencies + , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration , elabPlanPackageName , elabConfiguredName @@ -687,6 +688,38 @@ pkgSetupLibDependencies pkg = where stage = prevStage (pkgStage pkg) +-- | The cache files of all our inplace dependencies which, +-- when updated, require us to rebuild. See #4202 for +-- more details. Essentially, this is a list of filepaths +-- that, if our dependencies get rebuilt, will themselves +-- get updated. +-- +-- Note: the hash of these cache files gets built into +-- the build cache ourselves, which means that we end +-- up tracking transitive dependencies! +-- +-- Note: This tracks the "build" cache file, but not +-- "registration" or "config" cache files. Why not? +-- Arguably we should... +-- +-- Note: This is a bit of a hack, because it is not really +-- the hashes of the SOURCES of our (transitive) dependencies +-- that we should use to decide whether or not to rebuild, +-- but the output BUILD PRODUCTS. The strategy we use +-- here will never work if we want to implement unchanging +-- rebuilds. +elabInplaceDependencyBuildCacheFiles + :: DistDirLayout + -> ElaboratedInstallPlan + -> ElaboratedConfiguredPackage + -> [FilePath] +elabInplaceDependencyBuildCacheFiles layout plan root_elab = + go =<< InstallPlan.directDeps plan (nodeKey root_elab) + where + go = InstallPlan.foldPlanPackage (const []) $ \elab -> do + guard (elabIsSourcePackageClosure elab) + return $ distPackageCacheFile layout (elabDistDirParams elab) "build" + -- | Some extra metadata associated with an -- 'ElaboratedConfiguredPackage' which indicates that the "package" -- in question is actually a single component to be built. Arguably diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index f9395500d22..08e0d639bdd 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -2222,7 +2222,7 @@ planProject testdir cliConfig = do ) <- configureProject testdir cliConfig - (elaboratedPlan, _, elaboratedShared, _, _) <- + (elaboratedPlan, elaboratedShared, _, _) <- rebuildInstallPlan verbosity distDirLayout From 54cf64b7e37088778695cb90d3e04f9a5dd1cb76 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 24 Feb 2026 13:40:37 +0800 Subject: [PATCH 114/122] Stop stealing the vowels --- .../src/Distribution/Client/PackageHash.hs | 37 +------------------ 1 file changed, 1 insertion(+), 36 deletions(-) diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index cc5c9a8831a..1b3223953e8 100644 --- a/cabal-install/src/Distribution/Client/PackageHash.hs +++ b/cabal-install/src/Distribution/Client/PackageHash.hs @@ -79,7 +79,7 @@ import qualified Data.Set as Set hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageId | buildOS == Windows = hashedInstalledPackageIdShort - | buildOS == OSX = hashedInstalledPackageIdVeryShort + | buildOS == OSX = hashedInstalledPackageIdLong | otherwise = hashedInstalledPackageIdLong -- | Calculate a 'InstalledPackageId' for a package using our nix-style @@ -140,41 +140,6 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = | length s <= n = s | otherwise = take (n - 1) s ++ "_" --- | On macOS we shorten the name very aggressively. The mach-o linker on --- macOS has a limited load command size, to which the name of the library --- as well as its relative path (\@rpath) entry count. To circumvent this, --- on macOS the libraries are not stored as --- @store//libHS.dylib@ --- where libraryname contains the libraries name, version and abi hash, but in --- @store/lib/libHS.dylib@ --- where the very short library name drops all vowels from the package name, --- and truncates the hash to 4 bytes. --- --- We therefore we only need one \@rpath entry to @store/lib@ instead of one --- \@rpath entry for each library. And the reduced library name saves some --- additional space. --- --- This however has two major drawbacks: --- 1) Packages can collide more easily due to the shortened hash. --- 2) The libraries are *not* prefix relocatable anymore as they all end up --- in the same @store/lib@ folder. --- --- The ultimate solution would have to include generating proxy dynamic --- libraries on macOS, such that the proxy libraries and the linked libraries --- stay under the load command limit, and the recursive linker is still able --- to link all of them. -hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId -hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkComponentId $ - intercalate - "-" - [ filter (not . flip elem "aeiou") (prettyShow name) - , prettyShow version - , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) - ] - where - PackageIdentifier name version = pkgHashPkgId - -- | All the information that contributes to a package's hash, and thus its -- 'InstalledPackageId'. data PackageHashInputs = PackageHashInputs From 3c6bcbca28e69f9e02d47e14d1312405eef77914 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 24 Feb 2026 15:14:07 +0800 Subject: [PATCH 115/122] Fix caching of remote source tarballs Fixes #11511 --- cabal-install/src/Distribution/Client/ProjectConfig.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index f1d7ef32ea9..a4203f550ef 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -1520,10 +1520,10 @@ fetchAndReadSourcePackageRemoteTarball { distDownloadSrcDirectory } getTransport - tarballUri = + tarballUri = do -- The tarball download is expensive so we use another layer of file -- monitor to avoid it whenever possible. - rerunIfChanged verbosity monitor tarballUri $ do + r <- rerunIfChanged verbosity monitor tarballUri $ do -- Download transport <- getTransport liftIO $ do @@ -1537,12 +1537,13 @@ fetchAndReadSourcePackageRemoteTarball return () -- Read - monitorFiles [monitorFile tarballFile] let location = RemoteTarballPackage tarballUri tarballFile liftIO $ fmap (mkSpecificSourcePackage location) . uncurry (readSourcePackageCabalFile verbosity) =<< extractTarballPackageCabalFile tarballFile + monitorFiles [monitorFile tarballFile] + pure r where tarballStem :: FilePath tarballStem = From e1174ebfe58e83cc97b80f347e96a17d1a53f1f8 Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Sat, 28 Feb 2026 15:59:43 +0900 Subject: [PATCH 116/122] fix: serialise BuildInplaceOnly tarball extraction to prevent TOCTOU race When two stages of the same package (e.g. build: and host: in cross- compilation) are scheduled concurrently, both threads can observe the unpacked source directory as non-existent and race to extract the tarball. The second extraction overwrites the first mid-flight, corrupting the result and causing intermittent "No cabal file found" errors. Add an unpackLock (using the existing Lock/criticalSection from JobControl) to serialise the doesDirectoryExist check and tarball extraction in withTarballLocalDirectory. This is the same pattern already used for registerLock and cacheLock. --- .../Distribution/Client/ProjectBuilding.hs | 48 ++++++++++++------- 1 file changed, 31 insertions(+), 17 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index a64c5500ec4..5e308c38092 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -359,6 +359,7 @@ rebuildTargets | otherwise = do registerLock <- newLock -- serialise registration cacheLock <- newLock -- serialise access to setup exe cache + unpackLock <- newLock -- serialise tarball unpacking (avoid TOCTOU race) rebuildTargets' verbosity projectConfig distDirLayout installPlan sharedPackageConfig pkgsBuildStatus buildSettings $ \downloadMap jobControl pkg pkgBuildStatus -> rebuildTarget @@ -369,6 +370,7 @@ rebuildTargets downloadMap registerLock cacheLock + unpackLock installPlan sharedPackageConfig pkg @@ -507,7 +509,11 @@ rebuildTarget -> BuildTimeSettings -> AsyncFetchMap -> Lock + -- ^ registerLock: serialise registration -> Lock + -- ^ cacheLock: serialise access to setup exe cache + -> Lock + -- ^ unpackLock: serialise tarball unpacking -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> ElaboratedReadyPackage @@ -521,6 +527,7 @@ rebuildTarget downloadMap registerLock cacheLock + unpackLock installPlan sharedPackageConfig rpkg@(ReadyPackage pkg) @@ -567,6 +574,7 @@ rebuildTarget withTarballLocalDirectory verbosity distDirLayout + unpackLock tarball (packageId pkg) (elabDistDirParams pkg) @@ -687,6 +695,7 @@ downloadedSourceLocation pkgloc = withTarballLocalDirectory :: Verbosity -> DistDirLayout + -> Lock -> FilePath -> PackageId -> DistDirParams @@ -700,28 +709,33 @@ withTarballLocalDirectory withTarballLocalDirectory verbosity distDirLayout + unpackLock tarball pkgid dparams pkgTextOverride buildPkg = do - exists <- doesDirectoryExist srcdir - unless exists $ do - createDirectoryIfMissingVerbose verbosity True srcrootdir - unpackPackageTarball - verbosity - tarball - srcrootdir - pkgid - pkgTextOverride - moveTarballShippedDistDirectory - verbosity - distDirLayout - srcrootdir - pkgid - dparams - - -- FIXME: boh? + -- Use a lock to prevent a TOCTOU race: when two stages of the same + -- package (e.g. build: and host: in cross-compilation) are scheduled + -- concurrently, both may see the directory as non-existent and race + -- to unpack, corrupting the extraction and causing "No cabal file + -- found" errors. + criticalSection unpackLock $ do + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + unpackPackageTarball + verbosity + tarball + srcrootdir + pkgid + pkgTextOverride + moveTarballShippedDistDirectory + verbosity + distDirLayout + srcrootdir + pkgid + dparams buildPkg (BuildStatusConfigure MonitorFirstRun) (makeSymbolicPath srcdir) builddir where srcrootdir = distUnpackedSrcRootDirectory distDirLayout From 8f9daf7a0cbe34404cb96275a8c3083685fa6336 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 9 Jul 2025 12:20:35 +0800 Subject: [PATCH 117/122] Add rebase CI --- .github/scripts/rebase_local.sh | 58 +++++++++++ .github/scripts/rebase_spec.sh | 167 ++++++++++++++++++++++++++++++++ .github/workflows/rebase.yaml | 156 +++++++++++++++++++++++++++++ 3 files changed, 381 insertions(+) create mode 100644 .github/scripts/rebase_local.sh create mode 100644 .github/scripts/rebase_spec.sh create mode 100644 .github/workflows/rebase.yaml diff --git a/.github/scripts/rebase_local.sh b/.github/scripts/rebase_local.sh new file mode 100644 index 00000000000..206629b4c19 --- /dev/null +++ b/.github/scripts/rebase_local.sh @@ -0,0 +1,58 @@ +#!/bin/bash + +set -eux + +upstream_repo=$1 +# of the form [:], e.g.: +# BA:master B1:master B2:B1 B3:B2 +spec=$2 + +{ + +git remote add upstream "${upstream_repo}" || true +git fetch upstream + +output_branches=() + +# sync master with upstream +git checkout master +git reset --hard upstream/master +output_branches+=( "master" ) + +# rebase each branch +mkdir -p rebase +for branch_spec in ${spec} ; do + branch=$(echo "${branch_spec}" | awk -F ':' '{ print $1 }') + rebase_target=$(echo "${branch_spec}" | awk -F ':' '{ print $2 }') + git checkout "${branch}" + common_ancestor=$(git merge-base "${branch}" "origin/${rebase_target}") + [ -e rebase/"${branch}" ] && exit 1 + mkdir -p rebase/"${branch}" + ( + cd rebase/"${branch}" + echo "${common_ancestor}" > BASE_COMMIT + git format-patch "${common_ancestor}".."${branch}" + ) + if compgen -G rebase/"${branch}"/*.patch > /dev/null; then + git reset --hard "${rebase_target}" + git am --3way rebase/"${branch}"/*.patch + fi + output_branches+=( "${branch}" ) +done +unset branch_spec branch + +# cherry-pick on stable-master +git checkout stable-master +git reset --hard upstream/master +for branch_spec in ${spec} ; do + branch=$(echo "${branch_spec}" | awk -F ':' '{ print $1 }') + if compgen -G "rebase/${branch}"/*.patch > /dev/null; then + git am --3way "rebase/${branch}"/*.patch + fi +done +output_branches+=( "stable-master" ) + +} >&2 + +echo "${output_branches[*]}" + diff --git a/.github/scripts/rebase_spec.sh b/.github/scripts/rebase_spec.sh new file mode 100644 index 00000000000..566f3112142 --- /dev/null +++ b/.github/scripts/rebase_spec.sh @@ -0,0 +1,167 @@ +#!/bin/bash + +# Branch regex we consider for rebase targets. +# For our purposes this is usually 'stable-haskell/feature/*'. +# 'master' is always considered. +branch_regex=$1 +shift 1 +declare -a input_branches +input_branches=( "$@" ) +set -eux + +[ ${#input_branches[@]} -eq 0 ] && + input_branches=( $(gh pr list --label rebase --state open --json headRefName --jq ".[] | select( .headRefName | match(\"${branch_regex}\")) | .headRefName" --template '{{range .}}{{tablerow .headRefName}}{{end}}') ) + +branch_list=( ) +declare -A branch_map + +# @FUNCTION: die +# @USAGE: [msg] +# @DESCRIPTION: +# Exits the shell script with status code 2 +# and prints the given message in red to STDERR, if any. +die() { + (>&2 red_message "$1") + exit 2 +} + +# @FUNCTION: red_message +# @USAGE: +# @DESCRIPTION: +# Print a red message. +red_message() { + printf "\\033[0;31m%s\\033[0m\\n" "$1" +} + +# @FUNCTION: array_contains +# @USAGE: +# @DESCRIPTION: +# Checks whether the array reference contains the given value. +# @RETURN: 0 if value exists, 1 otherwise +array_contains() { + local -n arr=$1 + local val=$2 + shift 2 + if [[ " ${arr[*]} " =~ [[:space:]]${val}[[:space:]] ]]; then + return 0 + else + return 1 + fi +} + +max_backtrack=10 + +# @FUNCTION: backtrack +# @USAGE: +# @DESCRIPTION: +# Backtrack dependencies through an array list. +# E.g. given an associated array with key value pairs of: +# B1 -> M +# B2 -> B1 +# B3 -> B2 +# +# ...if we pass B3 as start_key and M as abort_value, then +# we receive the flattened ordered list "B1 B2 B3" +# @STDOUT: space separated list of backtracked values +backtrack() { + backtrack_ 0 "$1" "$2" "$3" +} + +# internal to track backtrack depth +backtrack_() { + local depth=$1 + if [[ $depth -gt $max_backtrack ]] ; then + die "Dependency backtracking too deep... aborting!" + fi + shift 1 + + if [[ $1 != map ]] ; then + local -n map=$1 + fi + + local base=$2 + local abort_value=$3 + local value + + if [ "${base}" = "${abort_value}" ] ; then + return + fi + + value=${map[$base]} + + if [ "${value}" = "${abort_value}" ] ; then + if ! array_contains branch_list "${base}" ; then + echo "${base}" + fi + else + if array_contains branch_list "${base}" ; then + backtrack_ $((depth++)) map "${map[$value]}" "${abort_value}" + else + echo "$(backtrack_ $((depth++)) map "${map[$base]}" "${abort_value}")" "${base}" + fi + fi +} + +create_branch_map() { + local -n arr=$1 + local -n discovered=$2 + local -n map=$3 + + while IFS= read -r branch || [[ -n $branch ]]; do + rebase_target=$(git branch --merged "${branch}" --sort="ahead-behind:${branch}" --format="%(refname:short)" | grep -e "${branch_regex}" -e '^master$' | awk 'NR==2{print;exit}') + + # this is the case when the branch is actually behind master... we then + # still want to rebase against master + if [ -z "${rebase_target}" ] ; then + rebase_target=master + fi + + if ! array_contains input_branches "${rebase_target}" && [ "${rebase_target}" != "master" ] ; then + discovered+=( "${rebase_target}" ) + fi + + map["${branch}"]="${rebase_target}" +done < <(printf '%s\n' "${arr[@]}") +} + +{ + +# create branch rebase tree +# we're doing that on the state of the local tree/master +newly_detected_input_branches=( ) +create_branch_map input_branches newly_detected_input_branches branch_map +# these shenanigns are needed in case the rebase target branches themselves do not have +# the 'rebase' label... this would break cherry-picking on master, so we include "parent" +# branches regardless +while true ; do + if [ ${#newly_detected_input_branches[@]} -eq 0 ] ; then + break + else + nothing=( ) + create_branch_map newly_detected_input_branches nothing branch_map + newly_detected_input_branches=( "${nothing[@]}" ) + fi +done + +} >&2 + +# flatten recursively +for key in "${!branch_map[@]}"; do + value=${branch_map[$key]} + if [ "${value}" = "master" ] ; then + if ! array_contains branch_list "${key}" ; then + branch_list+=( "${key}" ) + fi + else + # shellcheck disable=SC2207 + branch_list+=( $(backtrack branch_map "$key" "master") ) + fi +done +unset key + +result=( ) +for key in "${branch_list[@]}"; do + result+=( "${key}:${branch_map[$key]}" ) +done +echo "${result[@]}" + diff --git a/.github/workflows/rebase.yaml b/.github/workflows/rebase.yaml new file mode 100644 index 00000000000..59b1f716262 --- /dev/null +++ b/.github/workflows/rebase.yaml @@ -0,0 +1,156 @@ +name: Rebase against upstream + +on: + schedule: + - cron: '0 0 * * *' + workflow_dispatch: + +permissions: + contents: write + issues: write + pull-requests: read + +concurrency: + group: ${{ github.workflow }} + cancel-in-progress: false + +jobs: + rebase: + name: Rebase now! + runs-on: ubuntu-latest + env: + UPSTREAM_REPO: https://github.com/haskell/cabal.git + CI_BRANCH: stable-haskell/feature/rebase-CI + outputs: + rebase_output_json: ${{ steps.rebase.outputs.branches_json }} + rebase_output: ${{ steps.rebase.outputs.branches }} + steps: + - name: Checkout code + uses: actions/checkout@v4 + with: + fetch-depth: 0 + persist-credentials: false + + - id: rebase + name: rebase + run: | + set -eux + + git switch --detach + git fetch origin refs/heads/*:refs/heads/* + + gh repo set-default stable-haskell/cabal + git config checkout.defaultRemote origin + + # required to apply patches + git config user.email "ci@users.noreply.github.com" + git config user.name "GitHub CI" + + # this does not push + branch_spec=$(bash .github/scripts/rebase_spec.sh '^stable-haskell/feature/.*') + rebased_branches=( $(bash .github/scripts/rebase_local.sh ${{ env.UPSTREAM_REPO }} "${branch_spec}") ) + + # we use branches_json to trigger release workflow, but we don't want to do it for upstream master + echo "branches_json=$(jq --compact-output --null-input '$ARGS.positional' --args -- "${rebased_branches[@]/#/tmp\/}" | jq --compact-output 'del(.[] | select(. == "tmp/master"))')" >> "$GITHUB_OUTPUT" + # this output is used to update remote branches, so it shall include upstream master + echo "branches=${rebased_branches[*]} master" >> "$GITHUB_OUTPUT" + shell: bash + env: + GH_TOKEN: ${{ github.token }} + + - name: save branches on remote + run: | + set -eux + + for branch in ${{ steps.rebase.outputs.branches }} ; do + git checkout "${branch}" + git push -f https://${{ secrets.REBASE_PAT }}@github.com/${{ github.repository }}.git ${branch}:tmp/${branch} + done + shell: bash + env: + GH_TOKEN: ${{ github.token }} + + - if: always() + name: backup + run: | + git checkout -f master || true + git archive master > backup.tar + tar -rf backup.tar .git rebase + + - if: always() + name: Upload artifact + uses: actions/upload-artifact@v4 + with: + if-no-files-found: error + retention-days: 7 + name: backup + path: | + ./backup.tar + + - name: checkout reusable workflow + run: | + git checkout -f "${{ env.CI_BRANCH }}" + + release-workflow: + needs: ["rebase"] + uses: ./.github/workflows/reusable-release.yml + with: + branches: ${{ needs.rebase.outputs.rebase_output_json }} + ghc: "9.6.7" + cabal: "3.12.1.0" + + push-job: + runs-on: ubuntu-latest + needs: [rebase, release-workflow] + steps: + - name: Checkout code + uses: actions/checkout@v4 + with: + fetch-depth: 0 + persist-credentials: false + + - name: update branches + run: | + set -eux + + for branch in ${{ needs.rebase.outputs.rebase_output }} ; do + git checkout "${branch}" + git push -f https://${{ secrets.REBASE_PAT }}@github.com/${{ github.repository }}.git tmp/${branch}:${branch} + done + git push -f https://${{ secrets.REBASE_PAT }}@github.com/${{ github.repository }}.git tmp/stable-master:stable-master + + shell: bash + env: + GH_TOKEN: ${{ github.token }} + + - name: delete tmp branches + if: always() + run: | + unset branch + for branch in $(git for-each-ref --format="%(refname:short)" -- 'refs/heads/tmp') ; do + git push -f https://${{ secrets.REBASE_PAT }}@github.com/${{ github.repository }}.git :${branch} + done + shell: bash + env: + GH_TOKEN: ${{ github.token }} + + notify-job: + runs-on: ubuntu-latest + needs: [release-workflow] + if: ${{ always() && contains(needs.*.result, 'failure') }} + steps: + - name: Checkout code + uses: actions/checkout@v4 + + # create an issue with a link to the workflow run on failure + # TODO: don't create more issues, only use one + - run: | + set -eux + gh repo set-default stable-haskell/cabal + for issue in $(gh issue list --label rebase-failure --json url -q '.[] | .url') ; do + gh issue close "${issue}" + done + gh issue create --title "Rebase failed on $(date -u +"%Y-%m-%d")" --label rebase-failure --body "${{ github.server_url }}/${{ github.repository }}/actions/runs/${{ github.run_id }}" + env: + GH_TOKEN: ${{ github.token }} + From 2f10c049165eb46f8b20724d2cf07aa7616993e8 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 15 Jul 2025 19:12:11 +0800 Subject: [PATCH 118/122] Do nightly release --- .github/workflows/release.yaml | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index acc7cbf46b9..7382c7ccc40 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -58,8 +58,12 @@ jobs: name: release needs: [ "release-workflow" ] runs-on: ubuntu-latest - if: ${{ startsWith(github.ref, 'refs/tags/') || github.event_name == 'workflow_dispatch' }} + if: ${{ startsWith(github.ref, 'refs/tags/') || github.event_name == 'workflow_dispatch' || github.event_name == 'schedule' }} steps: + - name: Get current date + id: date + run: echo "NIGHTLY_DATE=$(date +'%Y-%m-%d')" >> $GITHUB_ENV + - name: Checkout code uses: actions/checkout@v4 @@ -87,3 +91,12 @@ jobs: files: | ./out/* + - name: Release nightly + if: ${{ github.event_name == 'schedule' }} + uses: softprops/action-gh-release@v1 + with: + tag_name: nightly-${{ env.NIGHTLY_DATE }} + draft: false + prerelease: true + files: | + ./out/* From 6e4ee4b75fdf493be1965124419f43c299e4fdc0 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 18 Jul 2025 15:28:32 +0800 Subject: [PATCH 119/122] Add FreeBSD releases --- .github/workflows/reusable-release.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/reusable-release.yml b/.github/workflows/reusable-release.yml index d8f88292e21..e2f18abb2da 100644 --- a/.github/workflows/reusable-release.yml +++ b/.github/workflows/reusable-release.yml @@ -786,3 +786,4 @@ jobs: sudo tzsetup Etc/GMT sudo adjkerntz -a bash .github/scripts/test.sh + From ccac04e04910898b7925320e6d2c000851a1a45b Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Wed, 13 Aug 2025 14:33:52 +0800 Subject: [PATCH 120/122] Remove EOL alpine:3.12 --- .github/workflows/reusable-release.yml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/.github/workflows/reusable-release.yml b/.github/workflows/reusable-release.yml index e2f18abb2da..dbaed924516 100644 --- a/.github/workflows/reusable-release.yml +++ b/.github/workflows/reusable-release.yml @@ -498,12 +498,6 @@ jobs: , DISTRO: "Alpine" , ARTIFACT: "x86_64-linux-musl-static" }, - { image: "alpine:3.12" - , installCmd: "apk update && apk add" - , toolRequirements: "${{ needs.tool-output.outputs.apk_tools }}" - , DISTRO: "Alpine" - , ARTIFACT: "x86_64-linux-musl-static" - }, { image: "ghcr.io/void-linux/void-glibc:latest" , installCmd: "xbps-install -Suy xbps && xbps-install -Sy" , toolRequirements: "${{ needs.tool-output.outputs.xbps_tools }}" From d6fac5f900c2242d4e788910d474803fc722647b Mon Sep 17 00:00:00 2001 From: "Moritz Angermann (local patch)" Date: Tue, 26 May 2026 11:21:53 +0900 Subject: [PATCH 121/122] Remove dead GHCJS references in ProjectPlanning.hs CompilerFlavor no longer has a GHCJS constructor and Distribution.Simple.GHCJS module no longer exists in stable-haskell/cabal. These imports + pattern were left behind from incomplete GHCJS removal. Removing them lets cabal-install bootstrap with GHC 9.8.4. Local fix for stable-haskell/ghc#wasm-cross-ghcup. Should be upstreamed to stable-haskell/cabal#stable-haskell/master. --- cabal-install/src/Distribution/Client/ProjectPlanning.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index bb7f8672c89..b95ea6f7a0f 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -221,7 +221,10 @@ import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD import qualified Distribution.Simple.Configure as Cabal import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS +-- GHCJS support was removed from stable-haskell/cabal (CompilerFlavor no longer +-- has a GHCJS constructor, Distribution.Simple.GHCJS module no longer exists). +-- This dead import was left behind. -- patched locally for wasm-cross-ghcup. +-- import qualified Distribution.Simple.GHCJS as GHCJS import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.LocalBuildInfo as Cabal import qualified Distribution.Simple.Setup as Cabal @@ -2432,7 +2435,8 @@ elaborateInstallPlan compilerShouldUseSharedLibByDefault = case compilerFlavor compiler of GHC -> GHC.compilerBuildWay compiler == DynWay && canBuildSharedLibs - GHCJS -> GHCJS.isDynamic compiler + -- GHCJS support removed -- patched locally for wasm-cross-ghcup. + -- GHCJS -> GHCJS.isDynamic compiler _ -> False canBuildWayLibs predicate = case predicate compiler of From 3386061c78d85651d6098445af85711466566a0b Mon Sep 17 00:00:00 2001 From: "Moritz Angermann (local patch)" Date: Tue, 26 May 2026 11:31:49 +0900 Subject: [PATCH 122/122] Fix stale binDirectoryFor call in ProjectOrchestration MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit binDirectoryFor was renamed/refactored to binDirectories (in ProjectPlanning.hs) with a different signature. The call site at ProjectOrchestration.hs:544 wasn't updated. Use elabBinDir directly — same value that binDirectories ultimately returns (see ProjectPlanning/Types.hs:496-497, 503). --- .../src/Distribution/Client/ProjectOrchestration.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 69f85429863..7af36eaf96e 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -541,7 +541,11 @@ installExecutables , (ComponentTarget (CExeName cname) _subtarget, _targetSelectors) <- targets , let platform = toolchainPlatform (getStage toolchains (elabStage elab)) , let exeName = unUnqualComponentName cname - , let dir = binDirectoryFor distDirLayout elaboratedShared elab exeName + -- binDirectoryFor was renamed/refactored to binDirectories with a + -- different signature; the call site here wasn't updated. Use + -- elabBinDir directly (same as what binDirectories yields) so this + -- file compiles. -- patched locally for wasm-cross-ghcup. + , let dir = elabBinDir elab , let exe = exeName <.> exeExtension platform ] toolchains = pkgConfigToolchains elaboratedShared