diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index 231111af1e4..ded65c63bce 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, Build) import Distribution.Verbosity (Verbosity) import Distribution.Version (Version, VersionRange) import Language.Haskell.Extension (Extension, Language, knownLanguages) @@ -405,6 +407,18 @@ instance Described ExposedModule where instance Described Extension where describe _ = RETodo +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 ')') + ] + 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/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs index c716563f52a..26c5f71680a 100644 --- a/Cabal-syntax/src/Distribution/Compat/Graph.hs +++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs @@ -100,10 +100,11 @@ 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 -- of class 'IsNode'. @@ -114,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 @@ -284,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. @@ -343,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 @@ -352,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 @@ -377,7 +387,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-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..558594f72b6 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -174,6 +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 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) @@ -224,6 +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 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) @@ -263,6 +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 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) @@ -339,6 +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 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) @@ -483,6 +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 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) @@ -585,6 +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 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) @@ -629,14 +641,16 @@ 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 "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 [] - <*> 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 +850,9 @@ formatOtherExtensions = alaList' FSep MQuoted formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName formatOtherModules = alaList' VCat MQuoted +formatExtraSources :: [ExtraSource pkg] -> List VCat (Identity (ExtraSource pkg)) (ExtraSource pkg) +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..f41f800be13 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,19 @@ 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 Pkg] + -- ^ Assembly source files + , cmmSources :: [ExtraSource Pkg] + -- ^ C-- source files + , autogenCmmSources :: [ExtraSource Build] + -- ^ C-- generated source files + , cSources :: [ExtraSource Pkg] + -- ^ C source files + , cxxSources :: [ExtraSource Pkg] + -- ^ C++ source files + , jsSources :: [ExtraSource Pkg] + -- ^ 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, @@ -171,6 +177,7 @@ instance Monoid BuildInfo where , extraFrameworkDirs = [] , asmSources = [] , cmmSources = [] + , autogenCmmSources = [] , cSources = [] , cxxSources = [] , jsSources = [] @@ -225,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 72a24caa734..70e7f1e38d4 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,27 @@ class HasBuildInfo a where extraFrameworkDirs = buildInfo . extraFrameworkDirs {-# INLINE extraFrameworkDirs #-} - asmSources :: Lens' a [SymbolicPath Pkg File] + asmSources :: Lens' a [ExtraSource Pkg] asmSources = buildInfo . asmSources {-# INLINE asmSources #-} - cmmSources :: Lens' a [SymbolicPath Pkg File] + autogenCmmSources :: Lens' a [ExtraSource Build] + autogenCmmSources = buildInfo . autogenCmmSources + {-# INLINE autogenCmmSources #-} + + cmmSources :: Lens' a [ExtraSource Pkg] cmmSources = buildInfo . cmmSources {-# INLINE cmmSources #-} - cSources :: Lens' a [SymbolicPath Pkg File] + cSources :: Lens' a [ExtraSource Pkg] cSources = buildInfo . cSources {-# INLINE cSources #-} - cxxSources :: Lens' a [SymbolicPath Pkg File] + cxxSources :: Lens' a [ExtraSource Pkg] cxxSources = buildInfo . cxxSources {-# INLINE cxxSources #-} - jsSources :: Lens' a [SymbolicPath Pkg File] + jsSources :: Lens' a [ExtraSource Pkg] jsSources = buildInfo . jsSources {-# INLINE jsSources #-} @@ -274,7 +279,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..e3b05603219 --- /dev/null +++ b/Cabal-syntax/src/Distribution/Types/ExtraSource.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Types.ExtraSource + ( ExtraSource (..) + , ExtraSourceClass (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Utils.Path (Build, FileOrDir (..), Pkg, RelativePath, SymbolicPath, relativeSymbolicPath, unsafeCoerceSymbolicPath) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as PP + +data family ExtraSource pkg + +data instance ExtraSource Pkg = ExtraSourcePkg (SymbolicPath Pkg File) [String] + deriving (Generic, Show, Read, Eq, Ord, Data) + +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 + path <- parsec <* P.spaces + opts <- P.optional (parensLax (P.sepBy p P.spaces)) + return (ExtraSourcePkg path (fromMaybe mempty opts)) + where + p :: P.CharParsing p => p String + p = some $ P.satisfy (\c -> not (isSpace c) && (c /= ')')) + +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 Build) where + pretty (ExtraSourceBuild path opts) = + pretty path <<>> PP.parens (PP.hsep (map PP.text opts)) + +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 a53d404dd1e..98380744f67 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 () @@ -25,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) @@ -73,6 +74,8 @@ instance NoThunks ConfVar instance NoThunks Dependency instance NoThunks Executable instance NoThunks ExecutableScope +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 e298681f272..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 - 0xc039c6741dead5203ad2b33bd3bf4dc8 + 0x8ba94d68856c65b2946ee48e11afdd07 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion md5CheckLocalBuildInfo proxy = md5Check proxy - 0xea86b170fa32ac289cbd1fb6174b5cbf + 0x4e2dd902c8bf79bb656793174f0a6c49 diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index f7e7ca5b7b6..77a1d5b86c3 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 @@ -27,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 @@ -75,6 +76,8 @@ instance ToExpr ExeDependency instance ToExpr Executable instance ToExpr ExecutableScope instance ToExpr ExposedModule +instance ToExpr (ExtraSource Build) +instance ToExpr (ExtraSource Pkg) instance ToExpr FlagAssignment instance ToExpr FlagName instance ToExpr ForeignLib 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..611537a7828 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 @@ -280,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/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 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..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 (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 (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 (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 (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 (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 ++ 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 ++ 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 ++ 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 ++ 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 ++ 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/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/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 08fb14520d7..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 @@ -183,6 +182,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 @@ -930,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) @@ -1208,7 +1209,8 @@ finalCheckPackage enabled configureComponents - :: LBC.LocalBuildConfig + :: HasCallStack + => LBC.LocalBuildConfig -> LBC.PackageBuildDescr -> PackageInfo -> ([PreExistingComponent], [ConfiguredPromisedComponent]) diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index 593bf4e9119..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 @@ -312,15 +313,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/Build/ExtraSources.hs b/Cabal/src/Distribution/Simple/GHC/Build/ExtraSources.hs index f2ca9aba02f..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 #-} @@ -26,6 +28,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) @@ -51,25 +54,24 @@ buildAllExtraSources = , buildJsSources , buildAsmSources , buildCmmSources + , buildAutogenCmmSources ] -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 +82,11 @@ buildCSources mbMainFile = CExe{} | Just main <- mbMainFile , isC $ getSymbolicPath main -> - cFiles ++ [main] + cFiles ++ [ExtraSourcePkg main mempty] _otherwise -> cFiles ) + +buildCxxSources :: ExtraSourceBuilder buildCxxSources mbMainFile = buildExtraSources "C++ Sources" @@ -93,9 +97,11 @@ buildCxxSources mbMainFile = CExe{} | Just main <- mbMainFile , isCxx $ getSymbolicPath main -> - cxxFiles ++ [main] + cxxFiles ++ [ExtraSourcePkg main mempty] _otherwise -> cxxFiles ) + +buildJsSources :: ExtraSourceBuilder buildJsSources _mbMainFile ghcProg buildTargetDir neededWays = do Platform hostArch _ <- hostPlatform <$> localBuildInfo let hasJsSupport = hostArch == JavaScript @@ -114,36 +120,49 @@ 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" 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) - -> SymbolicPath Pkg File + -> 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 -> [SymbolicPath Pkg File]) + -> (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 @@ -189,8 +208,7 @@ buildExtraSources platform mbWorkDir - buildAction :: SymbolicPath Pkg File -> IO () - buildAction sourceFile = do + buildAction extraSource = do let baseSrcOpts = componentSourceGhcOptions verbosity @@ -198,7 +216,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 +246,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 (Internal.sourcePath lbi extraSource) opts' + when needsRecomp $ runGhcProg opts' createDirectoryIfMissingVerbose verbosity True (i odir) case targetComponent targetInfo of @@ -269,4 +287,4 @@ buildExtraSources else do info verbosity ("Building " ++ description ++ "...") traverse_ buildAction sources - return (toNubListR 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 9e252d7c889..1a6e878c226 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 @@ -100,37 +104,47 @@ 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 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 + { 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) @@ -230,27 +244,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 @@ -377,21 +390,23 @@ includePaths lbi bi clbi odir = | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi ] -componentCcGhcOptions - :: Verbosity +type ExtraSourceGhcOptions pkg = + Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Artifacts) - -> SymbolicPath Pkg File + -> ExtraSource pkg -> GhcOptions -componentCcGhcOptions verbosity lbi bi clbi odir filename = + +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 [filename] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -408,6 +423,7 @@ componentCcGhcOptions verbosity lbi bi clbi odir filename = MaximalDebugInfo -> ["-g3"] ) ++ ccOptions bi + ++ extraSourceOpts extraSource , ghcOptCcProgram = maybeToFlag $ programPath @@ -416,21 +432,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 :: 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 [filename] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -447,6 +456,7 @@ componentCxxGhcOptions verbosity lbi bi clbi odir filename = MaximalDebugInfo -> ["-g3"] ) ++ cxxOptions bi + ++ extraSourceOpts extraSource , ghcOptCcProgram = maybeToFlag $ programPath @@ -455,21 +465,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 :: 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 [filename] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True , ghcOptPackageDBs = withPackageDB lbi @@ -490,21 +493,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 :: 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 [filename] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptJSppOptions = jsppOptions bi , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptHideAllPackages = toFlag True @@ -601,21 +597,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 :: 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 [filename] + , ghcOptInputFiles = toNubListR [sourcePath lbi extraSource] , ghcOptCppIncludePath = includePaths lbi bi clbi odir , ghcOptCppOptions = cppOptions bi , ghcOptCppIncludes = @@ -626,7 +615,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 } @@ -862,3 +851,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 a73d47f7a6e..de942f03515 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 (\e -> getSymbolicPath (extraSourceFile e) : extraSourceOpts e) 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 Pkg] + , cxxSourceFiles :: [ExtraSource Pkg] , 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, 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 = (main : cSources bnfo, cxxSources bnfo) + | otherwise = (ExtraSourcePkg 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/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/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 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/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/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs index 33c50f20b5e..b5d74b31b54 100644 --- a/Cabal/src/Distribution/Utils/LogProgress.hs +++ b/Cabal/src/Distribution/Utils/LogProgress.hs @@ -4,10 +4,13 @@ module Distribution.Utils.LogProgress ( LogProgress , runLogProgress + , runLogProgress' , warnProgress , infoProgress , dieProgress , addProgressCtx + , eitherToLogProgress + , ErrMsg ) where import Distribution.Compat.Prelude @@ -16,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 @@ -61,6 +65,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 -> @@ -75,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 @@ -88,3 +106,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/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 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/Modular.hs b/cabal-install-solver/src/Distribution/Solver/Modular.hs index a4baebf496c..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 @@ -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,36 +67,36 @@ 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 + (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 + -- 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 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 @@ -133,21 +135,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 5d196f4fd9f..84d709346f4 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,7 +36,7 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath -import Distribution.Solver.Types.Settings +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 @@ -50,8 +51,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. @@ -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. @@ -105,7 +112,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 @@ -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' })) @@ -140,40 +149,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. @@ -247,23 +258,22 @@ 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 - , 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 - , qualifyOptions = defaultQualifyOptions idx } , 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 | ind = L.map makeIndependent igs - | otherwise = L.map (Q (PackagePath DefaultNamespace 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..af78f678712 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,43 +19,47 @@ 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) + Inst pi -> Left (PreExistingId stage sourceId pi) _otherwise | QualExe _ pn' <- q -- NB: the dependencies of the executable are also @@ -66,7 +68,7 @@ convConfId (PI (Q (PackagePath _ q) pn) (I 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/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-solver/src/Distribution/Solver/Modular/Dependency.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Dependency.hs index 27debc9c6f0..dbd47c1dcc9 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,25 +43,26 @@ 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 import Distribution.Types.UnqualComponentName +import Distribution.Solver.Types.Stage {------------------------------------------------------------------------------- Constrained instances @@ -85,14 +90,37 @@ 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. - Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) - -- | Dependencies which are conditional on whether or not a stanza +-- +-- 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) + -- ^ 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 -- @@ -102,11 +130,8 @@ 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)] - -type TrueFlaggedDeps qpn = FlaggedDeps qpn -type FalseFlaggedDeps qpn = FlaggedDeps qpn + aux (Stanza _ t) = flattenFlaggedDeps t + aux (Simple d c) = [(d, c)] -- | A 'Dep' labeled with the reason it was introduced. -- @@ -114,76 +139,83 @@ type FalseFlaggedDeps qpn = FlaggedDeps qpn -- 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 -- 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, Show) -- | 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 = +data ExposedComponent + = -- | A library component ExposedLib LibraryName - | ExposedExe UnqualComponentName + | -- | 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. 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 s 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,37 +229,20 @@ 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 (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 - - -- 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 - 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 + goD (Ext ext) _ = Ext ext + goD (Lang lang) _ = Lang lang + goD (Pkg pkn vr) _ = Pkg pkn vr + + -- 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 -- @@ -244,8 +259,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 +286,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 +303,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 +317,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 +342,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 +364,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..8dfa9c88bf3 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs @@ -268,9 +268,9 @@ 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 (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..3833c95de69 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 @@ -32,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 { @@ -57,18 +61,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/IndexConversion.hs b/cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs index 72d0b8193e3..51a9ebad01d 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,24 +267,27 @@ 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 _ -> 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/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/Message.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Message.hs index d6ffadf0abf..51c0afae8f0 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' -> "to reuse " ++ showQPN (Q pp' pn) ++ " for " ++ showQPN qpn -- | 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 ccd0e4d4a70..7fa0a41bd7d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Package.hs @@ -10,9 +10,6 @@ module Distribution.Solver.Modular.Package , PN , QPV , instI - , makeIndependent - , primaryPP - , setupPP , showI , showPI , unPN @@ -26,6 +23,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 @@ -48,22 +46,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 @@ -74,33 +67,5 @@ 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 --- determine (1) if we should try to establish stanza preferences --- for this goal, and (2) whether or not a user specified @--constraint@ --- should apply to this dependency (grep 'primaryPP' to see the --- use sites). In particular this does not include packages pulled in --- as setup deps. --- -primaryPP :: PackagePath -> Bool -primaryPP (PackagePath _ns q) = go q - where - go QualToplevel = True - go (QualBase _) = True - go (QualSetup _) = False - go (QualExe _ _) = False - --- | Is the package a dependency of a setup script. This is used to --- establish whether or not certain constraints should apply to this --- dependency (grep 'setupPP' to see the use sites). --- -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..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 _ns (QualSetup _)) _)) _) = False - noSetupOrExe (Goal (P (Q (PackagePath _ns (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 b2c89fc1537..8eac32c4044 100644 --- a/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE CPP #-} -#ifdef DEBUG_TRACETREE -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} -#endif module Distribution.Solver.Modular.Solver ( SolverConfig(..) , solve @@ -44,17 +39,8 @@ 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 Debug.Trace.Tree (gtraceJson) -import Debug.Trace.Tree.Simple -import Debug.Trace.Tree.Generic -import Debug.Trace.Tree.Assoc (Assoc(..)) -#endif -- | Various options for the modular solver. data SolverConfig = SolverConfig { @@ -62,7 +48,6 @@ data SolverConfig = SolverConfig { countConflicts :: CountConflicts, fineGrainedConflicts :: FineGrainedConflicts, minimizeConflictSet :: MinimizeConflictSet, - independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, shadowPkgs :: ShadowPkgs, strongFlags :: StrongFlags, @@ -89,28 +74,23 @@ 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 . - traceTree "heuristics.json" id . trav ( - heuristicsPhase . - preferencesPhase . - validationPhase - ) . - traceTree "semivalidated.json" id . + heuristicsPhase . + preferencesPhase . + validationPhase + ) $ validationCata . - traceTree "pruned.json" id . - trav prunePhase . - traceTree "build.json" id $ + trav prunePhase $ buildPhase where explorePhase = backjumpAndExplore (maxBackjumps sc) @@ -137,14 +117,15 @@ 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 -> 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 @@ -167,65 +148,6 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices | otherwise = id {- P.firstGoal -} --- | Dump solver tree to a file (in debugging mode) --- --- This only does something if the @debug-tracetree@ configure argument was --- given; otherwise this is just the identity function. -{- FOURMOLU_DISABLE -} -traceTree :: -#ifdef DEBUG_TRACETREE - GSimpleTree a => -#endif - FilePath -- ^ Output file - -> (a -> a) -- ^ Function to summarize the tree before dumping - -> a -> a -#ifdef DEBUG_TRACETREE -traceTree = gtraceJson -#else -traceTree _ _ = id -#endif -{- FOURMOLU_ENABLE -} - -#ifdef DEBUG_TRACETREE -instance GSimpleTree (Tree d c) where - fromGeneric = go - where - go :: Tree d c -> SimpleTree - go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq - go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq - go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq - go (Done _rdm _s) = Node "D" $ Assoc [] - go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] - - psqToList :: W.WeightedPSQ w k v -> [(k, v)] - psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList - - -- Show package choice - goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) - goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) - goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) - - -- Show flag or stanza choice - goFS :: Bool -> Tree d c -> (String, SimpleTree) - goFS val subtree = (show val, go subtree) - - -- Show goal choice - goG :: Goal QPN -> Tree d c -> (String, SimpleTree) - goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) - - -- Variation on 'showGR' that produces shorter strings - -- (Actually, QGoalReason records more info than necessary: we only need - -- to know the variable that introduced the goal, not the value assigned - -- to that variable) - shortGR :: QGoalReason -> String - shortGR UserGoal = "user" - shortGR (DependencyGoal dr) = showDependencyReason dr - - -- Show conflict set - goCS :: ConflictSet -> String - goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" -#endif -- | Replace all goal reasons with a dummy goal reason in the tree -- @@ -250,5 +172,5 @@ _removeGR = trav go dummy = DependencyGoal $ DependencyReason - (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) + (Q (PackagePath Host QualToplevel) (mkPackageName "$")) M.empty S.empty 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' diff --git a/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs b/cabal-install-solver/src/Distribution/Solver/Modular/Validate.hs index 4af149b31cf..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, @@ -108,9 +109,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) @@ -191,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 @@ -200,17 +199,17 @@ 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 I stage _vr _loc = i 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 -- 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 @@ -235,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 @@ -257,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') -> @@ -265,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 @@ -287,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') -> @@ -331,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 @@ -348,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] @@ -452,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 @@ -563,19 +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 - , qualifyOptions = defaultQualifyOptions idx } + 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/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 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 06c5ae169fa..4b60d2ebc66 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 @@ -46,44 +57,54 @@ data ConstraintScope = 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) -- | 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 (ScopeAnyExeQualifier pn)) = pn +scopeToPackageName (ConstraintScope _stage (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') = - 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' +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) 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) = + 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 + 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-solver/src/Distribution/Solver/Types/PackagePath.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs index 4fc4df25f97..38cb0dd8d01 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackagePath.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) - , Namespace(..) , Qualifier(..) , dispQualifier , Qualified(..) @@ -12,42 +13,25 @@ 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) --- | A package path consists of a namespace and a package path inside that --- namespace. -data PackagePath = PackagePath Namespace 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 "." +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 = -- | 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 @@ -68,34 +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. --- --- 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 "." +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 ns qual) pn) = - dispNamespace ns <<>> 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/Progress.hs b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs index a47e651d1c4..ed281177819 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/Progress.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} module Distribution.Solver.Types.Progress ( Progress(..) , foldProgress + , step + , fail ) where import Prelude () -import Distribution.Solver.Compat.Prelude hiding (fail) +import Distribution.Solver.Compat.Prelude -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final @@ -13,14 +17,16 @@ import Distribution.Solver.Compat.Prelude hiding (fail) data Progress step fail done = Step step (Progress step fail done) | Fail fail | Done done + deriving (Functor) --- This Functor instance works around a bug in GHC 7.6.3. --- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637. --- The derived functor instance caused a space leak in the solver. -instance Functor (Progress step fail) where - fmap f (Step s p) = Step s (fmap f p) - fmap _ (Fail x) = Fail x - fmap f (Done r) = Done (f r) +instance (Show step, Show fail, Show done) => Show (Progress step fail done) where + showsPrec _ = foldProgress + (\s p -> showString "Step: " . shows s . showChar '\n' . p) + (\f -> showString "Fail: " . shows f) + (\r -> showString "Done: " . shows r) + +step :: step -> Progress step fail () +step s = Step s (Done ()) -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure. @@ -31,15 +37,18 @@ instance Functor (Progress step fail) where -- foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) -> Progress step fail done -> a -foldProgress step fail done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = fail f - fold (Done r) = done r +foldProgress step_ fail_ done_ = fold + where fold (Step s p) = step_ s (fold p) + fold (Fail f) = fail_ f + fold (Done r) = done_ r instance Monad (Progress step fail) where return = pure p >>= f = foldProgress Step Fail f p +instance MonadFail (Progress step String) where + fail = Fail + instance Applicative (Progress step fail) where pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p 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/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-solver/src/Distribution/Solver/Types/SolverId.hs b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs index d32ccc17e74..9afb8bf1338 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SolverId.hs @@ -9,14 +9,19 @@ import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) +import Distribution.Pretty (Pretty (..)) +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 @@ -27,3 +32,7 @@ instance Show SolverId where instance Package SolverId where packageId = solverSrcId + +instance Pretty SolverId where + 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-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-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..6ee663795f4 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/Toolchain.hs @@ -0,0 +1,42 @@ +{-# 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 + -- 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) + +-- 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/cabal-install.cabal b/cabal-install/cabal-install.cabal index 6e4256cb13d..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 @@ -215,12 +216,14 @@ library Distribution.Client.TargetProblem Distribution.Client.TargetSelector Distribution.Client.Targets + Distribution.Client.Toolchain Distribution.Client.Types Distribution.Client.Types.AllowNewer Distribution.Client.Types.BuildResults 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/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index d9ab2f5247f..ff26080adf6 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 (..) @@ -180,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 @@ -189,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]) @@ -226,7 +230,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/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/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/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/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/CmdGenBounds.hs b/cabal-install/src/Distribution/Client/CmdGenBounds.hs index 6e47fcd6a9c..6188ef3d46a 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) @@ -28,6 +27,7 @@ import Distribution.Simple.Utils import Distribution.Version import Distribution.Client.Setup (GlobalFlags (..)) +import Distribution.Utils.LogProgress (runLogProgress) -- Project orchestration imports @@ -39,6 +39,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 @@ -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 @@ -130,8 +132,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) @@ -139,7 +141,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 @@ -188,7 +190,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/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index f9be5763b3b..d741211f286 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 @@ -70,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} @@ -160,6 +166,7 @@ haddockAction relFlags targetStrings globalFlags = do projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}} | otherwise = projCtx + absProjectConfig <- mkConfigAbsolute relProjectConfig let baseCtx = relBaseCtx{projectConfig = absProjectConfig} @@ -183,15 +190,20 @@ 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 + let toolchains = pkgConfigToolchains (elaboratedShared buildCtx) + + -- TODO progs <- reconfigurePrograms verbosity @@ -200,14 +212,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..e929f3c1956 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -35,11 +35,13 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage (..) , ElaboratedInstallPlan + , ElaboratedInstalledPackageInfo , ElaboratedSharedConfig (..) , TargetAction (..) - ) -import Distribution.Client.ProjectPlanning.Types - ( elabDistDirParams + , Toolchain (..) + , WithStage (..) + , 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,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.Types.Version (mkVersion) -import Distribution.Types.VersionRange (orLaterVersion) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Verbosity as Verbosity ( normal ) @@ -154,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 @@ -167,27 +162,29 @@ haddockProjectAction flags _extraArgs globalFlags = do sharedConfig :: ElaboratedSharedConfig sharedConfig = elaboratedShared buildCtx - pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage] + pkgs :: [Either ElaboratedInstalledPackageInfo 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. @@ -215,7 +212,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 @@ -302,10 +299,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 +324,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 +333,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 @@ -442,7 +444,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 780047ef729..e20df89abb6 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 @@ -90,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 @@ -114,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 @@ -138,6 +140,7 @@ import Distribution.Simple.Compiler ) import Distribution.Simple.Configure ( configCompilerEx + , interpretPackageDbFlags ) import Distribution.Simple.Flag ( flagElim @@ -216,6 +219,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( writeFileAtomic ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , normal @@ -412,12 +418,15 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project } , projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + } , projectConfigStoreDir , projectConfigProgPathExtra - , projectConfigPackageDBs } , projectConfigLocalPackages = PackageConfig @@ -470,7 +479,6 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project fetchAndReadSourcePackages verbosity distDirLayout - (Just compiler) (projectConfigShared config) (projectConfigBuildOnly config) [ProjectPackageRemoteTarball uri | uri <- uris] @@ -561,7 +569,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 @@ -780,7 +788,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 @@ -825,7 +833,7 @@ partitionToKnownTargetsAndHackagePackages -> SourcePackageDb -> ElaboratedInstallPlan -> [TargetSelector] - -> IO (TargetsMap, [PackageName]) + -> IO (TargetsMapS, [PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do let mTargets = resolveTargetsFromSolver @@ -895,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) @@ -1001,7 +1012,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') @@ -1346,7 +1357,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/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 0dc78bcb4f3..ecce6fcb6e5 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) @@ -61,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 @@ -128,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) <- @@ -204,8 +206,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? @@ -225,7 +227,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) @@ -317,7 +319,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 @@ -334,7 +336,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 bec228a771e..a80a772ad5f 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 @@ -76,6 +77,7 @@ import Distribution.Simple.Program import Distribution.Simple.Utils ( die' , dieWithException + , warn , withOutputMarker , wrapText ) @@ -244,10 +246,13 @@ 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 + 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..655f5a3fa9c 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -55,9 +55,13 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedInstallPlan , ElaboratedSharedConfig (..) + , Stage (..) + , WithStage + , getStage ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies + ( Toolchain (..) + , elabOrderExeDependencies , showElaboratedInstallPlan ) import Distribution.Client.ScriptUtils @@ -79,7 +83,7 @@ import Distribution.Client.TargetProblem ) import Distribution.Client.Targets ( UserConstraint (..) - , UserConstraintScope (..) + , UserConstraintQualifier (..) ) import Distribution.Client.Types ( PackageSpecifier (..) @@ -91,7 +95,6 @@ import Distribution.Compiler import Distribution.Package ( Package (..) , UnitId - , installedUnitId , mkPackageName , packageName ) @@ -154,6 +157,9 @@ import Distribution.Types.VersionRange import Distribution.Utils.Generic ( safeHead ) +import Distribution.Utils.LogProgress + ( runLogProgress + ) import Distribution.Verbosity ( lessVerbose , normal @@ -180,6 +186,7 @@ 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) @@ -361,13 +368,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. - targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors - + 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'') @@ -380,20 +388,23 @@ 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' = + elaboratedPlan' <- + runLogProgress verbosity $ pruneInstallPlanToTargets TargetActionRepl targets elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) + + let includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) pkgsBuildStatus <- rebuildTargetsDryRun @@ -417,13 +428,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 +467,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 @@ -521,6 +530,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 @@ -560,8 +570,8 @@ minMultipleHomeUnitsVersion :: Version minMultipleHomeUnitsVersion = mkVersion [9, 4] data OriginalComponentInfo = OriginalComponentInfo - { ociUnitId :: UnitId - , ociOriginalDeps :: [UnitId] + { ociUnitId :: WithStage UnitId + , ociOriginalDeps :: [WithStage UnitId] } deriving (Show) @@ -596,18 +606,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' @@ -759,7 +776,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 @@ -776,7 +793,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..bbc2eeff44b 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 @@ -125,6 +126,7 @@ import Distribution.Types.UnqualComponentName ( UnqualComponentName , unUnqualComponentName ) +import Distribution.Utils.LogProgress (runLogProgress) import Distribution.Utils.NubList ( fromNubList ) @@ -246,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) <- @@ -384,7 +388,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 +400,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 +498,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 +515,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/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/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 0653b449504..97acd7064de 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 @@ -576,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/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index bf0b7fdec27..38230a83152 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 @@ -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 594afb9e24f..f1b7532e001 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- - ----------------------------------------------------------------------------- +{-# LANGUAGE LambdaCase #-} -- | -- Module : Distribution.Client.Dependency @@ -48,7 +49,6 @@ module Distribution.Client.Dependency , setCountConflicts , setFineGrainedConflicts , setMinimizeConflictSet - , setIndependentGoals , setAvoidReinstalls , setShadowPkgs , setStrongFlags @@ -116,7 +116,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 (..) @@ -137,7 +138,8 @@ import Distribution.Types.DependencySatisfaction ( DependencySatisfaction (..) ) import Distribution.Verbosity - ( normal + ( deafening + , normal ) import Distribution.Version @@ -161,6 +163,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 @@ -171,6 +174,8 @@ import Data.List ) import qualified Data.Map as Map import qualified Data.Set as Set +import GHC.Stack (HasCallStack) +import Text.PrettyPrint -- ------------------------------------------------------------ @@ -186,13 +191,12 @@ data DepResolverParams = DepResolverParams , depResolverConstraints :: [LabeledPackageConstraint] , depResolverPreferences :: [PackagePreference] , depResolverPreferenceDefault :: PackagesPreferenceDefault - , depResolverInstalledPkgIndex :: InstalledPackageIndex + , depResolverInstalledPkgIndex :: InstalledPackageIndex -> InstalledPackageIndex , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage , depResolverReorderGoals :: ReorderGoals , depResolverCountConflicts :: CountConflicts , depResolverFineGrainedConflicts :: FineGrainedConflicts , depResolverMinimizeConflictSet :: MinimizeConflictSet - , depResolverIndependentGoals :: IndependentGoals , depResolverAvoidReinstalls :: AvoidReinstalls , depResolverShadowPkgs :: ShadowPkgs , depResolverStrongFlags :: StrongFlags @@ -215,47 +219,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)) - ++ "\nindependent goals: " - ++ show (asBool (depResolverIndependentGoals 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. -- @@ -282,22 +287,20 @@ 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 , depResolverFineGrainedConflicts = FineGrainedConflicts True , depResolverMinimizeConflictSet = MinimizeConflictSet False - , depResolverIndependentGoals = IndependentGoals False , depResolverAvoidReinstalls = AvoidReinstalls False , depResolverShadowPkgs = ShadowPkgs False , depResolverStrongFlags = StrongFlags False @@ -374,12 +377,6 @@ setMinimizeConflictSet minimize params = { depResolverMinimizeConflictSet = minimize } -setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams -setIndependentGoals indep params = - params - { depResolverIndependentGoals = indep - } - setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams setAvoidReinstalls avoid params = params @@ -451,7 +448,7 @@ dontInstallNonReinstallablePackages params = where extraConstraints = [ LabeledPackageConstraint - (PackageConstraint (ScopeAnyQualifier pkgname) PackagePropertyInstalled) + (PackageConstraint (ConstraintScope Nothing (ScopeAnyQualifier pkgname)) PackagePropertyInstalled) ConstraintSourceNonReinstallablePackage | pkgname <- nonReinstallablePackages ] @@ -504,10 +501,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 @@ -518,10 +513,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 @@ -657,7 +650,7 @@ addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion minVersion) ) ConstraintSetupCabalMinVersion @@ -675,7 +668,7 @@ addSetupCabalMaxVersionConstraint maxVersion = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ earlierVersion maxVersion) ) ConstraintSetupCabalMaxVersion @@ -691,7 +684,7 @@ addSetupCabalProfiledDynamic = addConstraints [ LabeledPackageConstraint ( PackageConstraint - (ScopeAnySetupQualifier cabalPkgname) + (ConstraintScope Nothing (ScopeAnySetupQualifier cabalPkgname)) (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) ) ConstraintSourceProfiledDynamic @@ -708,12 +701,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 @@ -729,7 +720,6 @@ basicInstallPolicy . addSourcePackages [pkg | SpecificSourcePackage pkg <- pkgSpecifiers] $ basicDepResolverParams - installedPkgIndex sourcePkgIndex -- | The policy used by all the standard commands, install, fetch, freeze etc @@ -737,14 +727,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 @@ -790,54 +778,58 @@ 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 = - Step (showDepResolverParams finalparams) $ - fmap (validateSolverResult platform comp indGoals) $ - formatProgress $ - runSolver - ( SolverConfig - reordGoals - cntConflicts - fineGrained - minimize - indGoals - noReinstalls - shadowing - strFlags - onlyConstrained_ - maxBkjumps - enableBj - solveExes - order - verbosity - (PruneAfterFirstSuccess False) - ) - platform - comp - installedPkgIndex - sourcePkgIndex - pkgConfigDB - preferences - constraints - targets +resolveDependencies toolchains pkgConfigDB installedPkgIndex params = do + step (showDepResolverParams finalparams) + pkgs <- + formatProgress $ + runSolver + config + toolchains + pkgConfigDB + installedPkgIndex' + sourcePkgIndex + preferences + constraints + targets + validateSolverResult toolchains pkgs where + installedPkgIndex' = Staged $ \case + Build -> getStage installedPkgIndex Build + Host -> installedPkgIndexM (getStage installedPkgIndex Host) + + config = + SolverConfig + reordGoals + cntConflicts + fineGrained + minimize + noReinstalls + shadowing + strFlags + onlyConstrained_ + maxBkjumps + enableBj + solveExes + order + verbosity + (PruneAfterFirstSuccess False) + finalparams@( DepResolverParams targets constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex reordGoals cntConflicts fineGrained minimize - indGoals noReinstalls shadowing strFlags @@ -921,17 +913,17 @@ 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 - -> IndependentGoals + :: HasCallStack + => Staged (CompilerInfo, Platform) -> [ResolverPackage UnresolvedPkgLoc] - -> SolverInstallPlan -validateSolverResult platform comp indepGoals pkgs = - case planPackagesProblems platform comp pkgs of - [] -> case SolverInstallPlan.new indepGoals graph of - Right plan -> plan - Left problems -> error (formatPlanProblems problems) - problems -> error (formatPkgProblems problems) + -> Progress String String SolverInstallPlan +validateSolverResult toolchains pkgs = + case planPackagesProblems toolchains pkgs of + [] -> case SolverInstallPlan.new graph of + Right plan -> return plan + Left problems -> + fail (formatPlanProblems problems) + problems -> fail (formatPkgProblems problems) where graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc) graph = Graph.fromDistinctList pkgs @@ -972,14 +964,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 @@ -1028,14 +1019,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 ] @@ -1108,8 +1097,8 @@ configuredPackageProblems specifiedFlags compSpec (const Satisfied) - platform - cinfo + (snd (getStage toolchains stage)) + (fst (getStage toolchains stage)) [] (srcpkgDescription pkg) of Right (resolvedPkg, _) -> @@ -1148,6 +1137,7 @@ configuredPackageProblems -- It simply means preferences for installed packages will be ignored. resolveWithoutDependencies :: DepResolverParams + -> InstalledPackageIndex -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies ( DepResolverParams @@ -1155,13 +1145,12 @@ resolveWithoutDependencies constraints prefs defpref - installedPkgIndex + installedPkgIndexM sourcePkgIndex _reorderGoals _countConflicts _fineGrained _minimizeConflictSet - _indGoals _avoidReinstalls _shadowing _strFlags @@ -1172,7 +1161,8 @@ resolveWithoutDependencies _onlyConstrained _order _verbosity - ) = + ) + installedPkgIndex = collectEithers $ map selectPackage (Set.toList targets) where selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage @@ -1197,6 +1187,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 @@ -1205,8 +1196,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/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs index 64140152453..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 @@ -44,13 +45,10 @@ 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 -- | Information which can be used to construct the path to -- the build directory of a build. This is LESS fine-grained @@ -58,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 @@ -123,7 +122,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 +188,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" @@ -198,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" @@ -287,11 +266,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/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/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 033d3a01e14..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 = @@ -197,7 +198,6 @@ planPackages then Nothing else Just maxBackjumps ) - . setIndependentGoals independentGoals . setReorderGoals reorderGoals . setCountConflicts countConflicts . setFineGrainedConflicts fineGrainedConflicts @@ -220,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 @@ -235,7 +235,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..d9c47bb6da9 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -51,7 +51,10 @@ 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 import Distribution.Package @@ -212,9 +215,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 @@ -226,7 +229,6 @@ planPackages then Nothing else Just maxBackjumps ) - . setIndependentGoals independentGoals . setReorderGoals reorderGoals . setCountConflicts countConflicts . setFineGrainedConflicts fineGrainedConflicts @@ -245,7 +247,7 @@ planPackages in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] - $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + $ standardInstallPolicy sourcePkgDb pkgSpecifiers logMsg message rest = debug verbosity message >> rest @@ -259,7 +261,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) @@ -286,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/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 675fbd6bca3..9ec38fe0412 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 @@ -141,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 @@ -585,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 @@ -597,7 +599,6 @@ planPackages then Nothing else Just maxBackjumps ) - . setIndependentGoals independentGoals . setReorderGoals reorderGoals . setCountConflicts countConflicts . setFineGrainedConflicts fineGrainedConflicts @@ -650,7 +651,6 @@ planPackages -- doesn't understand how to install them . setSolveExecutables (SolveExecutables False) $ standardInstallPolicy - installedPkgIndex sourcePkgDb pkgSpecifiers @@ -667,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) @@ -716,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 df719fa5926..66534cdc1d2 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,22 +28,23 @@ module Distribution.Client.InstallPlan , PlanPackage , GenericPlanPackage (..) , foldPlanPackage - , IsUnit + , renderPlanPackageTag -- * Operations on 'InstallPlan's , new + , new' , toGraph , toList , toMap , keys , keysSet - , planIndepGoals , depends , fromSolverInstallPlan , fromSolverInstallPlanWithProgress , configureInstallPlan , remove , installed + , installedM , lookup , directDeps , revDirectDeps @@ -59,16 +63,19 @@ module Distribution.Client.InstallPlan , failed -- * Display - , showPlanGraph + , renderPlanGraph , ShowPlanNode (..) , showInstallPlan , showInstallPlan_gen - , showPlanPackageTag + , PlanProblem + , renderPlanProblem + , renderPlanProblems -- * Graph-like operations , dependencyClosure , reverseTopologicalOrder , reverseDependencyClosure + , IsGraph (..) ) where import Distribution.Client.Compat.Prelude hiding (lookup, toList) @@ -90,15 +97,12 @@ import Distribution.Package ( HasMungedPackageId (..) , HasUnitId (..) , Package (..) - , UnitId ) -import Distribution.Pretty (defaultStyle) import Distribution.Solver.Types.SolverPackage 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 @@ -110,11 +114,16 @@ 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.List.NonEmpty as NE 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. @@ -173,38 +182,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 @@ -215,11 +219,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) @@ -253,32 +252,44 @@ 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)) - , planIndepGoals :: !IndependentGoals } +type GenericInstallPlan ipkg srcpkg = GenericInstallPlan' (GraphKey ipkg srcpkg) ipkg srcpkg + -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) --- | Smart constructor that deals with caching the 'Graph' representation. -mkInstallPlan - :: (IsUnit ipkg, IsUnit srcpkg) - => String - -> Graph (GenericPlanPackage ipkg srcpkg) - -> IndependentGoals - -> GenericInstallPlan ipkg srcpkg -mkInstallPlan loc graph indepGoals = - assert - (valid loc graph) - GenericInstallPlan - { planGraph = graph - , planIndepGoals = indepGoals - } - internalError :: WithCallStack (String -> String -> a) internalError loc msg = error $ @@ -286,7 +297,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) @@ -297,39 +311,36 @@ 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 - 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 + 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 @@ -340,7 +351,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 @@ -349,25 +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} + +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 valid set of resolved packages. +-- | Build an installation plan from a set of packages. new - :: (IsUnit ipkg, IsUnit srcpkg) - => IndependentGoals - -> Graph (GenericPlanPackage ipkg srcpkg) - -> GenericInstallPlan ipkg srcpkg -new indepGoals graph = mkInstallPlan "new" graph indepGoals + :: ( 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) + -> LogProgress (GenericInstallPlan ipkg srcpkg) +new' = eitherToLogProgress . mkInstallPlan toGraph :: GenericInstallPlan ipkg srcpkg @@ -381,13 +430,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 @@ -396,16 +445,15 @@ 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 + -> Either (NonEmpty (PlanProblem ipkg srcpkg)) (GenericInstallPlan' (Key srcpkg) ipkg srcpkg) remove shouldRemove plan = - mkInstallPlan "remove" newGraph (planIndepGoals plan) - 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. @@ -413,7 +461,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 @@ -432,11 +480,31 @@ 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 + :: (IsGraph ipkg 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) + :: IsGraph ipkg srcpkg => GenericInstallPlan ipkg srcpkg - -> UnitId + -> GraphKey ipkg srcpkg -> Maybe (GenericPlanPackage ipkg srcpkg) lookup plan pkgid = Graph.lookup pkgid (planGraph plan) @@ -445,7 +513,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 @@ -457,7 +525,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 @@ -480,7 +548,7 @@ reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) -- the given packages. dependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] dependencyClosure plan = fromMaybe [] @@ -490,7 +558,7 @@ dependencyClosure plan = -- given packages. reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg - -> [UnitId] + -> [GraphKey ipkg srcpkg] -> [GenericPlanPackage ipkg srcpkg] reverseDependencyClosure plan = fromMaybe [] @@ -510,7 +578,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] @@ -518,39 +590,17 @@ fromSolverInstallPlan -> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = - mkInstallPlan - "fromSolverInstallPlan" - (Graph.fromDistinctList pkgs'') - (SolverInstallPlan.planIndepGoals plan) - 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) + :: ( IsGraph ipkg srcpkg + , Pretty (GraphKey ipkg srcpkg) + , Show (GraphKey ipkg srcpkg) + ) => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage -> LogProgress [GenericPlanPackage ipkg srcpkg] @@ -558,35 +608,22 @@ 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'') - (SolverInstallPlan.planIndepGoals plan) + new' (Graph.fromDistinctList pkgs'') where - f' (pidMap, ipiMap, pkgs) pkg = 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) - return (pidMap', ipiMap', pkgs' ++ pkgs) - - 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). + 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). + mapDep pMap key = fromMaybe (error ("fromSolverInstallPlanWithProgress: " ++ prettyShow key)) (Map.lookup key pMap) -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' @@ -672,7 +709,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 @@ -685,9 +722,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) @@ -713,11 +754,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') $ @@ -748,11 +789,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)) $ @@ -777,9 +818,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 @@ -858,7 +903,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 = @@ -880,15 +925,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. -- @@ -906,29 +951,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 @@ -955,11 +1001,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 @@ -997,83 +1044,123 @@ 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 - :: (IsUnit ipkg, IsUnit 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) [UnitId] - | PackageCycle [GenericPlanPackage ipkg srcpkg] + = PackageMissingDeps + (GenericPlanPackage ipkg srcpkg) + -- ^ The package that is missing dependencies + (NonEmpty (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 - :: (IsUnit ipkg, IsUnit srcpkg) +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 $ NE.toList 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. -- Use 'showPlanProblem' for a human readable explanation. problems - :: (IsUnit ipkg, IsUnit srcpkg) + :: IsGraph ipkg srcpkg => 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 - (fmap nodeKey . flip Graph.lookup graph) - missingDeps - ) + missingDeps | (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 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/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs index e8975b0fc57..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 } @@ -219,7 +220,7 @@ data PackageHashConfigInputs = PackageHashConfigInputs , pkgHashExtraIncludeDirs :: [FilePath] , pkgHashProgPrefix :: Maybe PathTemplate , pkgHashProgSuffix :: Maybe PathTemplate - , pkgHashPackageDbs :: [Maybe PackageDBCWD] + , pkgHashPackageDbs :: [PackageDBCWD] , -- Haddock options pkgHashDocumentation :: Bool , pkgHashHaddockHoogle :: Bool @@ -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 7bf6de869a5..e929f4fa32a 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 #-} @@ -57,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 @@ -71,7 +71,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 (..)) @@ -97,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 ------------------------------------------------------------------------------ @@ -259,21 +259,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 +303,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 -> @@ -335,26 +340,67 @@ 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@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + sharedPackageConfig pkgsBuildStatus buildSettings@BuildTimeSettings { 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 " @@ -365,11 +411,11 @@ 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. - 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 @@ -382,56 +428,53 @@ 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 uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus - - rebuildTarget - verbosity - distDirLayout - storeDirLayout - (jobControlSemaphore jobControl) - buildSettings - downloadMap - registerLock - cacheLock - sharedPackageConfig - installPlan - pkg - pkgBuildStatus + let pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") (nodeKey pkg) pkgsBuildStatus + act downloadMap jobControl pkg pkgBuildStatus where keepGoing = buildSettingKeepGoing withRepoCtx = 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 () 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 @@ -457,25 +500,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 @@ -518,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 @@ -561,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 @@ -576,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 @@ -592,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 @@ -608,6 +636,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? @@ -642,8 +687,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..8a54b494f76 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs @@ -25,8 +25,9 @@ import Prelude () import Distribution.Client.FileMonitor (MonitorChangedReason (..)) 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.Package (PackageId, UnitId) import Distribution.Simple.LocalBuildInfo (ComponentName) ------------------------------------------------------------------------------ @@ -36,7 +37,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 +136,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. @@ -160,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 diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs index e19c52157c0..63270d85448 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,8 @@ 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: -- @@ -176,26 +178,26 @@ buildAndRegisterUnpackedPackage buildTimeSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingKeepTempFiles} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir 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 @@ -203,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. @@ -221,8 +226,8 @@ buildAndRegisterUnpackedPackage criticalSection registerLock $ Cabal.registerPackage verbosity - compiler - progdb + toolchainCompiler + toolchainProgramDb Nothing (coercePackageDBStack pkgDBStack) ipkg @@ -234,27 +239,33 @@ 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 () 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 +461,7 @@ buildInplaceUnpackedPackage buildSettings@BuildTimeSettings{buildSettingHaddockOpen} registerLock cacheLock - pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = Platform _ os} + pkgshared plan rpkg@(ReadyPackage pkg) buildStatus @@ -597,6 +608,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 @@ -617,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 -------------------------------------------------------------------------------- @@ -648,17 +664,12 @@ buildAndInstallUnpackedPackage buildAndInstallUnpackedPackage verbosity distDirLayout - storeDirLayout@StoreDirLayout - { storePackageDBStack - } + storeDirLayout maybe_semaphore buildSettings@BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} registerLock cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigPlatform = platform - } + pkgshared plan rpkg@(ReadyPackage pkg) srcdir @@ -710,11 +721,8 @@ buildAndInstallUnpackedPackage "registerPkg: elab does NOT require registration for " ++ prettyShow uid | otherwise = do - assert - ( elabRegisterPackageDBStack pkg - == storePackageDBStack compiler (elabPackageDbs pkg) - ) - (return ()) + let packageDbStack = elabPackageDbs pkg ++ [storePackageDB storeDirLayout toolchainCompiler] + assert (elabRegisterPackageDBStack pkg == packageDbStack) (return ()) _ <- runRegister (elabRegisterPackageDBStack pkg) @@ -729,7 +737,7 @@ buildAndInstallUnpackedPackage newStoreEntry verbosity storeDirLayout - compiler + toolchainCompiler uid (copyPkgFiles verbosity pkgshared pkg runCopy) registerPkg @@ -767,6 +775,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 @@ -791,7 +802,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/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index 32d8048b2b5..3b2b7e886cd 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 (..) @@ -391,7 +392,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 +414,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, @@ -1399,7 +1398,6 @@ mplusMaybeT ma mb = do fetchAndReadSourcePackages :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> [ProjectPackageLocation] @@ -1407,7 +1405,6 @@ fetchAndReadSourcePackages fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations = do @@ -1444,7 +1441,6 @@ fetchAndReadSourcePackages syncAndReadSourcePackagesRemoteRepos verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) @@ -1563,7 +1559,6 @@ fetchAndReadSourcePackageRemoteTarball syncAndReadSourcePackagesRemoteRepos :: Verbosity -> DistDirLayout - -> Maybe Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly -> Bool @@ -1572,7 +1567,6 @@ syncAndReadSourcePackagesRemoteRepos syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory} - compiler ProjectConfigShared { projectConfigProgPathExtra } @@ -1607,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/ProjectConfig/FieldGrammar.hs b/cabal-install/src/Distribution/Client/ProjectConfig/FieldGrammar.hs index 591bf0ba03d..bbae09b7b9a 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 @@ -104,11 +108,22 @@ 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 +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 + <*> 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 = mkPackageConfig diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 32b3670b479..18f8f6aed64 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,17 +716,17 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , globalStoreDir = projectConfigStoreDir } = globalFlags + projectConfigToolchain = ProjectConfigToolchain{..} projectConfigPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigPackageDBs_ + projectConfigBuildPackageDBs = (fmap . fmap) (interpretPackageDB Nothing) projectConfigBuildPackageDBs_ ConfigFlags { configCommonFlags = commonFlags , configHcFlavor = projectConfigHcFlavor , configHcPath = projectConfigHcPath , configHcPkg = projectConfigHcPkg - , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME - configInstallDirs = projectConfigInstallDirs - , -- configUserInstall = projectConfigUserInstall, - configPackageDBs = projectConfigPackageDBs_ + , configInstallDirs = projectConfigInstallDirs + , configPackageDBs = projectConfigPackageDBs_ } = configFlags CommonSetupFlags @@ -744,6 +744,10 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = projectConfigBuildPackageDBs_ } = configExFlags InstallFlags @@ -759,7 +763,6 @@ convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags , installFineGrainedConflicts = projectConfigFineGrainedConflicts , installMinimizeConflictSet = projectConfigMinimizeConflictSet , installPerComponent = projectConfigPerComponent - , installIndependentGoals = projectConfigIndependentGoals , installPreferOldest = projectConfigPreferOldest , -- installShadowPkgs = projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags @@ -966,10 +969,7 @@ convertToLegacySharedConfig ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly{..} , projectConfigShared = ProjectConfigShared{..} - , projectConfigAllPackages = - PackageConfig - { packageConfigDocumentation - } + , projectConfigAllPackages = PackageConfig{..} } = LegacySharedConfig { legacyGlobalFlags = globalFlags @@ -981,6 +981,7 @@ convertToLegacySharedConfig , legacyMultiRepl = projectConfigMultiRepl } where + ProjectConfigToolchain{..} = projectConfigToolchain globalFlags = GlobalFlags { globalVersion = mempty @@ -1025,6 +1026,10 @@ convertToLegacySharedConfig , configAllowNewer = projectConfigAllowNewer , configWriteGhcEnvironmentFilesPolicy = projectConfigWriteGhcEnvironmentFilesPolicy + , configBuildHcFlavor = projectConfigBuildHcFlavor + , configBuildHcPath = projectConfigBuildHcPath + , configBuildHcPkg = projectConfigBuildHcPkg + , configBuildPackageDBs = fmap (fmap (fmap unsafeMakeSymbolicPath)) projectConfigBuildPackageDBs } installFlags = @@ -1043,7 +1048,6 @@ convertToLegacySharedConfig , installCountConflicts = projectConfigCountConflicts , installFineGrainedConflicts = projectConfigFineGrainedConflicts , installMinimizeConflictSet = projectConfigMinimizeConflictSet - , installIndependentGoals = projectConfigIndependentGoals , installPreferOldest = projectConfigPreferOldest , installShadowPkgs = mempty -- projectConfigShadowPkgs, , installStrongFlags = projectConfigStrongFlags @@ -1087,6 +1091,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 03e05835cd6..9a3897f5432 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) @@ -44,7 +53,6 @@ import Distribution.Solver.Types.Settings ( AllowBootLibInstalls (..) , CountConflicts (..) , FineGrainedConflicts (..) - , IndependentGoals (..) , MinimizeConflictSet (..) , OnlyConstrained (..) , PreferOldest (..) @@ -180,10 +188,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 #-} @@ -192,18 +196,42 @@ 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 #-} + +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 #-} @@ -212,10 +240,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 220834a331c..0246680077b 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. @@ -228,7 +226,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 @@ -242,6 +239,18 @@ data ProjectConfigShared = ProjectConfigShared } deriving (Eq, Show, Generic) +data ProjectConfigToolchain = ProjectConfigToolchain + { projectConfigHcFlavor :: Flag CompilerFlavor + , 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) + data ProjectFileParser = LegacyParser | ParsecParser @@ -343,6 +352,7 @@ data PackageConfig = PackageConfig instance Binary ProjectConfig instance Binary ProjectConfigBuildOnly +instance Binary ProjectConfigToolchain instance Binary ProjectConfigShared instance Binary ProjectConfigProvenance instance Binary PackageConfig @@ -350,6 +360,7 @@ instance Binary ProjectFileParser instance Structured ProjectConfig instance Structured ProjectConfigBuildOnly +instance Structured ProjectConfigToolchain instance Structured ProjectConfigShared instance Structured ProjectConfigProvenance instance Structured PackageConfig @@ -401,6 +412,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 = (<>) @@ -449,7 +467,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/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index d0dfb10601e..233347544e7 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,12 +104,14 @@ module Distribution.Client.ProjectOrchestration -- * Dummy projects , establishDummyProjectBaseContext , establishDummyDistDirLayout + , filterTargetsWithStage ) where import Distribution.Client.Compat.Prelude import Distribution.Compat.Directory ( makeAbsolute ) +import qualified Distribution.Compat.Graph as Graph import Prelude () import Distribution.Client.ProjectBuilding @@ -135,12 +139,9 @@ import Distribution.Client.TargetSelector , reportTargetSelectorProblems ) import Distribution.Client.Types - ( DocsResult (..) - , GenericReadyPackage (..) - , PackageLocation (..) + ( GenericReadyPackage (..) , PackageSpecifier (..) , SourcePackageDb (..) - , TestsResult (..) , UnresolvedSourcePackage , WriteGhcEnvironmentFilesPolicy (..) ) @@ -149,26 +150,15 @@ 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 ) -import Distribution.Types.InstalledPackageInfo - ( InstalledPackageInfo - ) import Distribution.Types.UnqualComponentName ( UnqualComponentName , packageNameToUnqualComponentName + , unUnqualComponentName ) import Distribution.PackageDescription.Configuration @@ -184,9 +174,6 @@ import Distribution.Package import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Compiler ( OptimisationLevel (..) - , compilerCompatVersion - , compilerId - , compilerInfo , showCompilerId ) import Distribution.Simple.Configure (computeEffectiveProfiling) @@ -204,27 +191,26 @@ import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose , debugNoWrap , dieWithException + , infoNoWrap + , installExecutableFile , notice , noticeNoWrap , ordNub , warn ) -import Distribution.System - ( Platform (Platform) - ) import Distribution.Types.Flag ( FlagAssignment , diffFlagAssignment , showFlagAssignment ) +import Distribution.Utils.LogProgress + ( LogProgress + ) import Distribution.Utils.NubList ( fromNubList ) -import Distribution.Utils.Path (makeSymbolicPath) +import Distribution.Utils.Path (makeSymbolicPath, ()) import Distribution.Verbosity -import Distribution.Version - ( mkVersion - ) #ifdef MIN_VERSION_unix import System.Posix.Signals (sigKILL, sigSEGV) @@ -343,7 +329,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. } @@ -381,7 +367,7 @@ withInstallPlan runProjectPreBuildPhase :: Verbosity -> ProjectBaseContext - -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)) + -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMapS)) -> IO ProjectBuildContext runProjectPreBuildPhase verbosity @@ -487,8 +473,8 @@ runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _ return () runProjectPostBuildPhase verbosity - ProjectBaseContext{..} - bc@ProjectBuildContext{..} + baseCtx@ProjectBaseContext{..} + buildCtx@ProjectBuildContext{..} buildOutcomes = do -- Update other build artefacts -- TODO: currently none, but could include: @@ -505,6 +491,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 $ @@ -517,26 +505,50 @@ 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 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. @@ -569,12 +581,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. @@ -597,7 +619,7 @@ resolveTargetsFromSolver -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap + -> Either [TargetProblem err] TargetsMapS resolveTargetsFromSolver selectPackageTargets selectComponentTarget installPlan sourceDb targetSelectors = resolveTargets selectPackageTargets @@ -819,18 +841,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 (++) @@ -839,7 +861,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} `Map.union` availableTargetsEmptyPackages availableTargetsByPackageName - :: Map PackageName [AvailableTarget (UnitId, ComponentName)] + :: Map PackageName [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageName = Map.mapKeysWith (++) @@ -849,7 +871,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndComponentName :: Map (PackageName, ComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndComponentName = Map.mapKeysWith (++) @@ -859,7 +881,7 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} availableTargetsByPackageNameAndUnqualComponentName :: Map (PackageName, UnqualComponentName) - [AvailableTarget (UnitId, ComponentName)] + [AvailableTarget (WithStage UnitId, ComponentName)] availableTargetsByPackageNameAndUnqualComponentName = Map.mapKeysWith (++) @@ -1051,9 +1073,9 @@ selectComponentTargetBasic -- for the extra unneeded info in the 'TargetsMap'. pruneInstallPlanToTargets :: TargetAction - -> TargetsMap - -> ElaboratedInstallPlan + -> TargetsMapS -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan = assert (Map.size targetsMap > 0) $ ProjectPlanning.pruneInstallPlanToTargets @@ -1063,7 +1085,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) @@ -1133,6 +1155,7 @@ printPlan unwords $ filter (not . null) $ [ " -" + , prettyShow (elabStage elab) , if verbosity >= deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) @@ -1142,17 +1165,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 + , let buildStatus = pkgsBuildStatus Map.! Graph.nodeKey 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 +1183,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 @@ -1181,7 +1204,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 +1244,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 +1276,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 +1288,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. @@ -1356,7 +1381,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 @@ -1414,9 +1439,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 @@ -1440,16 +1466,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 = @@ -1463,7 +1488,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 @@ -1473,7 +1498,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" @@ -1481,7 +1506,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 @@ -1492,7 +1517,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 a4ce230d984..9e71be71140 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) @@ -76,6 +77,7 @@ import System.FilePath import System.IO import Distribution.Simple.Program.GHC (packageDbArgsDb) +import GHC.Stack (HasCallStack) ----------------------------------------------------------------------------- -- Writing plan.json files @@ -104,20 +106,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 @@ -133,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 @@ -142,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 @@ -157,7 +166,8 @@ 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 , "flags" @@ -188,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 ) @@ -200,12 +210,15 @@ 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)) ] ++ 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'. @@ -442,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 @@ -495,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. @@ -518,7 +531,8 @@ data PostBuildProjectStatus = PostBuildProjectStatus -- | Work out which packages are out of date or invalid after a build. postBuildProjectStatus - :: ElaboratedInstallPlan + :: HasCallStack + => ElaboratedInstallPlan -> PackagesUpToDate -> BuildStatusMap -> BuildOutcomes @@ -564,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)) @@ -576,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 @@ -604,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") $ @@ -615,19 +635,25 @@ postBuildProjectStatus ) -- The plan graph but only counting dependency-on-library edges - packagesLibDepGraph :: 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. @@ -644,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 @@ -658,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 @@ -666,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 @@ -675,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 @@ -804,11 +828,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,55 +850,42 @@ 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) - ( renderGhcEnvironmentFile - path - elaboratedInstallPlan - postBuildStatus - ) --- 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/ + toolchainPlatform + (compilerVersion toolchainCompiler) + env + else return Nothing + where + Toolchain{toolchainPlatform, toolchainCompiler} = getStage (pkgConfigToolchains elaboratedSharedConfig) stage -writePlanGhcEnvironment _ _ _ _ = return Nothing + 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" @@ -877,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 @@ -949,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" @@ -966,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 968b915ee2a..d4d7460bd20 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -36,12 +36,21 @@ 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 + , elabExeDependencies -- * Reading the project configuration -- $readingTheProjectConfiguration @@ -69,7 +78,7 @@ module Distribution.Client.ProjectPlanning -- * Utils required for building , pkgHasEphemeralBuildTargets , elabBuildTargetWholeComponents - , configureCompiler + , configureToolchains -- * Setup.hs CLI flags for building , setupHsScriptOptions @@ -95,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 @@ -126,7 +135,6 @@ import Distribution.Client.ProjectConfig.Types (defaultProjectFileParser) import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy ( NonSetupLibDepSolverPlanPackage (..) - , mkDefaultSetupDeps , packageSetupScriptSpecVersion , packageSetupScriptStyle ) @@ -136,8 +144,9 @@ 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) +import Distribution.Client.Utils (concatMapM) import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.IndexUtils as IndexUtils @@ -160,7 +169,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 @@ -176,7 +184,6 @@ import Distribution.Simple.LocalBuildInfo , pkgComponents ) -import Distribution.Simple.BuildWay import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Program import Distribution.Simple.Program.Db @@ -197,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 @@ -212,8 +219,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 @@ -224,14 +229,18 @@ 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 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 import qualified Text.PrettyPrint as Disp @@ -352,7 +361,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 @@ -380,8 +390,8 @@ rebuildProjectConfig return ( configPath , distProjectFile "" - , (projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg) , projectConfigProjectFileParser + , projectConfigToolchain , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -400,21 +410,23 @@ 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) + 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 + (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 return (projectConfig <> cliConfig, localPackages) where - ProjectConfigShared{projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile} = + ProjectConfigShared{projectConfigProjectFileParser, projectConfigIgnoreProject, projectConfigConfigFile, projectConfigToolchain} = projectConfigShared cliConfig PackageConfig{packageConfigProgramPaths, packageConfigProgramPathExtra} = @@ -435,11 +447,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 @@ -454,7 +464,6 @@ rebuildProjectConfig fetchAndReadSourcePackages verbosity distDirLayout - compiler projectConfigShared projectConfigBuildOnly pkgLocations @@ -500,12 +509,12 @@ rebuildProjectConfig $ projectConfigProvenance projectConfig ] -configureCompiler +configureToolchains :: Verbosity -> DistDirLayout -> ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) -configureCompiler + -> Rebuild Toolchains +configureToolchains verbosity DistDirLayout { distProjectCacheFile @@ -513,9 +522,17 @@ configureCompiler ProjectConfig { projectConfigShared = ProjectConfigShared - { projectConfigHcFlavor - , projectConfigHcPath - , projectConfigHcPkg + { projectConfigToolchain = + ProjectConfigToolchain + { projectConfigHcFlavor + , projectConfigHcPath + , projectConfigHcPkg + , projectConfigPackageDBs + , projectConfigBuildHcFlavor + , projectConfigBuildHcPath + , projectConfigBuildHcPkg + , projectConfigBuildPackageDBs + } , projectConfigProgPathExtra } , projectConfigLocalPackages = @@ -524,17 +541,54 @@ configureCompiler , packageConfigProgramPathExtra } } = do - let fileMonitorCompiler = newFileMonitor $ distProjectCacheFile "compiler" + let fileMonitorBuildCompiler = newFileMonitor $ distProjectCacheFile "build-compiler" + fileMonitorHostCompiler = newFileMonitor $ distProjectCacheFile "host-compiler" progsearchpath <- liftIO $ getSystemSearchPath - (hc, plat, hcProgDb) <- + (buildHc, buildPlat, buildHcProgDb) <- + rerunIfChanged + verbosity + fileMonitorBuildCompiler + ( buildHcFlavor + , buildHcPath + , buildHcPkg + , 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 + 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 - fileMonitorCompiler - ( hcFlavor - , hcPath - , hcPkg + fileMonitorHostCompiler + ( hostHcFlavor + , hostHcPath + , hostHcPkg , progsearchpath , packageConfigProgramPaths , packageConfigProgramPathExtra @@ -551,8 +605,8 @@ configureCompiler result@(_, _, progdb') <- liftIO $ Cabal.configCompiler - hcFlavor - hcPath + hostHcFlavor + hostHcPath progdb verbosity -- Note that we added the user-supplied program locations and args @@ -568,12 +622,32 @@ 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) + 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 - hcPath = flagToMaybe projectConfigHcPath - hcPkg = flagToMaybe projectConfigHcPkg + 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -633,7 +707,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 @@ -678,27 +753,30 @@ rebuildInstallPlan , progsearchpath ) $ do - compilerEtc <- phaseConfigureCompiler projectConfig - _ <- phaseConfigurePrograms projectConfig compilerEtc - (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <- + toolchains <- phaseConfigureToolchains projectConfig + phaseConfigurePrograms projectConfig toolchains + (solverPlan, _, pkgConfigDBs, totalIndexState, activeRepos) <- phaseRunSolver projectConfig - compilerEtc + toolchains localPackages (fromMaybe mempty mbInstalledPackages) - ( elaboratedPlan - , elaboratedShared - ) <- + + (elaboratedPlan, elaboratedShared) <- phaseElaboratePlan projectConfig - compilerEtc - 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. @@ -715,14 +793,20 @@ 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. -- - phaseConfigureCompiler + phaseConfigureToolchains :: ProjectConfig - -> Rebuild (Compiler, Platform, ProgramDb) - 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. -- @@ -738,17 +822,18 @@ rebuildInstallPlan -- phaseConfigurePrograms :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> Toolchains -> Rebuild () - phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = 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 compilerprogdb) - (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. @@ -761,43 +846,42 @@ rebuildInstallPlan -- phaseRunSolver :: ProjectConfig - -> (Compiler, Platform, ProgramDb) + -> 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 } - (compiler, platform, progdb) + 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 (getInstalledPackages verbosity) + 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,23 +894,25 @@ 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 - corePackageDbs :: PackageDBStackCWD - corePackageDbs = - Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared) + compilerAndPlatform = + fmap + (\Toolchain{toolchainCompiler, toolchainPlatform} -> (compilerInfo toolchainCompiler, toolchainPlatform)) + toolchains withRepoCtx :: (RepoContext -> IO a) -> IO a withRepoCtx = @@ -874,9 +960,10 @@ rebuildInstallPlan -- version of the plan has the final nix-style hashed ids. -- phaseElaboratePlan - :: ProjectConfig - -> (Compiler, Platform, ProgramDb) - -> Maybe PkgConfigDb + :: HasCallStack + => ProjectConfig + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Rebuild @@ -891,7 +978,7 @@ rebuildInstallPlan , projectConfigSpecificPackage , projectConfigBuildOnly } - (compiler, platform, progdb) + toolchains pkgConfigDB solverPlan localPackages = do @@ -904,15 +991,16 @@ rebuildInstallPlan (packageLocationsSignature solverPlan) $ getPackageSourceHashes verbosity withRepoCtx solverPlan - defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) - (elaboratedPlan, elaboratedShared) <- - liftIO . runLogProgress verbosity $ + 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 verbosity - platform - compiler - progdb + toolchains pkgConfigDB distDirLayout cabalStoreDirLayout @@ -924,14 +1012,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 = @@ -971,11 +1062,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 +1070,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. @@ -1036,44 +1125,28 @@ 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 - -> ProgramDb - -> Platform - -> PackageDBStackCWD + -> Toolchain -> Rebuild InstalledPackageIndex -getInstalledPackages verbosity compiler progdb platform packagedbs = do - monitorFiles . map monitorFileOrDirectory +getInstalledPackages verbosity Toolchain{..} = do + monitorFiles + . map monitorFileOrDirectory =<< liftIO ( IndexUtils.getInstalledPackagesMonitorFiles verbosity - compiler + toolchainCompiler Nothing -- use ambient working directory - (coercePackageDBStack packagedbs) - progdb - platform + (coercePackageDBStack toolchainPackageDBs) + toolchainProgramDb + toolchainPlatform ) liftIO $ IndexUtils.getInstalledPackages verbosity - compiler - packagedbs - progdb + toolchainCompiler + toolchainPackageDBs + toolchainProgramDb {- --TODO: [nice to have] use this but for sanity / consistency checking @@ -1101,9 +1174,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 @@ -1226,8 +1300,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 -> @@ -1305,30 +1379,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 - platform - (compilerInfo comp) - pkgConfigDB - 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 @@ -1336,7 +1404,6 @@ planPackages resolverParams :: DepResolverParams resolverParams = setMaxBackjumps solverSettingMaxBackjumps - . setIndependentGoals solverSettingIndependentGoals . setReorderGoals solverSettingReorderGoals . setCountConflicts solverSettingCountConflicts . setFineGrainedConflicts solverSettingFineGrainedConflicts @@ -1368,13 +1435,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 @@ -1398,7 +1470,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) @@ -1447,84 +1521,9 @@ planPackages -- Note: we don't use the standardInstallPolicy here, since that uses -- its own addDefaultSetupDependencies that is not appropriate for us. basicInstallPolicy - installedPkgIndex - 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 @@ -1629,17 +1628,16 @@ 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 - -> Platform - -> Compiler - -> ProgramDb - -> Maybe PkgConfigDb + :: HasCallStack + => Verbosity + -> Staged Toolchain + -> Staged (Maybe PkgConfigDb) -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Map PackageId PackageSourceHash - -> InstallDirs.InstallDirTemplates + -> Staged InstallDirs.InstallDirTemplates -> ProjectConfigShared -> PackageConfig -> PackageConfig @@ -1647,12 +1645,10 @@ elaborateInstallPlan -> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig) elaborateInstallPlan verbosity - platform - compiler - compilerprogdb + toolchains pkgConfigDB distDirLayout@DistDirLayout{..} - storeDirLayout@StoreDirLayout{storePackageDBStack} + storeDirLayout solverPlan localPackages sourcePackageHashes @@ -1666,9 +1662,7 @@ elaborateInstallPlan where elaboratedSharedConfig = ElaboratedSharedConfig - { pkgConfigPlatform = platform - , pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = compilerprogdb + { pkgConfigToolchains = toolchains , pkgConfigReplOptions = mempty } @@ -1688,13 +1682,12 @@ elaborateInstallPlan ) f _ = Nothing - elaboratedInstallPlan - :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage) + elaboratedInstallPlan :: HasCallStack => 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" @@ -1710,346 +1703,400 @@ 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) = - case mkComponentsGraph (elabEnabledSpec elab0) pd of - Right g -> do - let src_comps = componentsGraphToList g - infoProgress $ - hang - (text "Component graph for" <+> pretty pkgid <<>> colon) - 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 -> do - elaborationWarnings - 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, elaborationWarnings) = 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" - , elabLinkedInstantiatedWith = Map.empty - , elabInstallDirs = notImpl "elabInstallDirs" - , elabPkgOrComp = ElabComponent (ElaboratedComponent{..}) - } - | otherwise = - Nothing - where - compSolverName = CD.ComponentSetup - compComponentName = Nothing - - dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 - - compLibDependencies = - -- MP: No idea what this function does - map (\cid -> (configuredId cid, False)) dep_pkgs - compLinkedLibDependencies = notImpl "compLinkedLibDependencies" - compOrderLibDependencies = notImpl "compOrderLibDependencies" - - -- Not supported: - compExeDependencies :: [a] - compExeDependencies = [] - - compExeDependencyPaths :: [a] - compExeDependencyPaths = [] - - compPkgConfigDependencies :: [a] - compPkgConfigDependencies = [] - - notImpl f = - error $ - "Distribution.Client.ProjectPlanning.setupComponent: " - ++ f - ++ " not implemented yet" - - buildComponent - :: ( ConfiguredComponentMap - , LinkedComponentMap - , Map ComponentId FilePath - ) - -> Cabal.Component - -> LogProgress - ( ( ConfiguredComponentMap - , LinkedComponentMap - , 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 - -- 1. Configure the component, but with a place holder ComponentId. - 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) - 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 = - map - annotatedIdToConfiguredId - (cc_exe_deps cc0) - compExeDependencyPaths = - [ (annotatedIdToConfiguredId aid', path) - | aid' <- cc_exe_deps cc0 - , Just paths <- [Map.lookup (ann_id aid') exe_map1] - , path <- paths - ] - elab_comp = ElaboratedComponent{..} - - -- 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 + $ 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 + ] + + 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) + } } - cid = case elabBuildStyle elab0 of - BuildInplaceOnly{} -> - mkComponentId $ - prettyShow pkgid - ++ "-inplace" - ++ ( case Cabal.componentNameString cname of - Nothing -> "" - Just s -> "-" ++ prettyShow s - ) - BuildAndInstall -> - hashedInstalledPackageId - ( packageHashInputs + elab = + elab2 + { elabInstallDirs = + computeInstallDirs + storeDirLayout + defaultInstallDirs elaboratedSharedConfig - elab1 -- knot tied - ) - cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)} - infoProgress $ 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 <- - toLinkedComponent - verbosity - False - lookup_uid - (elabPkgSourceId elab0) - (Map.union external_lc_map lc_map) - cc - infoProgress $ 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 - -- instantiated packages. - - -- 5. Construct the final ElaboratedConfiguredPackage - let - elab2 = - elab1 - { elabModuleShape = lc_shape lc - , elabUnitId = abstractUnitId (lc_uid lc) - , elabComponentId = lc_cid lc - , elabLinkedInstantiatedWith = Map.fromList (lc_insts 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) - ) - } - } - elab = - elab2 - { elabInstallDirs = - computeInstallDirs - storeDirLayout - defaultInstallDirs - elaboratedSharedConfig - elab2 - } + 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 - compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies" - compOrderLibDependencies = error "buildComponent: compOrderLibDependencies" - - cname = Cabal.componentName comp - 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_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_map = - Map.fromList $ - [ (getComponentId pkg, paths) - | pkg <- external_exe_dep_pkgs - , let paths = planPackageExePaths pkg + 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_exe_dep_pkgs = concatMap mapDep $ CD.select (== compSolverName) solverPkgExeDeps + + 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 ++ concatMap mapDep external_exe_dep_sids - - compPkgConfigDependencies = - [ ( pn - , fromMaybe - ( error $ - "compPkgConfigDependencies: impossible! " - ++ prettyShow pn - ++ " from " - ++ prettyShow (elabPkgSourceId elab0) - ) - (pkgConfigDB >>= \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 @@ -2100,30 +2147,25 @@ elaborateInstallPlan -> LogProgress ElaboratedConfiguredPackage elaborateSolverToPackage pkgWhyNotPerComponent - pkg@( SolverPackage - (SourcePackage pkgid _gpd _srcloc _descOverride) - _flags - _stanzas - _deps0 - _exe_deps0 - ) + solverPkg@SolverPackage{solverPkgSource = SourcePackage{srcpkgPackageId}} compGraph comps = do -- 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) = - elaborateSolverToCommon pkg + elab0@ElaboratedConfiguredPackage + { elabPkgSourceHash + , elabStanzasRequested + , elabStage + } = elaborateSolverToCommon solverPkg elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId , elabComponentId = pkgInstalledId - , elabLinkedInstantiatedWith = Map.empty - , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..} + , elabPkgOrComp = ElabPackage elabPkg , elabModuleShape = modShape } @@ -2142,8 +2184,8 @@ elaborateInstallPlan Just e -> Ty.elabModuleShape e pkgInstalledId - | shouldBuildInplaceOnly pkg = - mkComponentId (prettyShow pkgid ++ "-inplace") + | shouldBuildInplaceOnly solverPkg = + mkComponentId (prettyShow srcpkgPackageId) | otherwise = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId @@ -2154,34 +2196,44 @@ 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) - - pkgLibDependencies = - buildComponentDeps (filterExt' . compLibDependencies) - pkgExeDependencies = - buildComponentDeps (filterExt . compExeDependencies) - pkgExeDependencyPaths = - buildComponentDeps (filterExt' . compExeDependencyPaths) - - -- TODO: Why is this flat? - pkgPkgConfigDependencies = - CD.flatDeps $ buildComponentDeps compPkgConfigDependencies + isExternal confid = confSrcId confid /= srcpkgPackageId + isExternal' (WithStage stage confId) = stage /= elabStage || isExternal confId + + 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, [()]) - | 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 = @@ -2190,60 +2242,69 @@ 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, LogProgress ()) + -> ElaboratedConfiguredPackage elaborateSolverToCommon - pkg@( SolverPackage - (SourcePackage pkgid gdesc srcloc descOverride) - flags - stanzas - deps0 - _exe_deps0 - ) = - (elaboratedPackage, wayWarnings pkgid) + solverPkg@SolverPackage + { solverPkgStage + , solverPkgSource = + SourcePackage + { srcpkgPackageId + , srcpkgDescription + , srcpkgSource + , srcpkgDescrOverride + } + , solverPkgFlags + , solverPkgStanzas + , solverPkgLibDeps + } = + 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 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" elabIsCanonical = True - elabPkgSourceId = pkgid - elabPkgDescription = case PD.finalizePD - flags - elabEnabledSpec - (const Satisfied) - platform - (compilerInfo compiler) - [] - gdesc of - Right (desc, _) -> desc - Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" - elabFlagAssignment = flags + elabPkgSourceId = srcpkgPackageId + + elabStage = solverPkgStage + elabCompiler = getStage compilers elabStage + 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" + + 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 @@ -2257,8 +2318,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 @@ -2276,7 +2337,7 @@ elaborateInstallPlan elabHaddockTargets = [] elabBuildHaddocks = - perPkgOptionFlag pkgid False packageConfigDocumentation + perPkgOptionFlag srcpkgPackageId False packageConfigDocumentation -- `documentation: true` should imply `-haddock` for GHC addHaddockIfDocumentationEnabled :: ConfiguredProgram -> ConfiguredProgram @@ -2285,77 +2346,89 @@ elaborateInstallPlan then cp{programOverrideArgs = "-haddock" : programOverrideArgs} else cp - elabPkgSourceLocation = srcloc - elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes - elabLocalToProject = isLocalToProject pkg + elabPkgSourceLocation = srcpkgSource + + elabPkgSourceHash = Map.lookup srcpkgPackageId sourcePackageHashes + + elabLocalToProject = isLocalToProject solverPkg + elabBuildStyle = - if shouldBuildInplaceOnly pkg + if shouldBuildInplaceOnly solverPkg then BuildInplaceOnly OnDisk else BuildAndInstall - elabPackageDbs = projectConfigPackageDBs sharedPackageConfig - elabBuildPackageDBStack = buildAndRegisterDbs - elabRegisterPackageDBStack = buildAndRegisterDbs + + elabPackageDbs = getStage packageDbs elabStage + elabBuildPackageDBStack = buildAndRegisterDbs elabStage + elabRegisterPackageDBStack = buildAndRegisterDbs elabStage elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + elabSetupScriptCliVersion = packageSetupScriptSpecVersion elabSetupScriptStyle elabPkgDescription libDepGraph - deps0 - elabSetupPackageDBStack = buildAndRegisterDbs + solverPkgLibDeps + + 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)))] - elabInplaceBuildPackageDBStack = inplacePackageDbs - elabInplaceRegisterPackageDBStack = inplacePackageDbs - elabInplaceSetupPackageDBStack = inplacePackageDbs + -- 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)] - buildAndRegisterDbs - | shouldBuildInplaceOnly pkg = inplacePackageDbs - | otherwise = corePackageDbs + elabInplaceBuildPackageDBStack = inplacePackageDbs elabStage + elabInplaceRegisterPackageDBStack = inplacePackageDbs elabStage + elabInplaceSetupPackageDBStack = inplacePackageDbs (prevStage elabStage) - elabPkgDescriptionOverride = descOverride + buildAndRegisterDbs stage + | shouldBuildInplaceOnly solverPkg = inplacePackageDbs stage + | otherwise = corePackageDbs stage + + elabPkgDescriptionOverride = srcpkgDescrOverride elabBuildOptions = LBC.BuildOptions - { withVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively - , withSharedLib = canBuildSharedLibs && 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 = canBuildProfilingLibs && pkgid `Set.member` pkgsUseProfilingLibrary - , withProfLibShared = canBuildProfilingSharedLibs && 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 compiler - profExe = perPkgOptionFlag pkgid False packageConfigProf + okProfDyn = profilingDynamicSupportedOrUnknown elabCompiler + 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 @@ -2365,59 +2438,63 @@ elaborateInstallPlan elabProgramPaths = Map.fromList [ (programId prog, programPath prog) - | prog <- configuredPrograms compilerprogdb + | prog <- configuredPrograms elabProgramDb ] - <> perPkgOptionMapLast pkgid packageConfigProgramPaths + <> perPkgOptionMapLast srcpkgPackageId packageConfigProgramPaths + elabProgramArgs = Map.unionWith (++) ( 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 - 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 + (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 + + 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 @@ -2434,7 +2511,6 @@ elaborateInstallPlan where exe = fromFlagOrDefault def bothflag lib = fromFlagOrDefault def (bothflag <> libflag) - bothflag = lookupPerPkgOption pkgid fboth libflag = lookupPerPkgOption pkgid flib @@ -2457,12 +2533,6 @@ elaborateInstallPlan mempty perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig) - inplacePackageDbs = - corePackageDbs - ++ [distPackageDB (compilerId compiler)] - - corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig) - -- 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 @@ -2470,16 +2540,18 @@ 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 $ - map packageId $ - SolverInstallPlan.reverseDependencyClosure - solverPlan - (map PlannedId (Set.toList pkgsLocalToProject)) + Set.fromList + [ solverId pkg + | spkg <- SolverInstallPlan.toList solverPlan + , packageId spkg `elem` pkgsLocalToProject + , pkg <- SolverInstallPlan.reverseDependencyClosure solverPlan [solverId spkg] + ] isLocalToProject :: Package pkg => pkg -> Bool isLocalToProject pkg = @@ -2499,7 +2571,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 @@ -2510,7 +2584,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 @@ -2522,53 +2596,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 @@ -2580,7 +2613,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 @@ -2589,7 +2624,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 @@ -2610,6 +2645,7 @@ elaborateInstallPlan NonSetupLibDepSolverPlanPackage (SolverInstallPlan.toList solverPlan) + packagesWithLibDepsDownwardClosedProperty :: (PackageIdentifier -> Bool) -> Set PackageIdentifier packagesWithLibDepsDownwardClosedProperty property = Set.fromList . map packageId @@ -2634,14 +2670,17 @@ 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 (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. @@ -2667,15 +2706,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) @@ -2699,12 +2737,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)) ) @@ -2718,9 +2758,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 @@ -2762,13 +2801,13 @@ 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 :: 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 @@ -2778,6 +2817,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. @@ -2822,75 +2872,87 @@ 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 defaultInstallDirs elaboratedShared plan = - InstallPlan.new - (IndependentGoals False) - (Graph.fromDistinctList (Map.elems ready_map)) +instantiateInstallPlan + :: HasCallStack + => StoreDirLayout + -> Staged InstallDirs.InstallDirTemplates + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan +instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = do + InstallPlan.new (Map.elems ready_map) 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 - , elabInstantiatedWith = fmap fst insts - , 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)) - ) - } - } - 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 @@ -2899,112 +2961,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 - | not (Map.null (elabLinkedInstantiatedWith elab)) -> - indefiniteUnitId (elabComponentId elab) - >> return () + InstallPlan.Configured (elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) + | 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 @@ -3096,15 +3181,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 @@ -3127,27 +3214,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 = @@ -3181,7 +3270,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 @@ -3215,7 +3304,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 @@ -3223,7 +3312,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 -> @@ -3236,11 +3325,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 @@ -3350,13 +3439,13 @@ data TargetAction -- will prune differently depending on what is already installed (to -- implement "sticky" test suite enabling behavior). pruneInstallPlanToTargets - :: TargetAction - -> Map UnitId [ComponentTarget] - -> ElaboratedInstallPlan + :: HasCallStack + => TargetAction + -> Map (Graph.Key ElaboratedPlanPackage) [ComponentTarget] -> ElaboratedInstallPlan + -> LogProgress ElaboratedInstallPlan pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan = - InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan) - . Graph.fromDistinctList + InstallPlan.new -- We have to do the pruning in two passes . pruneInstallPlanPass2 . pruneInstallPlanPass1 @@ -3372,16 +3461,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 @@ -3392,7 +3481,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 = @@ -3405,7 +3494,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 @@ -3446,7 +3535,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 @@ -3455,7 +3545,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 @@ -3465,8 +3555,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] @@ -3505,25 +3595,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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -3573,7 +3659,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} = @@ -3604,7 +3690,7 @@ pruneInstallPlanPass1 pkgs availablePkgs = Set.fromList - [ installedUnitId pkg + [ Graph.nodeKey pkg | InstallPlan.PreExisting pkg <- pkgs ] @@ -3640,7 +3726,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 @@ -3648,8 +3734,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 @@ -3742,7 +3827,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 @@ -3757,11 +3842,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 @@ -3771,7 +3855,6 @@ pruneInstallPlanPass2 pkgs = , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] ] - hasReverseLibDeps :: Set UnitId hasReverseLibDeps = Set.fromList [ depid @@ -3779,7 +3862,6 @@ pruneInstallPlanPass2 pkgs = , depid <- elabOrderLibDependencies pkg ] - hasReverseExeDeps :: Set UnitId hasReverseExeDeps = Set.fromList [ depid @@ -3806,21 +3888,21 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = -- -- This is not always possible. pruneInstallPlanToDependencies - :: Set UnitId + :: HasCallStack + => Set (Graph.Key ElaboratedPlanPackage) -> ElaboratedInstallPlan -> Either CannotPruneDependencies - ElaboratedInstallPlan + (Graph.Graph ElaboratedPlanPackage) pruneInstallPlanToDependencies pkgTargets installPlan = assert ( all (isJust . InstallPlan.lookup installPlan) (Set.toList pkgTargets) ) - $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan)) - . checkBrokenDeps + $ checkBrokenDeps . Graph.fromDistinctList - . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets) + . filter (\pkg -> Graph.nodeKey pkg `Set.notMember` pkgTargets) . InstallPlan.toList $ installPlan where @@ -3840,7 +3922,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 @@ -3855,7 +3937,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan = newtype CannotPruneDependencies = CannotPruneDependencies [ ( ElaboratedPlanPackage - , [ElaboratedPlanPackage] + , NonEmpty ElaboratedPlanPackage ) ] deriving (Show) @@ -3901,18 +3983,18 @@ 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 = - [ (uid, srcid) - | (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) <- elabSetupLibDependencies elab ] , useDependenciesExclusive = True , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps - , useProgramDb = pkgConfigCompilerProgs , useDistPref = builddir , useLoggingHandle = Nothing -- this gets set later , useWorkingDir = Just srcdir @@ -3936,6 +4018,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. -- @@ -3997,20 +4083,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 @@ -4018,12 +4105,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, @@ -4043,7 +4133,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 @@ -4054,6 +4144,8 @@ setupHsConfigureFlags elab Cabal.ConfigFlags{..} where + Toolchain{toolchainCompiler} = getStage (pkgConfigToolchains sharedConfig) elabStage + Cabal.ConfigFlags { configVanillaLib , configSharedLib @@ -4080,7 +4172,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 @@ -4113,7 +4207,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 @@ -4138,29 +4232,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 @@ -4171,7 +4269,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 @@ -4182,7 +4280,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) = @@ -4346,13 +4446,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 -> [ @@ -4381,6 +4481,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 @@ -4443,33 +4545,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 @@ -4490,11 +4598,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 @@ -4541,22 +4649,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 @@ -4598,43 +4694,121 @@ 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 +-- 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..d2a5f186e18 --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Stage.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TypeFamilies #-} + +module Distribution.Client.ProjectPlanning.Stage + ( WithStage (..) + , Stage (..) + , HasStage (..) + , Staged (..) + ) 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 (..), Staged (..)) +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 6aa1065d20e..ea19684a7cc 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 @@ -22,7 +24,7 @@ module Distribution.Client.ProjectPlanning.Types , elabOrderLibDependencies , elabExeDependencies , elabOrderExeDependencies - , elabSetupDependencies + , elabSetupLibDependencies , elabPkgConfigDependencies , elabInplaceDependencyBuildCacheFiles , elabRequiresRegistration @@ -59,6 +61,15 @@ module Distribution.Client.ProjectPlanning.Types , componentOptionalStanza , componentTargetName + -- * Toolchain + , Toolchain (..) + , Toolchains + , Stage (..) + , Staged (..) + , WithStage (..) + , withStage + , HasStage (..) + -- * Setup script , SetupScriptStyle (..) ) where @@ -77,9 +88,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 +123,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 (..)) @@ -122,9 +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 @@ -134,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) @@ -155,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 @@ -163,7 +189,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)) @@ -178,15 +204,16 @@ 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 -- 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. @@ -203,8 +230,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 @@ -247,21 +272,21 @@ 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] + , 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 + -- 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 @@ -344,10 +369,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 @@ -494,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 @@ -527,23 +557,35 @@ elabConfiguredName verbosity elab Just (CLibName LMainLibName) -> "" Just cname -> prettyShow cname ++ " from " ) - ++ prettyShow (packageId elab) + ++ prettyShow (Graph.nodeKey elab) | otherwise = prettyShow (elabUnitId 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 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) + +-- +-- 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" @@ -553,49 +595,81 @@ elabDistDirParams shared elab = -- use 'elabLibDependencies'. This method is the same as -- 'nodeNeighbors'. -- --- NB: this method DOES include setup deps. -elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId] +-- Note: this method DOES include setup deps. +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 - --- | Like 'elabOrderDependencies', but only returns dependencies on --- libraries. -elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] + elabOrderLibDependencies elab <> elabOrderExeDependencies elab + +-- | The result includes setup dependencies +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 - --- | 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 elab = + -- 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 = case elabPkgOrComp elab of - ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) - ElabComponent comp -> compLibDependencies comp + ElabPackage pkg -> + ordNub $ CD.flatDeps (pkgOrderExeDependencies pkg) + ElabComponent comp -> + map (fmap fromConfiguredId) (compExeDependencies comp) --- | Like 'elabOrderDependencies', but only returns dependencies on --- executables. (This coincides with 'elabExeDependencies'.) -elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId] -elabOrderExeDependencies = - map newSimpleUnitId . elabExeDependencies +-- | 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 -> + 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 -- the setup script. -elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] -elabExeDependencies elab = map confInstId $ - case elabPkgOrComp elab of - ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg) - ElabComponent comp -> compExeDependencies comp +elabExeDependencies :: ElaboratedConfiguredPackage -> [WithStage ComponentId] +elabExeDependencies elab = + map (fmap confInstId) $ + case elabPkgOrComp elab of + ElabPackage pkg -> ordNub $ 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. @@ -604,25 +678,33 @@ elabExeDependencies elab = map confInstId $ 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) --- | 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 elab = +elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] +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 -> CD.setupDeps (pkgLibDependencies pkg) - -- TODO: Custom setups not supported for components yet. When - -- they are, need to do this differently + ElabPackage pkg -> pkgSetupLibDependencies pkg + -- Custom setups not supported for components. ElabComponent _ -> [] -elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)] -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} = - pkgPkgConfigDependencies pkg -elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} = - compPkgConfigDependencies comp +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 @@ -684,18 +766,20 @@ data ElaboratedComponent = ElaboratedComponent -- instantiation phase. It's more precise than -- 'compLibDependencies', and also stores information about internal -- dependencies. - , compExeDependencies :: [ConfiguredId] + , compInstantiatedWith :: Map ModuleName Module + , compLinkedInstantiatedWith :: Map ModuleName OpenModule + , 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] -- ^ 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. @@ -705,18 +789,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 @@ -726,9 +801,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. @@ -787,13 +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 [UnitId] -pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) - `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) - -- | This is used in the install plan to indicate how the package will be -- built. data BuildStyle 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) diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 1c78d537c19..8c54f093007 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 @@ -82,6 +82,9 @@ import Distribution.Client.TargetSelector ( TargetSelectorProblem (..) , TargetString (..) ) +import Distribution.Client.Toolchain + ( Toolchain (..) + ) import Distribution.Client.Types ( PackageLocation (..) , PackageSpecifier (..) @@ -191,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 ) @@ -357,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 @@ -371,16 +375,20 @@ 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 baseCtx) + + toolchains <- + runRebuild projectRoot $ configureToolchains verbosity (distDirLayout baseCtx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig baseCtx) - createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx) - (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + let Toolchain{toolchainCompiler, toolchainPlatform = toolchainPlatform@(Platform arch os)} = getStage toolchains Host - (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton + (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' compiler platform + build_dir = distBuildDirectory (distDirLayout ctx') $ (scriptDistDirParams script) ctx' toolchainCompiler toolchainPlatform exePath = build_dir "bin" scriptExeFileName script exePathRel = makeRelative (normalise projectRoot) exePath @@ -423,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 @@ -466,14 +475,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 @@ -584,10 +592,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/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 81f2d69ff0a..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) @@ -1409,7 +1427,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 +1449,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 +1530,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 +1558,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 +1578,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 +1648,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 +2250,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 +2294,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 +2652,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 +3603,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 +3626,6 @@ optionSolverFlags setfgc getmc setmc - getig - setig getpo setpo getsip @@ -3676,13 +3678,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/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index 69c8f888698..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 @@ -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/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs index 17dcf6d9398..2eb0d4fdaef 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,21 +64,20 @@ 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.Settings import Distribution.Solver.Types.SolverId 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 +import GHC.Stack (HasCallStack) type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc @@ -90,22 +85,9 @@ type SolverPlanIndex = Graph SolverPlanPackage data SolverInstallPlan = SolverInstallPlan { planIndex :: !SolverPlanIndex - , planIndepGoals :: !IndependentGoals } deriving (Generic) -{- --- | Much like 'planPkgIdOf', but mapping back to full packages. -planPkgOf :: SolverInstallPlan - -> Graph.Vertex - -> SolverPlanPackage -planPkgOf plan v = - case Graph.lookupKey (planIndex plan) - (planPkgIdOf plan v) of - Just pkg -> pkg - Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" --} - instance Binary SolverInstallPlan instance Structured SolverInstallPlan @@ -142,12 +124,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] @@ -162,13 +143,13 @@ 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] (SolverInstallPlan) -remove shouldRemove plan = - new (planIndepGoals plan) newIndex +remove shouldRemove plan = new newIndex where newIndex = Graph.fromDistinctList $ @@ -185,19 +166,15 @@ 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 SolverPlanPackage - [PackageIdentifier] + (NE.NonEmpty PackageIdentifier) | PackageCycle [SolverPlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageInconsistency QPN [(SolverId, SolverId)] | PackageStateInvalid SolverPlanPackage SolverPlanPackage showPlanProblem :: SolverPlanProblem -> String @@ -205,7 +182,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) @@ -218,7 +195,7 @@ showPlanProblem (PackageInconsistency name inconsistencies) = [ " package " ++ prettyShow pkg ++ " requires " - ++ prettyShow (PackageIdentifier name ver) + ++ prettyShow ver | (pkg, ver) <- inconsistencies ] showPlanProblem (PackageStateInvalid pkg pkg') = @@ -239,16 +216,16 @@ 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 - (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 @@ -256,7 +233,7 @@ problems indepGoals index = ] ++ [ PackageInconsistency name inconsistencies | (name, inconsistencies) <- - dependencyInconsistencies indepGoals index + dependencyInconsistencies index ] ++ [ PackageStateInvalid pkg pkg' | pkg <- Foldable.toList index @@ -275,10 +252,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 - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies indepGoals index = + :: SolverPlanIndex + -> [(QPN, [(SolverId, SolverId)])] +dependencyInconsistencies index = concatMap dependencyInconsistencies' subplans where subplans :: [SolverPlanIndex] @@ -286,7 +262,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 +293,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 @@ -335,6 +304,8 @@ rootSets (IndependentGoals indepGoals) 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 @@ -362,23 +333,28 @@ 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 - , reallyIsInconsistent (map fst uses) + , length uses > 1 ] where -- For each package name (of a dependency, somewhere) -- 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 @@ -387,21 +363,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 @@ -434,7 +395,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/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..d74aff42e3e 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 (..) + , ExtraSourceClass (..) , 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/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index bfa94b0da80..6891b567b24 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,17 +616,25 @@ 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. 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) -instance Binary UserConstraintScope -instance Structured UserConstraintScope +instance Binary UserConstraintQualifier +instance Structured UserConstraintQualifier fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel @@ -631,29 +642,40 @@ 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 (UserAnyExeQualifier pn)) = + ConstraintScope mstage (ScopeAnyExeQualifier 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 + scopePN (UserAnyExeQualifier pn) = pn userToPackageConstraint :: UserConstraint -> PackageConstraint -userToPackageConstraint (UserConstraint scope prop) = +userToPackageConstraint (UserConstraintX scope prop) = PackageConstraint (fromUserConstraintScope scope) prop readUserConstraint :: String -> Either String UserConstraint @@ -668,7 +690,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 +706,60 @@ 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 + | pn == mkPackageName "exe" = UserAnyExeQualifier <$> 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 + 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])))) +-- +-- >>> 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 "build:rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserQualified UserQualToplevel (PackageName "rts"))) PackagePropertySource) +-- +-- >>> eitherParsec "build:any.rts source" :: Either String UserConstraint +-- Right (UserConstraintX (UserConstraintScope (Just Build) (UserAnyQualifier (PackageName "rts"))) PackagePropertySource) +-- +-- >>> 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])))) diff --git a/cabal-install/src/Distribution/Client/Toolchain.hs b/cabal-install/src/Distribution/Client/Toolchain.hs new file mode 100644 index 00000000000..e6023fdd91a --- /dev/null +++ b/cabal-install/src/Distribution/Client/Toolchain.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.Toolchain + ( Stage (..) + , Staged (..) + , 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) +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) + +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) + +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/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/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/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) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 95f04b81a4c..c2c72684d48 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 #-} @@ -30,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 (..) @@ -71,7 +72,8 @@ 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.LogProgress +import Distribution.Utils.Path (FileOrDir (File), Pkg, SymbolicPath, unsafeMakeSymbolicPath) import Distribution.Version import IntegrationTests2.CPP @@ -685,7 +687,10 @@ 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 :: SymbolicPath Pkg File -> ExtraSource Pkg + mkExtraSource x = ExtraSourcePkg x [] withHsSrcDirs :: Executable -> [FilePath] -> Executable withHsSrcDirs exe srcDirs = @@ -955,11 +960,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" @@ -981,9 +986,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" @@ -998,8 +1003,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 @@ -1086,8 +1091,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" @@ -1156,7 +1161,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 @@ -1164,13 +1169,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 @@ -1183,7 +1188,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" @@ -1220,8 +1225,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" @@ -1268,7 +1273,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" @@ -1305,8 +1310,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" @@ -1709,11 +1714,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" @@ -1725,7 +1730,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 @@ -1740,10 +1745,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 = @@ -1761,7 +1766,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 @@ -1914,10 +1919,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]) ) @@ -1931,7 +1936,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 @@ -2238,7 +2243,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]) @@ -2249,10 +2254,12 @@ executePlan ts ] elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan + either (error . show) id $ + runLogProgress' $ + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan pkgsBuildStatus <- rebuildTargetsDryRun @@ -2305,7 +2312,8 @@ mkProjectConfig (GhcPath ghcPath) = mempty { projectConfigShared = mempty - { projectConfigHcPath = maybeToFlag ghcPath + { projectConfigToolchain = + mempty{projectConfigHcPath = maybeToFlag ghcPath} } , projectConfigBuildOnly = mempty @@ -2341,7 +2349,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 @@ -2797,7 +2805,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 diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index c8843761e69..8b6ee203104 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 (..) @@ -287,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 @@ -324,6 +329,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/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index 9db7109fbc6..636703be3ae 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 @@ -15,7 +17,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) @@ -29,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 @@ -224,8 +226,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) @@ -249,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 (IndependentGoals False) 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 diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index caee779671b..a177ef3e37e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -600,6 +600,30 @@ 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 + projectConfigBuildHcFlavor <- arbitrary + projectConfigBuildHcPath <- arbitraryFlag arbitraryShortToken + projectConfigBuildHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigBuildPackageDBs <- shortListOf 2 arbitrary + return ProjectConfigToolchain{..} + + shrink ProjectConfigToolchain{..} = + runShrinker $ + pure ProjectConfigToolchain + <*> shrinker projectConfigHcFlavor + <*> 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 projectConfigDistDir <- arbitraryFlag arbitraryShortToken @@ -608,12 +632,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 @@ -635,7 +656,6 @@ instance Arbitrary ProjectConfigShared where projectConfigAllowBootLibInstalls <- arbitrary projectConfigOnlyConstrained <- arbitrary projectConfigPerComponent <- arbitrary - projectConfigIndependentGoals <- arbitrary projectConfigPreferOldest <- arbitrary projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken projectConfigMultiRepl <- arbitrary @@ -655,12 +675,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 @@ -682,7 +699,6 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigAllowBootLibInstalls <*> shrinker projectConfigOnlyConstrained <*> shrinker projectConfigPerComponent - <*> shrinker projectConfigIndependentGoals <*> shrinker projectConfigPreferOldest <*> shrinker projectConfigProgPathExtra <*> shrinker projectConfigMultiRepl @@ -1043,9 +1059,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/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 ef4f9fb7c9f..b77cdff89c6 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 @@ -45,7 +46,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 @@ -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 @@ -74,11 +75,13 @@ instance ToExpr ReorderGoals instance ToExpr RepoIndexState instance ToExpr RepoName instance ToExpr ReportLevel +instance ToExpr Stage instance ToExpr StrongFlags 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/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index d1d70f59348..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 {------------------------------------------------------------------------------- @@ -270,7 +271,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 +789,6 @@ exResolve -> CountConflicts -> FineGrainedConflicts -> MinimizeConflictSet - -> IndependentGoals -> PreferOldest -> ReorderGoals -> AllowBootLibInstalls @@ -812,7 +811,6 @@ exResolve countConflicts fineGrainedConflicts minimizeConflictSet - indepGoals prefOldest reorder allowBootLibInstalls @@ -824,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 = @@ -857,17 +859,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 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..3b670caf176 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 @@ -49,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 @@ -64,11 +64,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 +112,6 @@ data SolverTest = SolverTest , testMaxBackjumps :: Maybe Int , testFineGrainedConflicts :: FineGrainedConflicts , testMinimizeConflictSet :: MinimizeConflictSet - , testIndepGoals :: IndependentGoals , testPreferOldest :: PreferOldest , testAllowBootLibInstalls :: AllowBootLibInstalls , testOnlyConstrained :: OnlyConstrained @@ -220,7 +214,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 +244,6 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> (CountConflicts True) testFineGrainedConflicts testMinimizeConflictSet - testIndepGoals testPreferOldest (ReorderGoals False) testAllowBootLibInstalls @@ -307,20 +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.DefaultNamespace P.QualToplevel - QualIndep p -> - P.PackagePath - (P.Independent $ C.mkPackageName p) - P.QualToplevel + QualNone -> P.PackagePath Host 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 Host (P.QualSetup (C.mkPackageName s)) + QualIndepSetup _ s -> + P.PackagePath Host (P.QualSetup (C.mkPackageName s)) QualExe p1 p2 -> - P.PackagePath - P.DefaultNamespace - (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 9994acee2e9..08e917be949 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 (..) @@ -52,14 +53,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 +69,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 +78,6 @@ tests = (FineGrainedConflicts True) (ReorderGoals False) (CountConflicts True) - indepGoals (PreferOldest False) (getBlind <$> goalOrder) targets = testTargets test @@ -88,25 +87,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 +97,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 +112,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 +127,6 @@ tests = (FineGrainedConflicts True) reorderGoals (CountConflicts True) - indepGoals prefOldest Nothing in counterexample (showResults r1 r2) $ @@ -163,7 +142,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 +151,6 @@ tests = (FineGrainedConflicts False) reorderGoals (CountConflicts False) - indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ @@ -180,7 +158,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 +167,6 @@ tests = fineGrainedConflicts reorderGoals (CountConflicts False) - indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ @@ -211,9 +188,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 +204,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 +223,6 @@ solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goal countConflicts fineGrainedConflicts (MinimizeConflictSet False) - indep prefOldest reorder (AllowBootLibInstalls False) @@ -498,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 @@ -526,11 +498,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 @@ -620,11 +587,16 @@ 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 instance ArbitraryOrd P.Qualifier -instance ArbitraryOrd P.Namespace instance ArbitraryOrd OptionalStanza instance ArbitraryOrd FlagName instance ArbitraryOrd PackageName @@ -632,12 +604,9 @@ 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) -deriving instance Generic P.PackagePath -deriving instance Generic P.Namespace -deriving instance Generic P.Qualifier randomSubset :: Int -> [a] -> Gen [a] randomSubset n xs = take n <$> shuffle xs diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs index 5c1d26a1bc2..ee35154974b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs @@ -35,15 +35,15 @@ tests = \p (Blind f) -> toProgress (retry (fromProgress p) (fromProgress . f)) === (foldProgress Step f Done (p :: Log Int) :: Log Int) - , testProperty "failWith" $ \step failure -> - toProgress (failWith step failure) - === (Step step (Fail failure) :: Log Int) - , testProperty "succeedWith" $ \step success -> - toProgress (succeedWith step success) - === (Step step (Done success) :: Log Int) - , testProperty "continueWith" $ \step p -> - toProgress (continueWith step (fromProgress p)) - === (Step step p :: Log Int) + , testProperty "failWith" $ \step' failure -> + toProgress (failWith step' failure) + === (Step step' (Fail failure) :: Log Int) + , testProperty "succeedWith" $ \step' success -> + toProgress (succeedWith step' success) + === (Step step' (Done success) :: Log Int) + , testProperty "continueWith" $ \step' p -> + toProgress (continueWith step' (fromProgress p)) + === (Step step' p :: Log Int) , testCase "tryWith with failure" $ let failure = Fail "Error" s = Step Success @@ -67,9 +67,5 @@ instance deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done) -deriving instance - (Show step, Show fail, Show done) - => Show (Progress step fail done) - deriving instance Eq Message deriving instance Show Message diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index a1f5eed3c62..e092b40c033 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" @@ -77,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"] $ @@ -92,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"] $ @@ -105,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 $ @@ -120,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 $ @@ -135,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 = @@ -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 ] @@ -273,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"] $ @@ -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" @@ -430,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 $ @@ -545,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] $ @@ -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 -------------------------------------------------------------------------------} @@ -2460,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 $ @@ -2576,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" 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