diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index 8d5b583f222..03fd00b9290 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -98,6 +98,10 @@ extra-source-files: tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal tests/PackageTests/BuildTestSuiteDetailedV09/Dummy2.hs + tests/PackageTests/BuildToolsPath/A.hs + tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs + tests/PackageTests/BuildToolsPath/build-tools-path.cabal + tests/PackageTests/BuildToolsPath/hello/Hello.hs tests/PackageTests/BuildableField/BuildableField.cabal tests/PackageTests/BuildableField/Main.hs tests/PackageTests/CMain/Bar.hs @@ -108,6 +112,17 @@ extra-source-files: tests/PackageTests/Configure/include/HsZlibConfig.h.in tests/PackageTests/Configure/zlib.buildinfo.in tests/PackageTests/Configure/zlib.cabal + tests/PackageTests/ConfigureComponent/Exe/Bad.hs + tests/PackageTests/ConfigureComponent/Exe/Exe.cabal + tests/PackageTests/ConfigureComponent/Exe/Good.hs + tests/PackageTests/ConfigureComponent/SubLib/Lib.cabal + tests/PackageTests/ConfigureComponent/SubLib/Lib.hs + tests/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs + tests/PackageTests/ConfigureComponent/Test/Lib.hs + tests/PackageTests/ConfigureComponent/Test/Test.cabal + tests/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs + tests/PackageTests/ConfigureComponent/Test/testlib/testlib.cabal + tests/PackageTests/ConfigureComponent/Test/tests/Test.hs tests/PackageTests/CopyAssumeDepsUpToDate/CopyAssumeDepsUpToDate.cabal tests/PackageTests/CopyAssumeDepsUpToDate/Main.hs tests/PackageTests/CopyAssumeDepsUpToDate/P.hs diff --git a/Cabal/Distribution/InstalledPackageInfo.hs b/Cabal/Distribution/InstalledPackageInfo.hs index 2d3cee9b60d..4cbf5d112ae 100644 --- a/Cabal/Distribution/InstalledPackageInfo.hs +++ b/Cabal/Distribution/InstalledPackageInfo.hs @@ -108,6 +108,9 @@ installedComponentId ipi = case installedUnitId ipi of {-# DEPRECATED installedPackageId "Use installedUnitId instead" #-} -- | Backwards compatibility with Cabal pre-1.24. +-- This type synonym is slightly awful because in cabal-install +-- we define an 'InstalledPackageId' but it's a ComponentId, +-- not a UnitId! installedPackageId :: InstalledPackageInfo -> UnitId installedPackageId = installedUnitId diff --git a/Cabal/Distribution/Package.hs b/Cabal/Distribution/Package.hs index 0431b3d2809..8278ba98d25 100644 --- a/Cabal/Distribution/Package.hs +++ b/Cabal/Distribution/Package.hs @@ -27,6 +27,7 @@ module Distribution.Package ( UnitId(..), mkUnitId, mkLegacyUnitId, + unitIdComponentId, getHSLibraryName, InstalledPackageId, -- backwards compat @@ -176,6 +177,10 @@ mkUnitId = SimpleUnitId . ComponentId mkLegacyUnitId :: PackageId -> UnitId mkLegacyUnitId = SimpleUnitId . ComponentId . display +-- | Extract 'ComponentId' from 'UnitId'. +unitIdComponentId :: UnitId -> ComponentId +unitIdComponentId (SimpleUnitId cid) = cid + -- ------------------------------------------------------------ -- * Package source dependencies -- ------------------------------------------------------------ @@ -234,7 +239,7 @@ packageVersion = pkgVersion . packageId instance Package PackageIdentifier where packageId = id --- | Packages that have an installed package ID +-- | Packages that have an installed unit ID class Package pkg => HasUnitId pkg where installedUnitId :: pkg -> UnitId diff --git a/Cabal/Distribution/PackageDescription/Configuration.hs b/Cabal/Distribution/PackageDescription/Configuration.hs index 74d5c03b4db..e72f5d67135 100644 --- a/Cabal/Distribution/PackageDescription/Configuration.hs +++ b/Cabal/Distribution/PackageDescription/Configuration.hs @@ -421,11 +421,14 @@ overallDependencies enabled (TargetSet targets) = mconcat depss where (depss, _) = unzip $ filter (removeDisabledSections . snd) targets removeDisabledSections :: PDTagged -> Bool - removeDisabledSections (Lib l) = componentEnabled enabled (CLib l) - removeDisabledSections (SubLib _ l) = componentEnabled enabled (CLib l) - removeDisabledSections (Exe _ e) = componentEnabled enabled (CExe e) - removeDisabledSections (Test _ t) = componentEnabled enabled (CTest t) - removeDisabledSections (Bench _ b) = componentEnabled enabled (CBench b) + -- UGH. The embedded componentName in the 'Component's here is + -- BLANK. I don't know whose fault this is but I'll use the tag + -- instead. -- ezyang + removeDisabledSections (Lib _) = componentNameEnabled enabled CLibName + removeDisabledSections (SubLib t _) = componentNameEnabled enabled (CSubLibName t) + removeDisabledSections (Exe t _) = componentNameEnabled enabled (CExeName t) + removeDisabledSections (Test t _) = componentNameEnabled enabled (CTestName t) + removeDisabledSections (Bench t _) = componentNameEnabled enabled (CBenchName t) removeDisabledSections PDNull = True -- Apply extra constraints to a dependency map. diff --git a/Cabal/Distribution/PackageDescription/Parse.hs b/Cabal/Distribution/PackageDescription/Parse.hs index 3ee906b245e..75bdf20753e 100644 --- a/Cabal/Distribution/PackageDescription/Parse.hs +++ b/Cabal/Distribution/PackageDescription/Parse.hs @@ -24,6 +24,10 @@ module Distribution.PackageDescription.Parse ( FieldDescr(..), LineNo, + -- ** Private, but needed for pretty-printer + TestSuiteStanza(..), + BenchmarkStanza(..), + -- ** Supplementary build information readHookedBuildInfo, parseHookedBuildInfo, @@ -34,6 +38,7 @@ module Distribution.PackageDescription.Parse ( binfoFieldDescrs, sourceRepoFieldDescrs, testSuiteFieldDescrs, + benchmarkFieldDescrs, flagFieldDescrs ) where @@ -189,12 +194,7 @@ storeXFieldsLib _ _ = Nothing executableFieldDescrs :: [FieldDescr Executable] executableFieldDescrs = - [ -- note ordering: configuration must come first, for - -- showPackageDescription. - simpleField "executable" - showToken parseTokenQ - exeName (\xs exe -> exe{exeName=xs}) - , simpleField "main-is" + [ simpleField "main-is" showFilePath parseFilePathQ modulePath (\xs exe -> exe{modulePath=xs}) ] @@ -1094,7 +1094,7 @@ parsePackageDescription file = do -- Note: we don't parse the "executable" field here, hence the tail hack. parseExeFields :: [Field] -> PM Executable - parseExeFields = lift . parseFields (tail executableFieldDescrs) + parseExeFields = lift . parseFields executableFieldDescrs storeXFieldsExe emptyExecutable parseTestFields :: LineNo -> [Field] -> PM TestSuite diff --git a/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/Cabal/Distribution/PackageDescription/PrettyPrint.hs index 7cbf726bfa4..5c54d286a1b 100644 --- a/Cabal/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -35,6 +35,7 @@ import Distribution.ParseUtils import Distribution.PackageDescription.Parse import Distribution.Package import Distribution.Text +import Distribution.ModuleName import Text.PrettyPrint (hsep, space, parens, char, nest, isEmpty, ($$), (<+>), @@ -58,11 +59,11 @@ ppGenericPackageDescription :: GenericPackageDescription -> Doc ppGenericPackageDescription gpd = ppPackageDescription (packageDescription gpd) $+$ ppGenPackageFlags (genPackageFlags gpd) - $+$ ppLibrary (condLibrary gpd) - $+$ ppSubLibraries (condSubLibraries gpd) - $+$ ppExecutables (condExecutables gpd) - $+$ ppTestSuites (condTestSuites gpd) - $+$ ppBenchmarks (condBenchmarks gpd) + $+$ ppCondLibrary (condLibrary gpd) + $+$ ppCondSubLibraries (condSubLibraries gpd) + $+$ ppCondExecutables (condExecutables gpd) + $+$ ppCondTestSuites (condTestSuites gpd) + $+$ ppCondBenchmarks (condBenchmarks gpd) ppPackageDescription :: PackageDescription -> Doc ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd @@ -119,14 +120,14 @@ ppFlag flag@(MkFlag name _ _ _) = where fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag -ppLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc -ppLibrary Nothing = mempty -ppLibrary (Just condTree) = +ppCondLibrary :: Maybe (CondTree ConfVar [Dependency] Library) -> Doc +ppCondLibrary Nothing = mempty +ppCondLibrary (Just condTree) = emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib) -ppSubLibraries :: [(String, CondTree ConfVar [Dependency] Library)] -> Doc -ppSubLibraries libs = +ppCondSubLibraries :: [(String, CondTree ConfVar [Dependency] Library)] -> Doc +ppCondSubLibraries libs = vcat [emptyLine $ text ("library " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppLib)| (n,condTree) <- libs] @@ -136,8 +137,8 @@ ppLib lib Nothing = ppFieldsFiltered libDefaults libFieldDescrs lib ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) -ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc -ppExecutables exes = +ppCondExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppCondExecutables exes = vcat [emptyLine $ text ("executable " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] where @@ -152,8 +153,8 @@ ppExecutables exes = $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 $+$ ppCustomFields (customFieldsBI buildInfo') -ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc -ppTestSuites suites = +ppCondTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppCondTestSuites suites = emptyLine $ vcat [ text ("test-suite " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) | (n,condTree) <- suites] @@ -184,8 +185,8 @@ ppTestSuites suites = TestSuiteLibV09 _ m -> Just m _ -> Nothing -ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc -ppBenchmarks suites = +ppCondBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc +ppCondBenchmarks suites = emptyLine $ vcat [ text ("benchmark " ++ n) $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark) | (n,condTree) <- suites] @@ -280,17 +281,80 @@ writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription -- | @since 1.26.0.0@ showPackageDescription :: PackageDescription -> String showPackageDescription pkg = render $ - ppPackage pkg - $$ ppCustomFields (customFieldsPD pkg) - $$ (case library pkg of - Nothing -> mempty - Just lib -> ppLibrary' lib) - $$ vcat [ space $$ ppLibrary' lib | lib <- subLibraries pkg ] - $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] - where - ppPackage = ppFields pkgDescrFieldDescrs - ppLibrary' = ppFields libFieldDescrs - ppExecutable = ppFields executableFieldDescrs + ppPackageDescription pkg + $+$ ppMaybeLibrary (library pkg) + $+$ ppSubLibraries (subLibraries pkg) + $+$ ppExecutables (executables pkg) + $+$ ppTestSuites (testSuites pkg) + $+$ ppBenchmarks (benchmarks pkg) + +ppMaybeLibrary :: Maybe Library -> Doc +ppMaybeLibrary Nothing = mempty +ppMaybeLibrary (Just lib) = + emptyLine $ text "library" + $+$ nest indentWith (ppFields libFieldDescrs lib) + +ppSubLibraries :: [Library] -> Doc +ppSubLibraries libs = vcat [ + emptyLine $ text "library" <+> text libname + $+$ nest indentWith (ppFields libFieldDescrs lib) + | lib@Library{ libName = Just libname } <- libs ] + +ppExecutables :: [Executable] -> Doc +ppExecutables exes = vcat [ + emptyLine $ text "executable" <+> text (exeName exe) + $+$ nest indentWith (ppFields executableFieldDescrs exe) + | exe <- exes ] + +ppTestSuites :: [TestSuite] -> Doc +ppTestSuites tests = vcat [ + emptyLine $ text "test-suite" <+> text (testName test) + $+$ nest indentWith (ppFields testSuiteFieldDescrs test_stanza) + | test <- tests + , let test_stanza + = TestSuiteStanza { + testStanzaTestType = Just (testSuiteInterfaceToTestType (testInterface test)), + testStanzaMainIs = testSuiteInterfaceToMaybeMainIs (testInterface test), + testStanzaTestModule = testSuiteInterfaceToMaybeModule (testInterface test), + testStanzaBuildInfo = testBuildInfo test + } + ] + +testSuiteInterfaceToTestType :: TestSuiteInterface -> TestType +testSuiteInterfaceToTestType (TestSuiteExeV10 ver _) = TestTypeExe ver +testSuiteInterfaceToTestType (TestSuiteLibV09 ver _) = TestTypeLib ver +testSuiteInterfaceToTestType (TestSuiteUnsupported ty) = ty + +testSuiteInterfaceToMaybeMainIs :: TestSuiteInterface -> Maybe FilePath +testSuiteInterfaceToMaybeMainIs (TestSuiteExeV10 _ fp) = Just fp +testSuiteInterfaceToMaybeMainIs TestSuiteLibV09{} = Nothing +testSuiteInterfaceToMaybeMainIs TestSuiteUnsupported{} = Nothing + +testSuiteInterfaceToMaybeModule :: TestSuiteInterface -> Maybe ModuleName +testSuiteInterfaceToMaybeModule (TestSuiteLibV09 _ mod_name) = Just mod_name +testSuiteInterfaceToMaybeModule TestSuiteExeV10{} = Nothing +testSuiteInterfaceToMaybeModule TestSuiteUnsupported{} = Nothing + +ppBenchmarks :: [Benchmark] -> Doc +ppBenchmarks benchs = vcat [ + emptyLine $ text "benchmark" <+> text (benchmarkName bench) + $+$ nest indentWith (ppFields benchmarkFieldDescrs bench_stanza) + | bench <- benchs + , let bench_stanza = BenchmarkStanza { + benchmarkStanzaBenchmarkType = Just (benchmarkInterfaceToBenchmarkType (benchmarkInterface bench)), + benchmarkStanzaMainIs = benchmarkInterfaceToMaybeMainIs (benchmarkInterface bench), + benchmarkStanzaBenchmarkModule = Nothing, + benchmarkStanzaBuildInfo = benchmarkBuildInfo bench + }] + +benchmarkInterfaceToBenchmarkType :: BenchmarkInterface -> BenchmarkType +benchmarkInterfaceToBenchmarkType (BenchmarkExeV10 ver _) = BenchmarkTypeExe ver +benchmarkInterfaceToBenchmarkType (BenchmarkUnsupported ty) = ty + +benchmarkInterfaceToMaybeMainIs :: BenchmarkInterface -> Maybe FilePath +benchmarkInterfaceToMaybeMainIs (BenchmarkExeV10 _ fp) = Just fp +benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing + -- | @since 1.26.0.0@ writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () diff --git a/Cabal/Distribution/Simple.hs b/Cabal/Distribution/Simple.hs index 3bce554fb53..90d3b04f8fa 100644 --- a/Cabal/Distribution/Simple.hs +++ b/Cabal/Distribution/Simple.hs @@ -187,7 +187,8 @@ allSuffixHandlers hooks configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo configureAction hooks flags args = do distPref <- findDistPrefOrDefault (configDistPref flags) - let flags' = flags { configDistPref = toFlag distPref } + let flags' = flags { configDistPref = toFlag distPref + , configArgs = args } -- See docs for 'HookedBuildInfo' pbi <- preConf hooks args flags' @@ -578,7 +579,6 @@ defaultUserHooks = autoconfUserHooks { -- https://github.com/haskell/cabal/issues/158 where oldCompatPostConf args flags pkg_descr lbi = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args confExists <- doesFileExist "configure" when confExists $ runConfigureScript verbosity @@ -609,7 +609,6 @@ autoconfUserHooks where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () defaultPostConf args flags pkg_descr lbi = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args confExists <- doesFileExist "configure" if confExists then runConfigureScript verbosity diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index 598c00932f7..ab08940fea0 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -425,6 +425,7 @@ testSuiteLibV09AsLibAndExe pkg_descr libClbi = LibComponentLocalBuildInfo { componentPackageDeps = componentPackageDeps clbi , componentInternalDeps = componentInternalDeps clbi + , componentExeDeps = componentExeDeps clbi , componentLocalName = CSubLibName (testName test) , componentIsPublic = False , componentIncludes = componentIncludes clbi @@ -465,6 +466,7 @@ testSuiteLibV09AsLibAndExe pkg_descr -- (doesn't clobber something) we won't run into trouble componentUnitId = mkUnitId (stubName test), componentInternalDeps = [componentUnitId clbi], + componentExeDeps = [], componentLocalName = CExeName (stubName test), componentPackageDeps = deps, componentIncludes = zip (map fst deps) (repeat defaultRenaming) @@ -488,6 +490,7 @@ benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } componentUnitId = componentUnitId clbi, componentLocalName = CExeName (benchmarkName bm), componentInternalDeps = componentInternalDeps clbi, + componentExeDeps = componentExeDeps clbi, componentPackageDeps = componentPackageDeps clbi, componentIncludes = componentIncludes clbi } diff --git a/Cabal/Distribution/Simple/BuildTarget.hs b/Cabal/Distribution/Simple/BuildTarget.hs index f0508680872..0a8ffa2b6bc 100644 --- a/Cabal/Distribution/Simple/BuildTarget.hs +++ b/Cabal/Distribution/Simple/BuildTarget.hs @@ -12,6 +12,7 @@ module Distribution.Simple.BuildTarget ( -- * Main interface readTargetInfos, + readBuildTargets, -- in case you don't have LocalBuildInfo -- * Build targets BuildTarget(..), @@ -232,10 +233,21 @@ showUserBuildTarget = intercalate ":" . getComponents getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] -showBuildTarget :: QualLevel -> PackageId -> BuildTarget -> String -showBuildTarget ql pkgid bt = +-- | Unless you use 'QL1', this function is PARTIAL; +-- use 'showBuildTarget' instead. +showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String +showBuildTarget' ql pkgid bt = showUserBuildTarget (renderBuildTarget ql bt pkgid) +-- | Unambiguously render a 'BuildTarget', so that it can +-- be parsed in all situations. +showBuildTarget :: PackageId -> BuildTarget -> String +showBuildTarget pkgid t = + showBuildTarget' (qlBuildTarget t) pkgid t + where + qlBuildTarget BuildTargetComponent{} = QL2 + qlBuildTarget _ = QL3 + -- ------------------------------------------------------------ -- * Resolving user targets to build targets @@ -998,3 +1010,7 @@ checkBuildTargets verbosity pkg_descr lbi targets = do formatReason cn DisabledAllBenchmarks = "Cannot process the " ++ cn ++ " because benchmarks are not " ++ "enabled. Re-run configure with the flag --enable-benchmarks" + formatReason cn (DisabledAllButOne cn') = + "Cannot process the " ++ cn ++ " because this package was " + ++ "configured only to build " ++ cn' ++ ". Re-run configure " + ++ "with the argument " ++ cn diff --git a/Cabal/Distribution/Simple/Configure.hs b/Cabal/Distribution/Simple/Configure.hs index 72bfd89eaa3..d65fd778196 100644 --- a/Cabal/Distribution/Simple/Configure.hs +++ b/Cabal/Distribution/Simple/Configure.hs @@ -35,6 +35,8 @@ module Distribution.Simple.Configure (configure, tryGetPersistBuildConfig, maybeGetPersistBuildConfig, findDistPref, findDistPrefOrDefault, + mkComponentsGraph, + getInternalPackages, computeComponentId, computeCompatPackageKey, computeCompatPackageName, @@ -69,10 +71,12 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.PackageDescription as PD hiding (Flag) import Distribution.ModuleName +import Distribution.PackageDescription.PrettyPrint import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Check hiding (doesFileExist) import Distribution.Simple.Program import Distribution.Simple.Setup as Setup +import Distribution.Simple.BuildTarget import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.LocalBuildInfo @@ -104,6 +108,7 @@ import Data.Either ( partitionEithers ) import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Maybe as Maybe import Numeric ( showIntAtBase ) import System.Directory ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) @@ -320,7 +325,32 @@ configure (pkg_descr0', pbi) cfg = do (maybe RelaxDepsNone unAllowNewer $ configAllowNewer cfg) pkg_descr0' - setupMessage verbosity "Configuring" (packageId pkg_descr0) + -- Determine the component we are configuring, if a user specified + -- one on the command line. We use a fake, flattened version of + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription pkg_descr0 + targets <- readBuildTargets flat_pkg_descr (configArgs cfg) + -- TODO: bleat if you use the module/file syntax + let targets' = [ cname | BuildTargetComponent cname <- targets ] + case targets' of + _ | null (configArgs cfg) -> return Nothing + [cname] -> return (Just cname) + [] -> die "No valid component targets found" + _ -> die "Can only configure either single component or all of them" + + let use_external_internal_deps = isJust mb_cname + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) + Just cname -> notice verbosity + ("Configuring component " ++ display cname ++ + " from " ++ display (packageId pkg_descr0)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + die "--cid is only supported for per-component configure" checkDeprecatedFlags verbosity cfg checkExactConfiguration pkg_descr0 cfg @@ -360,17 +390,22 @@ configure (pkg_descr0', pbi) cfg = do <- getInstalledPackages (lessVerbose verbosity) comp packageDbs programsConfig - -- An approximate InstalledPackageIndex of all (possible) internal libraries. - -- This database is used to bootstrap the process before we know precisely - -- what these libraries are supposed to be. - let internalPackageSet :: InstalledPackageIndex + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + let internalPackageSet :: Map PackageName ComponentName internalPackageSet = getInternalPackages pkg_descr0 -- Make a data structure describing what components are enabled. let enabled :: ComponentEnabledSpec - enabled = ComponentEnabledSpec - { testsEnabled = fromFlag (configTests cfg) - , benchmarksEnabled = fromFlag (configBenchmarks cfg) } + enabled = case mb_cname of + Just cname -> OneComponentEnabledSpec cname + Nothing -> ComponentEnabledSpec + { testsEnabled = fromFlag (configTests cfg) + , benchmarksEnabled = fromFlag (configBenchmarks cfg) } + -- Some sanity checks related to enabling components. + when (isJust mb_cname && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ + die $ "--enable-tests/--enable-benchmarks are incompatible with" ++ + " explicitly specifying a component to configure." -- allConstraints: The set of all 'Dependency's we have. Used ONLY -- to 'configureFinalizedPackage'. @@ -413,6 +448,7 @@ configure (pkg_descr0', pbi) cfg = do allConstraints (dependencySatisfiable (fromFlagOrDefault False (configExactConfiguration cfg)) + (packageVersion pkg_descr0) installedPackageSet internalPackageSet requiredDepsMap) @@ -420,13 +456,25 @@ configure (pkg_descr0', pbi) cfg = do compPlatform pkg_descr0 + debug verbosity $ "Finalized package description:\n" + ++ showPackageDescription pkg_descr + -- NB: showPackageDescription does not display the AWFUL HACK GLOBAL + -- buildDepends, so we have to display it separately. See #2066 + -- Some day, we should eliminate this, so that + -- configureFinalizedPackage returns the set of overall dependencies + -- separately. Then 'configureDependencies' and + -- 'Distribution.PackageDescription.Check' need to be adjusted + -- accordingly. + debug verbosity $ "Finalized build-depends: " + ++ intercalate ", " (map display (buildDepends pkg_descr)) + checkCompilerProblems comp pkg_descr checkPackageProblems verbosity pkg_descr0 (updatePackageDescription pbi pkg_descr) -- The list of 'InstalledPackageInfo' recording the selected -- dependencies... - -- internalPkgDeps: ...on internal packages (these are fake!) + -- internalPkgDeps: ...on internal packages -- externalPkgDeps: ...on external packages -- -- Invariant: For any package name, there is at most one package @@ -442,6 +490,7 @@ configure (pkg_descr0', pbi) cfg = do externalPkgDeps :: [InstalledPackageInfo]) <- configureDependencies verbosity + use_external_internal_deps internalPackageSet installedPackageSet requiredDepsMap @@ -514,7 +563,8 @@ configure (pkg_descr0', pbi) cfg = do -- -- TODO: Move this into a helper function. defaultDirs :: InstallDirTemplates - <- defaultInstallDirs (compilerFlavor comp) + <- defaultInstallDirs' use_external_internal_deps + (compilerFlavor comp) (fromFlag (configUserInstall cfg)) (hasLibs pkg_descr) let installDirs :: InstallDirTemplates @@ -570,10 +620,11 @@ configure (pkg_descr0', pbi) cfg = do -- From there, we build a ComponentLocalBuildInfo for each of the -- components, which lets us actually build each component. buildComponents <- - case mkComponentsGraph enabled pkg_descr internalPkgDeps of + case mkComponentsGraph enabled pkg_descr internalPackageSet of Left componentCycle -> reportComponentCycle componentCycle Right comps -> - mkComponentsLocalBuildInfo cfg comp packageDependsIndex pkg_descr + mkComponentsLocalBuildInfo cfg use_external_internal_deps comp + packageDependsIndex pkg_descr internalPkgDeps externalPkgDeps comps (configConfigurationsFlags cfg) @@ -780,40 +831,29 @@ checkExactConfiguration pkg_descr0 cfg = do -- does the resolution of conditionals, and it takes internalPackageSet -- as part of its input. getInternalPackages :: GenericPackageDescription - -> InstalledPackageIndex + -> Map PackageName ComponentName getInternalPackages pkg_descr0 = + -- TODO: some day, executables will be fair game here too! let pkg_descr = flattenPackageDescription pkg_descr0 - mkInternalPackage lib = emptyInstalledPackageInfo { - --TODO: should use a per-compiler method to map the source - -- package ID into an installed package id we can use - -- for the internal package set. What we do here - -- is skeevy, but we're highly unlikely to accidentally - -- shadow something legitimate. - Installed.installedUnitId = mkUnitId n, - -- NB: we TEMPORARILY set the package name to be the - -- library name. When we actually register, it won't - -- look like this; this is just so that internal - -- build-depends get resolved correctly. - Installed.sourcePackageId = PackageIdentifier (PackageName n) - (pkgVersion (package pkg_descr)) - } - where n = case libName lib of - Nothing -> display (packageName pkg_descr) - Just n' -> n' - in PackageIndex.fromList (map mkInternalPackage (allLibraries pkg_descr)) - - --- | Returns true if a dependency is satisfiable. This is to be passed + f lib = case libName lib of + Nothing -> (packageName pkg_descr, CLibName) + Just n' -> (PackageName n', CSubLibName n') + in Map.fromList (map f (allLibraries pkg_descr)) + +-- | Returns true if a dependency is satisfiable. This function +-- may report a dependency satisfiable even when it is not, +-- but not vice versa. This is to be passed -- to finalizePD. dependencySatisfiable :: Bool + -> Version -> InstalledPackageIndex -- ^ installed set - -> InstalledPackageIndex -- ^ internal set + -> Map PackageName ComponentName -- ^ internal set -> Map PackageName InstalledPackageInfo -- ^ required dependencies -> (Dependency -> Bool) dependencySatisfiable - exact_config installedPackageSet internalPackageSet requiredDepsMap - d@(Dependency depName _) + exact_config pkg_ver installedPackageSet internalPackageSet requiredDepsMap + d@(Dependency depName verRange) | exact_config = -- When we're given '--exact-configuration', we assume that all -- dependencies and flags are exactly specified on the command @@ -827,17 +867,31 @@ dependencySatisfiable -- -- (However, note that internal deps don't have to be -- specified!) + -- + -- NB: Just like the case below, we might incorrectly + -- determine an external internal dep is satisfiable + -- when it actually isn't. (depName `Map.member` requiredDepsMap) || isInternalDep + | isInternalDep + , pkg_ver `withinRange` verRange = + -- If a 'PackageName' is defined by an internal component, + -- and the user didn't specify a version range which is + -- incompatible with the package version, the dep is + -- satisfiable (and we are going to use the internal + -- dependency.) Note that this doesn't mean we are + -- actually going to SUCCEED when we configure the package, + -- if UseExternalInternalDeps is True. NB: if + -- the version bound fails we want to fall through to the + -- next case. + True + | otherwise = - -- Normal operation: just look up dependency in the combined + -- Normal operation: just look up dependency in the -- package index. - not . null . PackageIndex.lookupDependency pkgs $ d + not . null . PackageIndex.lookupDependency installedPackageSet $ d where - -- NB: Prefer the INTERNAL package set - pkgs = PackageIndex.merge installedPackageSet internalPackageSet - isInternalDep = not . null - $ PackageIndex.lookupDependency internalPackageSet d + isInternalDep = Map.member depName internalPackageSet -- | Relax the dependencies of this package if needed. relaxPackageDeps :: (VersionRange -> VersionRange) @@ -939,22 +993,26 @@ checkCompilerProblems comp pkg_descr = do die $ "Your compiler does not support module re-exports. To use " ++ "this feature you probably must use GHC 7.9 or later." +type UseExternalInternalDeps = Bool + -- | Select dependencies for the package. configureDependencies :: Verbosity - -> InstalledPackageIndex -- ^ internal packages + -> UseExternalInternalDeps + -> Map PackageName ComponentName -- ^ internal packages -> InstalledPackageIndex -- ^ installed packages -> Map PackageName InstalledPackageInfo -- ^ required deps -> PackageDescription -> IO ([PackageId], [InstalledPackageInfo]) -configureDependencies verbosity +configureDependencies verbosity use_external_internal_deps internalPackageSet installedPackageSet requiredDepsMap pkg_descr = do let selectDependencies :: [Dependency] -> ([FailedDependency], [ResolvedDependency]) selectDependencies = partitionEithers - . map (selectDependency internalPackageSet installedPackageSet - requiredDepsMap) + . map (selectDependency (package pkg_descr) + internalPackageSet installedPackageSet + requiredDepsMap use_external_internal_deps) (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) @@ -1079,23 +1137,34 @@ reportProgram verbosity prog (Just configuredProg) hackageUrl :: String hackageUrl = "http://hackage.haskell.org/package/" -data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo - | InternalDependency Dependency PackageId -- should be a - -- lib name +data ResolvedDependency + -- | An external dependency from the package database, OR an + -- internal dependency which we are getting from the package + -- database. + = ExternalDependency Dependency InstalledPackageInfo + -- | An internal dependency ('PackageId' should be a library name) + -- which we are going to have to build. (The + -- 'PackageId' here is a hack to get a modest amount of + -- polymorphism out of the 'Package' typeclass.) + | InternalDependency Dependency PackageId data FailedDependency = DependencyNotExists PackageName + | DependencyMissingInternal PackageName PackageName | DependencyNoVersion Dependency -- | Test for a package dependency and record the version we have installed. -selectDependency :: InstalledPackageIndex -- ^ Internally defined packages +selectDependency :: PackageId -- ^ Package id of current package + -> Map PackageName ComponentName -> InstalledPackageIndex -- ^ Installed packages -> Map PackageName InstalledPackageInfo -- ^ Packages for which we have been given specific deps to -- use + -> UseExternalInternalDeps -- ^ Are we configuring a single component? -> Dependency -> Either FailedDependency ResolvedDependency -selectDependency internalIndex installedIndex requiredDepsMap - dep@(Dependency pkgname vr) = +selectDependency pkgid internalIndex installedIndex requiredDepsMap + use_external_internal_deps + dep@(Dependency dep_pkgname vr) = -- If the dependency specification matches anything in the internal package -- index, then we prefer that match to anything in the second. -- For example: @@ -1110,19 +1179,32 @@ selectDependency internalIndex installedIndex requiredDepsMap -- We want "build-depends: MyLibrary" always to match the internal library -- even if there is a newer installed library "MyLibrary-0.2". -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. - case PackageIndex.lookupPackageName internalIndex pkgname of - [(_,[pkg])] | packageVersion pkg `withinRange` vr - -> Right $ InternalDependency dep (packageId pkg) - - _ -> case Map.lookup pkgname requiredDepsMap of + case Map.lookup dep_pkgname internalIndex of + Just cname | packageVersion pkgid `withinRange` vr + -> if use_external_internal_deps + then do_external (Just cname) + else do_internal + _ -> do_external Nothing + where + do_internal = Right (InternalDependency dep + (PackageIdentifier dep_pkgname (packageVersion pkgid))) + do_external is_internal = case Map.lookup dep_pkgname requiredDepsMap of -- If we know the exact pkg to use, then use it. Just pkginstance -> Right (ExternalDependency dep pkginstance) -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case PackageIndex.lookupDependency installedIndex dep of - [] -> Left $ DependencyNotExists pkgname + Nothing -> case PackageIndex.lookupDependency installedIndex dep' of + [] -> Left $ + case is_internal of + Just cname -> DependencyMissingInternal dep_pkgname + (computeCompatPackageName (packageName pkgid) cname) + Nothing -> DependencyNotExists dep_pkgname pkgs -> Right $ ExternalDependency dep $ case last pkgs of (_ver, pkginstances) -> head pkginstances + where + dep' | Just cname <- is_internal + = Dependency (computeCompatPackageName (packageName pkgid) cname) vr + | otherwise = dep reportSelectedDependencies :: Verbosity -> [ResolvedDependency] -> IO () @@ -1146,6 +1228,11 @@ reportFailedDependencies failed = ++ "Perhaps you need to download and install it from\n" ++ hackageUrl ++ display pkgname ++ "?" + reportFailedDependency (DependencyMissingInternal pkgname real_pkgname) = + "internal dependency " ++ display pkgname ++ " not installed.\n" + ++ "Perhaps you need to configure and install it first?\n" + ++ "(Munged package name we searched for was " ++ display real_pkgname ++ ")" + reportFailedDependency (DependencyNoVersion dep) = "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" @@ -1245,23 +1332,17 @@ newPackageDepsBehaviour pkg = -- deps in the end. So we still need to remember which installed packages to -- pick. combinedConstraints :: [Dependency] -> - [(PackageName, UnitId)] -> + [(PackageName, ComponentId)] -> InstalledPackageIndex -> Either String ([Dependency], Map PackageName InstalledPackageInfo) combinedConstraints constraints dependencies installedPackages = do - when (not (null badUnitIds)) $ + when (not (null badComponentIds)) $ Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badUnitIds) + $+$ nest 4 (dispDependencies badComponentIds) $+$ text "however the given installed package instance does not exist." - when (not (null badNames)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badNames) - $+$ text ("however the installed package's name does not match " - ++ "the name given.") - --TODO: we don't check that all dependencies are used! return (allConstraints, idConstraintMap) @@ -1278,35 +1359,26 @@ combinedConstraints constraints dependencies installedPackages = do | (_, _, Just pkg) <- dependenciesPkgInfo ] -- The dependencies along with the installed package info, if it exists - dependenciesPkgInfo :: [(PackageName, UnitId, + dependenciesPkgInfo :: [(PackageName, ComponentId, Maybe InstalledPackageInfo)] dependenciesPkgInfo = - [ (pkgname, ipkgid, mpkg) - | (pkgname, ipkgid) <- dependencies - , let mpkg = PackageIndex.lookupUnitId - installedPackages ipkgid + [ (pkgname, cid, mpkg) + | (pkgname, cid) <- dependencies + , let mpkg = PackageIndex.lookupComponentId + installedPackages cid ] -- If we looked up a package specified by an installed package id -- (i.e. someone has written a hash) and didn't find it then it's -- an error. - badUnitIds = - [ (pkgname, ipkgid) - | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ] - - -- If someone has written e.g. - -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have - -- probably made a mistake. - badNames = - [ (requestedPkgName, ipkgid) - | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo - , let foundPkgName = packageName pkg - , requestedPkgName /= foundPkgName ] + badComponentIds = + [ (pkgname, cid) + | (pkgname, cid, Nothing) <- dependenciesPkgInfo ] dispDependencies deps = hsep [ text "--dependency=" - <<>> quotes (disp pkgname <<>> char '=' <<>> disp ipkgid) - | (pkgname, ipkgid) <- deps ] + <<>> quotes (disp pkgname <<>> char '=' <<>> disp cid) + | (pkgname, cid) <- deps ] -- ----------------------------------------------------------------------------- -- Configuring program dependencies @@ -1321,7 +1393,9 @@ configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = case lookupKnownProgram progName conf of - Nothing -> die ("Unknown build tool " ++ progName) + Nothing -> + -- Try to configure it as a 'simpleProgram' automatically + configureProgram verbosity (simpleProgram progName) conf Just prog -- requireProgramVersion always requires the program have a version -- but if the user says "build-depends: foo" ie no version constraint @@ -1492,14 +1566,12 @@ configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx -- libraries are considered internal), create a graph of dependencies -- between the components. This is NOT necessarily the build order -- (although it is in the absence of Backpack.) --- --- TODO: tighten up the type of 'internalPkgDeps' mkComponentsGraph :: ComponentEnabledSpec -> PackageDescription - -> [PackageId] + -> Map PackageName ComponentName -> Either [ComponentName] [(Component, [ComponentName])] -mkComponentsGraph enabled pkg_descr internalPkgDeps = +mkComponentsGraph enabled pkg_descr internalPackageSet = let g = Graph.fromList [ N c (componentName c) (componentDeps c) | c <- pkgBuildableComponents pkg_descr , componentEnabled enabled c ] @@ -1514,12 +1586,9 @@ mkComponentsGraph enabled pkg_descr internalPkgDeps = , toolname `elem` map exeName (executables pkg_descr) ] - ++ [ if pkgname == packageName pkg_descr - then CLibName - else CSubLibName toolname - | Dependency pkgname@(PackageName toolname) _ - <- targetBuildDepends bi - , pkgname `elem` map packageName internalPkgDeps ] + ++ [ cname + | Dependency pkgname _ <- targetBuildDepends bi + , cname <- Maybe.maybeToList (Map.lookup pkgname internalPackageSet) ] where bi = componentBuildInfo component @@ -1535,13 +1604,14 @@ reportComponentCycle cnames = -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId :: Flag String + -> Flag ComponentId -> PackageIdentifier -> ComponentName -- TODO: careful here! -> [ComponentId] -- IPIDs of the component dependencies -> FlagAssignment -> ComponentId -computeComponentId mb_explicit pid cname dep_ipids flagAssignment = do +computeComponentId mb_ipid mb_cid pid cname dep_ipids flagAssignment = -- show is found to be faster than intercalate and then replacement of -- special character used in intercalating. We cannot simply hash by -- doubly concating list, as it just flatten out the nested list, so @@ -1559,13 +1629,15 @@ computeComponentId mb_explicit pid cname dep_ipids flagAssignment = do -- Hack to reuse install dirs machinery -- NB: no real IPID available at this point where env = packageTemplateEnv pid (mkUnitId "") - actual_base = case mb_explicit of - Flag cid0 -> explicit_base cid0 + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 NoFlag -> generated_base - ComponentId $ actual_base - ++ (case componentNameString cname of - Nothing -> "" - Just s -> "-" ++ s) + in case mb_cid of + Flag cid -> cid + NoFlag -> ComponentId $ actual_base + ++ (case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ s) hashToBase62 :: String -> String hashToBase62 s = showFingerprint $ fingerprintString s @@ -1692,6 +1764,7 @@ computeCompatPackageKey comp pkg_name pkg_version (SimpleUnitId (ComponentId str | otherwise = str mkComponentsLocalBuildInfo :: ConfigFlags + -> UseExternalInternalDeps -> Compiler -> InstalledPackageIndex -> PackageDescription @@ -1700,20 +1773,13 @@ mkComponentsLocalBuildInfo :: ConfigFlags -> [(Component, [ComponentName])] -> FlagAssignment -> IO [ComponentLocalBuildInfo] -mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr +mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages pkg_descr internalPkgDeps externalPkgDeps graph flagAssignment = foldM go [] graph where go z (component, dep_cnames) = do - -- NB: We want to preserve cdeps because it contains extra - -- information like build-tools ordering - let dep_uids = [ componentUnitId dep_clbi - | cname <- dep_cnames - -- Being in z relies on topsort! - , dep_clbi <- z - , componentLocalName dep_clbi == cname ] - clbi <- componentLocalBuildInfo z component dep_uids + clbi <- componentLocalBuildInfo z component dep_cnames return (clbi:z) -- The allPkgDeps contains all the package deps for the whole package @@ -1722,8 +1788,19 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr -- needs. Note, this only works because we cannot yet depend on two -- versions of the same package. componentLocalBuildInfo :: [ComponentLocalBuildInfo] - -> Component -> [UnitId] -> IO ComponentLocalBuildInfo - componentLocalBuildInfo internalComps component dep_uids = + -> Component -> [ComponentName] -> IO ComponentLocalBuildInfo + componentLocalBuildInfo internalComps component dep_cnames = + -- NB: We want to preserve cdeps because it contains extra + -- information like build-tools ordering + let dep_uids = [ componentUnitId dep_clbi + | cname <- dep_cnames + , dep_clbi <- internalComps + , componentLocalName dep_clbi == cname ] + dep_exes = [ componentUnitId dep_clbi + | cname@(CExeName _) <- dep_cnames + , dep_clbi <- internalComps + , componentLocalName dep_clbi == cname ] + in -- (putStrLn $ "configuring " ++ display (componentName component)) >> case component of CLib lib -> do @@ -1740,6 +1817,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr return LibComponentLocalBuildInfo { componentPackageDeps = cpds, componentInternalDeps = dep_uids, + componentExeDeps = dep_exes, componentUnitId = uid, componentLocalName = componentName component, componentIsPublic = libName lib == Nothing, @@ -1752,6 +1830,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr return ExeComponentLocalBuildInfo { componentUnitId = uid, componentInternalDeps = dep_uids, + componentExeDeps = dep_exes, componentLocalName = componentName component, componentPackageDeps = cpds, componentIncludes = includes @@ -1760,6 +1839,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr return TestComponentLocalBuildInfo { componentUnitId = uid, componentInternalDeps = dep_uids, + componentExeDeps = dep_exes, componentLocalName = componentName component, componentPackageDeps = cpds, componentIncludes = includes @@ -1768,14 +1848,14 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr return BenchComponentLocalBuildInfo { componentUnitId = uid, componentInternalDeps = dep_uids, + componentExeDeps = dep_exes, componentLocalName = componentName component, componentPackageDeps = cpds, componentIncludes = includes } where - -- TODO configIPID should have name changed - cid = computeComponentId (configIPID cfg) (package pkg_descr) + cid = computeComponentId (configIPID cfg) (configCID cfg) (package pkg_descr) (componentName component) (getDeps (componentName component)) flagAssignment @@ -1818,6 +1898,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr dedup = Map.toList . Map.fromList -- TODO: this should include internal deps too + -- NB: This works correctly in per-component mode getDeps :: ComponentName -> [ComponentId] getDeps cname = let externalPkgs @@ -1827,7 +1908,11 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr in map Installed.installedComponentId externalPkgs selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] - selectSubset bi pkgs = + selectSubset bi pkgs + -- No need to subset for one-component config: deps + -- is precisely what we want + | use_external_internal = pkgs + | otherwise = [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ] names :: BuildInfo -> [PackageName] diff --git a/Cabal/Distribution/Simple/GHC.hs b/Cabal/Distribution/Simple/GHC.hs index 3e7cd634197..af2309315b3 100644 --- a/Cabal/Distribution/Simple/GHC.hs +++ b/Cabal/Distribution/Simple/GHC.hs @@ -1138,20 +1138,17 @@ installLib :: Verbosity -> Library -> ComponentLocalBuildInfo -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do +installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do -- copy .hi files over: - whenRegistered $ do - whenVanilla $ copyModuleFiles "hi" - whenProf $ copyModuleFiles "p_hi" - whenShared $ copyModuleFiles "dyn_hi" + whenVanilla $ copyModuleFiles "hi" + whenProf $ copyModuleFiles "p_hi" + whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: - whenRegistered $ do - whenVanilla $ installOrdinary builtDir targetDir vanillaLibName - whenProf $ installOrdinary builtDir targetDir profileLibName - whenGHCi $ installOrdinary builtDir targetDir ghciLibName - whenRegisteredOrDynExecutable $ do - whenShared $ installShared builtDir dynlibTargetDir sharedLibName + whenVanilla $ installOrdinary builtDir targetDir vanillaLibName + whenProf $ installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + whenShared $ installShared builtDir dynlibTargetDir sharedLibName where builtDir = componentBuildDir lbi clbi @@ -1189,17 +1186,6 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do whenGHCi = when (hasLib && withGHCiLib lbi) whenShared = when (hasLib && withSharedLib lbi) - -- Some files (e.g. interface files) are completely unnecessary when - -- we are not actually going to register the library. A library is - -- not registered if there is no "public library", e.g. in the case - -- that we have an internal library and executables, but no public - -- library. - whenRegistered = when (hasPublicLib pkg) - - -- However, we must always install dynamic libraries when linking - -- dynamic executables, because we'll try to load them! - whenRegisteredOrDynExecutable = when (hasPublicLib pkg || (hasExes pkg && withDynExe lbi)) - -- ----------------------------------------------------------------------------- -- Registering diff --git a/Cabal/Distribution/Simple/GHC/Internal.hs b/Cabal/Distribution/Simple/GHC/Internal.hs index 669f62ccca5..2bed4040e36 100644 --- a/Cabal/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/Distribution/Simple/GHC/Internal.hs @@ -46,6 +46,8 @@ import Distribution.Simple.Setup import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program import Distribution.Simple.LocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo import Distribution.Simple.Utils import Distribution.Simple.BuildPaths import Distribution.System @@ -304,6 +306,7 @@ componentGhcOptions verbosity lbi bi clbi odir = ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), ghcOptDebugInfo = toGhcDebugInfo (withDebugInfo lbi), ghcOptExtra = toNubListR $ hcOptions GHC bi, + ghcOptExtraPath = toNubListR $ exe_paths, ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), -- Unsupported extensions have already been checked by configure ghcOptExtensions = toNubListR $ usedExtensions bi, @@ -320,6 +323,11 @@ componentGhcOptions verbosity lbi bi clbi odir = toGhcDebugInfo NormalDebugInfo = toFlag True toGhcDebugInfo MaximalDebugInfo = toFlag True + exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) + | uid <- componentExeDeps clbi + -- TODO: Ugh, localPkgDescr + , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] + -- | Strip out flags that are not supported in ghci filterGhciFlags :: [String] -> [String] filterGhciFlags = filter supported diff --git a/Cabal/Distribution/Simple/InstallDirs.hs b/Cabal/Distribution/Simple/InstallDirs.hs index 46a91307b08..fe282407071 100644 --- a/Cabal/Distribution/Simple/InstallDirs.hs +++ b/Cabal/Distribution/Simple/InstallDirs.hs @@ -25,6 +25,7 @@ module Distribution.Simple.InstallDirs ( InstallDirs(..), InstallDirTemplates, defaultInstallDirs, + defaultInstallDirs', combineInstallDirs, absoluteInstallDirs, CopyDest(..), @@ -156,7 +157,17 @@ type InstallDirTemplates = InstallDirs PathTemplate -- Default installation directories defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs comp userInstall _hasLibs = do +defaultInstallDirs = defaultInstallDirs' False + +defaultInstallDirs' :: Bool {- use external internal deps -} + -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs' True comp userInstall hasLibs = do + dflt <- defaultInstallDirs' False comp userInstall hasLibs + -- Be a bit more hermetic about per-component installs + return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", + docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" + } +defaultInstallDirs' False comp userInstall _hasLibs = do installPrefix <- if userInstall then getAppUserDataDirectory "cabal" diff --git a/Cabal/Distribution/Simple/PackageIndex.hs b/Cabal/Distribution/Simple/PackageIndex.hs index 47e194d0839..5dfe353e98d 100644 --- a/Cabal/Distribution/Simple/PackageIndex.hs +++ b/Cabal/Distribution/Simple/PackageIndex.hs @@ -77,6 +77,7 @@ module Distribution.Simple.PackageIndex ( -- ** Precise lookups lookupUnitId, + lookupComponentId, lookupSourcePackageId, lookupPackageId, lookupPackageName, @@ -131,11 +132,11 @@ import qualified Data.Tree as Tree -- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. -- -data PackageIndex a = PackageIndex +data PackageIndex a = PackageIndex { -- The primary index. Each InstalledPackageInfo record is uniquely identified -- by its UnitId. -- - !(Map UnitId a) + unitIdIndex :: !(Map UnitId a), -- This auxiliary index maps package names (case-sensitively) to all the -- versions and instances of that package. This allows us to find all @@ -148,9 +149,9 @@ data PackageIndex a = PackageIndex -- -- FIXME: Clarify what "preference order" means. Check that this invariant is -- preserved. See #1463 for discussion. - !(Map PackageName (Map Version [a])) + packageIdIndex :: !(Map PackageName (Map Version [a])) - deriving (Eq, Generic, Show, Read) + } deriving (Eq, Generic, Show, Read) instance Binary a => Binary (PackageIndex a) @@ -353,16 +354,16 @@ deleteDependency (Dependency name verstionRange) = -- | Get all the packages from the index. -- allPackages :: PackageIndex a -> [a] -allPackages (PackageIndex pids _) = Map.elems pids +allPackages = Map.elems . unitIdIndex -- | Get all the packages from the index. -- -- They are grouped by package name (case-sensitively). -- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] -allPackagesByName (PackageIndex _ pnames) = +allPackagesByName index = [ (pkgname, concat (Map.elems pvers)) - | (pkgname, pvers) <- Map.toList pnames ] + | (pkgname, pvers) <- Map.toList (packageIdIndex index) ] -- | Get all the packages from the index. -- @@ -370,23 +371,30 @@ allPackagesByName (PackageIndex _ pnames) = -- allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a -> [(PackageId, [a])] -allPackagesBySourcePackageId (PackageIndex _ pnames) = +allPackagesBySourcePackageId index = [ (packageId ipkg, ipkgs) - | pvers <- Map.elems pnames + | pvers <- Map.elems (packageIdIndex index) , ipkgs@(ipkg:_) <- Map.elems pvers ] -- -- * Lookups -- --- | Does a lookup by source package id (name & version). +-- | Does a lookup by unit identifier. -- -- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. -- lookupUnitId :: PackageIndex a -> UnitId -> Maybe a -lookupUnitId (PackageIndex pids _) pid = Map.lookup pid pids +lookupUnitId index uid = Map.lookup uid (unitIdIndex index) + +-- | Does a lookup by component identifier. In the absence +-- of Backpack, this is just a 'lookupUnitId'. +-- +lookupComponentId :: PackageIndex a -> ComponentId + -> Maybe a +lookupComponentId index uid = Map.lookup (SimpleUnitId uid) (unitIdIndex index) -- | Backwards compatibility for Cabal pre-1.24. {-# DEPRECATED lookupInstalledPackageId "Use lookupUnitId instead" #-} @@ -402,8 +410,8 @@ lookupInstalledPackageId = lookupUnitId -- preference, with the most preferred first. -- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] -lookupSourcePackageId (PackageIndex _ pnames) pkgid = - case Map.lookup (packageName pkgid) pnames of +lookupSourcePackageId index pkgid = + case Map.lookup (packageName pkgid) (packageIdIndex index) of Nothing -> [] Just pvers -> case Map.lookup (packageVersion pkgid) pvers of Nothing -> [] @@ -421,8 +429,8 @@ lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of -- lookupPackageName :: PackageIndex a -> PackageName -> [(Version, [a])] -lookupPackageName (PackageIndex _ pnames) name = - case Map.lookup name pnames of +lookupPackageName index name = + case Map.lookup name (packageIdIndex index) of Nothing -> [] Just pvers -> Map.toList pvers @@ -434,8 +442,8 @@ lookupPackageName (PackageIndex _ pnames) name = -- lookupDependency :: PackageIndex a -> Dependency -> [(Version, [a])] -lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = - case Map.lookup name pnames of +lookupDependency index (Dependency name versionRange) = + case Map.lookup name (packageIdIndex index) of Nothing -> [] Just pvers -> [ entry | entry@(ver, _) <- Map.toList pvers @@ -458,8 +466,8 @@ lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = -- it is a non-empty list of non-empty lists. -- searchByName :: PackageIndex a -> String -> SearchResult [a] -searchByName (PackageIndex _ pnames) name = - case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames +searchByName index name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList (packageIdIndex index) , lowercase name' == lname ] of [] -> None [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) @@ -475,9 +483,9 @@ data SearchResult a = None | Unambiguous a | Ambiguous [a] -- That is, all packages that contain the given string in their name. -- searchByNameSubstring :: PackageIndex a -> String -> [a] -searchByNameSubstring (PackageIndex _ pnames) searchterm = +searchByNameSubstring index searchterm = [ pkg - | (PackageName name, pvers) <- Map.toList pnames + | (PackageName name, pvers) <- Map.toList (packageIdIndex index) , lsearchterm `isInfixOf` lowercase name , pkgs <- Map.elems pvers , pkg <- pkgs ] diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index ac6ba0b6538..b4d58dc7fd7 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -210,6 +210,10 @@ data GhcOptions = GhcOptions { -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. ghcOptVerbosity :: Flag Verbosity, + -- | Put the extra folders in the PATH environment variable we invoke + -- GHC with + ghcOptExtraPath :: NubListR FilePath, + -- | Let GHC know that it is Cabal that's calling it. -- Modifies some of the GHC error messages. ghcOptCabal :: Flag Bool @@ -251,7 +255,9 @@ runGHC verbosity ghcProg comp platform opts = do ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> ProgramInvocation ghcInvocation prog comp platform opts = - programInvocation prog (renderGhcOptions comp platform opts) + (programInvocation prog (renderGhcOptions comp platform opts)) { + progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) + } renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] renderGhcOptions comp _platform@(Platform _arch os) opts diff --git a/Cabal/Distribution/Simple/Program/Run.hs b/Cabal/Distribution/Simple/Program/Run.hs index 5da7ec05612..3e54b585a9a 100644 --- a/Cabal/Distribution/Simple/Program/Run.hs +++ b/Cabal/Distribution/Simple/Program/Run.hs @@ -32,6 +32,7 @@ import Distribution.Verbosity import Distribution.Compat.Environment import qualified Data.Map as Map +import System.FilePath import System.Exit ( ExitCode(..), exitWith ) @@ -46,6 +47,8 @@ data ProgramInvocation = ProgramInvocation { progInvokePath :: FilePath, progInvokeArgs :: [String], progInvokeEnv :: [(String, Maybe String)], + -- Extra paths to add to PATH + progInvokePathEnv :: [FilePath], progInvokeCwd :: Maybe FilePath, progInvokeInput :: Maybe String, progInvokeInputEncoding :: IOEncoding, @@ -61,6 +64,7 @@ emptyProgramInvocation = progInvokePath = "", progInvokeArgs = [], progInvokeEnv = [], + progInvokePathEnv = [], progInvokeCwd = Nothing, progInvokeInput = Nothing, progInvokeInputEncoding = IOEncodingText, @@ -91,6 +95,7 @@ runProgramInvocation verbosity progInvokePath = path, progInvokeArgs = args, progInvokeEnv = [], + progInvokePathEnv = [], progInvokeCwd = Nothing, progInvokeInput = Nothing } = @@ -101,10 +106,12 @@ runProgramInvocation verbosity progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, + progInvokePathEnv = extraPath, progInvokeCwd = mcwd, progInvokeInput = Nothing } = do - menv <- getEffectiveEnvironment envOverrides + pathOverride <- getExtraPathEnv envOverrides extraPath + menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) exitCode <- rawSystemIOWithEnv verbosity path args mcwd menv @@ -117,11 +124,13 @@ runProgramInvocation verbosity progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, + progInvokePathEnv = extraPath, progInvokeCwd = mcwd, progInvokeInput = Just inputStr, progInvokeInputEncoding = encoding } = do - menv <- getEffectiveEnvironment envOverrides + pathOverride <- getExtraPathEnv envOverrides extraPath + menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) (_, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv @@ -141,6 +150,7 @@ getProgramInvocationOutput verbosity progInvokePath = path, progInvokeArgs = args, progInvokeEnv = envOverrides, + progInvokePathEnv = extraPath, progInvokeCwd = mcwd, progInvokeInput = minputStr, progInvokeOutputEncoding = encoding @@ -148,7 +158,8 @@ getProgramInvocationOutput verbosity let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False decode | utf8 = fromUTF8 . normaliseLineEndings | otherwise = id - menv <- getEffectiveEnvironment envOverrides + pathOverride <- getExtraPathEnv envOverrides extraPath + menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) (output, errors, exitCode) <- rawSystemStdInOut verbosity path args mcwd menv @@ -166,6 +177,18 @@ getProgramInvocationOutput verbosity IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 +getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] +getExtraPathEnv _ [] = return [] +getExtraPathEnv env extras = do + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] + -- | Return the current environment extended with the given overrides. -- getEffectiveEnvironment :: [(String, Maybe String)] diff --git a/Cabal/Distribution/Simple/Register.hs b/Cabal/Distribution/Simple/Register.hs index 8425be81874..d3f7702205d 100644 --- a/Cabal/Distribution/Simple/Register.hs +++ b/Cabal/Distribution/Simple/Register.hs @@ -88,12 +88,13 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8 register :: PackageDescription -> LocalBuildInfo -> RegisterFlags -- ^Install in the user's database?; verbose -> IO () -register pkg_descr lbi flags = when (hasPublicLib pkg_descr) doRegister +register pkg_descr lbi flags = + -- Duncan originally asked for us to not register/install files + -- when there was no public library. But with per-component + -- configure, we legitimately need to install internal libraries + -- so that we can get them. So just unconditionally install. + doRegister where - -- We do NOT register libraries outside of the inplace database - -- if there is no public library, since no one else can use it - -- usefully (they're not public.) If we start supporting scoped - -- packages, we'll have to relax this. doRegister = do targets <- readTargetInfos verbosity pkg_descr lbi (regArgs flags) diff --git a/Cabal/Distribution/Simple/Setup.hs b/Cabal/Distribution/Simple/Setup.hs index fbadd5d635d..fa2eaab1016 100644 --- a/Cabal/Distribution/Simple/Setup.hs +++ b/Cabal/Distribution/Simple/Setup.hs @@ -347,6 +347,10 @@ relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . display) $ pkgs -- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' -- should be updated. data ConfigFlags = ConfigFlags { + -- This is the same hack as in 'buildArgs' and 'copyArgs'. + -- TODO: Stop using this eventually when 'UserHooks' gets changed + configArgs :: [String], + --FIXME: the configPrograms is only here to pass info through to configure -- because the type of configure is constrained by the UserHooks. -- when we change UserHooks next we should pass the initial @@ -387,6 +391,7 @@ data ConfigFlags = ConfigFlags { -- frameworks (OS X only) configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files configIPID :: Flag String, -- ^ explicit IPID to be used + configCID :: Flag ComponentId, -- ^ explicit CID to be used configDistPref :: Flag FilePath, -- ^"dist" prefix configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use @@ -399,7 +404,7 @@ data ConfigFlags = ConfigFlags { configStripLibs :: Flag Bool, -- ^Enable library stripping configConstraints :: [Dependency], -- ^Additional constraints for -- dependencies. - configDependencies :: [(PackageName, UnitId)], + configDependencies :: [(PackageName, ComponentId)], -- ^The packages depended on. configConfigurationsFlags :: FlagAssignment, configTests :: Flag Bool, -- ^Enable test suite compilation @@ -435,6 +440,7 @@ configAbsolutePaths f = defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags { + configArgs = [], configPrograms_ = pure progConf, configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, configVanillaLib = Flag True, @@ -672,6 +678,11 @@ configureOptions showOrParseArgs = configIPID (\v flags -> flags {configIPID = v}) (reqArgFlag "IPID") + ,option "" ["cid"] + "Installed component ID to compile this component as" + (fmap display . configCID) (\v flags -> flags {configCID = fmap ComponentId v}) + (reqArgFlag "CID") + ,option "" ["extra-lib-dirs"] "A list of directories to search for external libraries" configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) @@ -698,7 +709,7 @@ configureOptions showOrParseArgs = ,option "" ["dependency"] "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" configDependencies (\v flags -> flags { configDependencies = v}) - (reqArg "NAME=ID" + (reqArg "NAME=CID" (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency)) (map (\x -> display (fst x) ++ "=" ++ display (snd x)))) @@ -784,7 +795,7 @@ showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] showProfDetailLevelFlag NoFlag = [] showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] -parseDependency :: Parse.ReadP r (PackageName, UnitId) +parseDependency :: Parse.ReadP r (PackageName, ComponentId) parseDependency = do x <- parse _ <- Parse.char '=' @@ -875,6 +886,7 @@ data CopyFlags = CopyFlags { copyAssumeDepsUpToDate :: Flag Bool, -- This is the same hack as in 'buildArgs'. But I (ezyang) don't -- think it's a hack, it's the right way to make hooks more robust + -- TODO: Stop using this eventually when 'UserHooks' gets changed copyArgs :: [String] } deriving (Show, Generic) diff --git a/Cabal/Distribution/Simple/UserHooks.hs b/Cabal/Distribution/Simple/UserHooks.hs index 5f0fd21ed10..b3ba6cf9b99 100644 --- a/Cabal/Distribution/Simple/UserHooks.hs +++ b/Cabal/Distribution/Simple/UserHooks.hs @@ -164,7 +164,7 @@ emptyUserHooks readDesc = return Nothing, hookedPreProcessors = [], hookedPrograms = [], - preConf = rn, + preConf = rn', confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), postConf = ru, preBuild = rn', diff --git a/Cabal/Distribution/Types/ComponentEnabledSpec.hs b/Cabal/Distribution/Types/ComponentEnabledSpec.hs index 78227cd1779..2ecfb1f15c0 100644 --- a/Cabal/Distribution/Types/ComponentEnabledSpec.hs +++ b/Cabal/Distribution/Types/ComponentEnabledSpec.hs @@ -15,6 +15,7 @@ module Distribution.Types.ComponentEnabledSpec ( import Prelude () import Distribution.Compat.Prelude +import Distribution.Text import Distribution.Types.Component -- TODO: maybe remove me? import Distribution.Types.ComponentName @@ -50,11 +51,10 @@ import Distribution.Types.ComponentName -- -- @since 2.0.0.0 data ComponentEnabledSpec - = ComponentEnabledSpec { - testsEnabled :: Bool, - benchmarksEnabled :: Bool - } - deriving (Generic, Read, Show) + = ComponentEnabledSpec { testsEnabled :: Bool, + benchmarksEnabled :: Bool } + | OneComponentEnabledSpec ComponentName + deriving (Generic, Read, Show, Eq) instance Binary ComponentEnabledSpec -- | The default set of enabled components. Historically tests and @@ -91,11 +91,16 @@ componentDisabledReason enabled comp -- @since 2.0.0.0 componentNameDisabledReason :: ComponentEnabledSpec -> ComponentName -> Maybe ComponentDisabledReason -componentNameDisabledReason enabled (CTestName _) - | not (testsEnabled enabled) = Just DisabledAllTests -componentNameDisabledReason enabled (CBenchName _) - | not (benchmarksEnabled enabled) = Just DisabledAllBenchmarks -componentNameDisabledReason _ _ = Nothing +componentNameDisabledReason + ComponentEnabledSpec{ testsEnabled = False } (CTestName _) + = Just DisabledAllTests +componentNameDisabledReason + ComponentEnabledSpec{ benchmarksEnabled = False } (CBenchName _) + = Just DisabledAllBenchmarks +componentNameDisabledReason ComponentEnabledSpec{} _ = Nothing +componentNameDisabledReason (OneComponentEnabledSpec cname) c + | c == cname = Nothing + | otherwise = Just (DisabledAllButOne (display cname)) -- | A reason explaining why a component is disabled. -- @@ -103,3 +108,4 @@ componentNameDisabledReason _ _ = Nothing data ComponentDisabledReason = DisabledComponent | DisabledAllTests | DisabledAllBenchmarks + | DisabledAllButOne String diff --git a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs index b6611724cf7..79eb824623f 100644 --- a/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/Cabal/Distribution/Types/ComponentLocalBuildInfo.hs @@ -40,6 +40,7 @@ data ComponentLocalBuildInfo -- @-package-id@ arguments. This is a modernized version of -- 'componentPackageDeps', which is kept around for BC purposes. componentIncludes :: [(UnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], -- | The internal dependencies which induce a graph on the -- 'ComponentLocalBuildInfo' of this package. This does NOT -- coincide with 'componentPackageDeps' because it ALSO records @@ -62,6 +63,7 @@ data ComponentLocalBuildInfo componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], componentIncludes :: [(UnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } | TestComponentLocalBuildInfo { @@ -69,6 +71,7 @@ data ComponentLocalBuildInfo componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], componentIncludes :: [(UnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } @@ -77,6 +80,7 @@ data ComponentLocalBuildInfo componentUnitId :: UnitId, componentPackageDeps :: [(UnitId, PackageId)], componentIncludes :: [(UnitId, ModuleRenaming)], + componentExeDeps :: [UnitId], componentInternalDeps :: [UnitId] } deriving (Generic, Read, Show) diff --git a/Cabal/Distribution/Types/LocalBuildInfo.hs b/Cabal/Distribution/Types/LocalBuildInfo.hs index 15ae66a7f83..dfbaf10e720 100644 --- a/Cabal/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/Distribution/Types/LocalBuildInfo.hs @@ -29,6 +29,7 @@ module Distribution.Types.LocalBuildInfo ( -- details. componentNameTargets', + unitIdTarget', allTargetsInBuildOrder', withAllTargetsInBuildOrder', neededTargetsInBuildOrder', @@ -39,6 +40,7 @@ module Distribution.Types.LocalBuildInfo ( -- prevent someone from accidentally defining them componentNameTargets, + unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, @@ -210,6 +212,12 @@ componentNameTargets' pkg_descr lbi cname = Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis Nothing -> [] +unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo +unitIdTarget' pkg_descr lbi uid = + case Graph.lookup uid (componentGraph lbi) of + Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) + Nothing -> Nothing + -- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] @@ -262,11 +270,14 @@ testCoverage lbi = exeCoverage lbi && libCoverage lbi ------------------------------------------------------------------------------- -- Stub functions to prevent someone from accidentally defining them -{-# WARNING componentNameTargets, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} +{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi +unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo +unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi + allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi diff --git a/Cabal/Distribution/Types/PackageDescription.hs b/Cabal/Distribution/Types/PackageDescription.hs index b026d571fdc..734ca3506f3 100644 --- a/Cabal/Distribution/Types/PackageDescription.hs +++ b/Cabal/Distribution/Types/PackageDescription.hs @@ -43,6 +43,7 @@ module Distribution.Types.PackageDescription ( updatePackageDescription, pkgComponents, pkgBuildableComponents, + enabledComponents, lookupComponent, getComponent, ) where @@ -57,6 +58,7 @@ import Distribution.Types.Benchmark import Distribution.Types.Component import Distribution.Types.ComponentName +import Distribution.Types.ComponentEnabledSpec import Distribution.Types.SetupBuildInfo import Distribution.Types.BuildInfo import Distribution.Types.BuildType @@ -346,6 +348,13 @@ pkgComponents pkg = pkgBuildableComponents :: PackageDescription -> [Component] pkgBuildableComponents = filter componentBuildable . pkgComponents +-- | A list of all components in the package that are enabled. +-- +-- @since 2.0.0.0 +-- +enabledComponents :: PackageDescription -> ComponentEnabledSpec -> [Component] +enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg + lookupComponent :: PackageDescription -> ComponentName -> Maybe Component lookupComponent pkg CLibName = fmap CLib (library pkg) lookupComponent pkg (CSubLibName name) = diff --git a/Cabal/changelog b/Cabal/changelog index 1965a5fc597..aef6aac05ac 100644 --- a/Cabal/changelog +++ b/Cabal/changelog @@ -66,6 +66,13 @@ internal use. * Macros in 'cabal_macros.h' are now ifndef'd, so that they don't cause an error if the macro is already defined. (#3041) + * './Setup configure' now accepts a single argument specifying + the component to be configured. The semantics of this mode + of operation are described in + + * Internal 'build-tools' dependencies are now added to PATH + upon invocation of GHC, so that they can be conveniently + used via `-pgmF`. (#1541) 1.24.0.0 Ryan Thomas March 2016 * Support GHC 8. diff --git a/Cabal/doc/developing-packages.markdown b/Cabal/doc/developing-packages.markdown index f20d1c83f22..64cc60dadfb 100644 --- a/Cabal/doc/developing-packages.markdown +++ b/Cabal/doc/developing-packages.markdown @@ -1416,7 +1416,8 @@ for these fields. build this package, e.g. `c2hs >= 0.15, cpphs`. If no version constraint is specified, any version is assumed to be acceptable. `build-tools` can refer to locally defined executables, in which - case Cabal will make sure that executable is built first. + case Cabal will make sure that executable is built first and + add it to the PATH upon invocations to the compiler. `buildable:` _boolean_ (default: `True`) : Is the component buildable? Like some of the other fields below, diff --git a/Cabal/doc/installing-packages.markdown b/Cabal/doc/installing-packages.markdown index c95037f56d7..e1996429fe0 100644 --- a/Cabal/doc/installing-packages.markdown +++ b/Cabal/doc/installing-packages.markdown @@ -410,6 +410,35 @@ is passed the `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, value of the `--with-compiler` option is passed in a `--with-hc` option and all options specified with `--configure-option=` are passed on. +In Cabal 2.0, support for a single positional argument was added to `setup configure` +This makes Cabal configure a the specific component to be +configured. Specified names can be qualified with `lib:` or +`exe:` in case just a name is ambiguous (as would be the case +for a package named `p` which has a library and an executable +named `p`.) This has the following effects: + +* Subsequent invocations of `build`, `register`, etc. operate only + on the configured component. + +* Cabal requires all "internal" dependencies (e.g., an executable + depending on a library defined in the same package) must be + found in the set of databases via `--package-db` (and related flags): + these dependencies are assumed to be up-to-date. A dependency can + be explicitly specified using `--dependency` simply by giving + the name of the internal library; e.g., the dependency for an + internal library named `foo` is given as `--dependency=pkg-internal=pkg-1.0-internal-abcd`. + +* Only the dependencies needed for the requested component are + required. Similarly, when `--exact-configuration` is specified, + it's only necessary to specify `--dependency` for the component. + (As mentioned previously, you *must* specify internal dependencies + as well.) + +* Internal `build-tools` dependencies are expected to be in the `PATH` + upon subsequent invocations of `setup`. + +Full details can be found in the [Componentized Cabal proposal](https://github.com/ezyang/ghc-proposals/blob/master/proposals/0000-componentized-cabal.rst). + ### Programs used for building ### The following options govern the programs used to process the source @@ -753,6 +782,19 @@ be controlled with the following command line options. To reset the stack, use `--package-db=clear`. +`--ipid=`_ipid_ +: Specifies the _installed package identifier_ of the package to be + built; this identifier is passed on to GHC and serves as the basis + for linker symbols and the `id` field in a `ghc-pkg` registration. + When a package has multiple components, the actual component + identifiers are derived off of this identifier (e.g., an + internal library `foo` from package `p-0.1-abcd` will get the + identifier `p-0.1-abcd-foo`. + +`--cid=`_cid_ +: Specifies the _component identifier_ of the component being built; + this is only valid if you are configuring a single component. + `--default-user-config=` _file_ : Allows a "default" `cabal.config` freeze file to be passed in manually. This file will only be used if one does not exist in the @@ -954,6 +996,18 @@ be controlled with the following command line options. for libraries it is also saved in the package registration information and used when compiling modules that use the library. +`--dependency`[=_pkgname_=_ipid_] +: Specify that a particular dependency should used for a particular + package name. In particular, it declares that any reference to + _pkgname_ in a `build-depends` should be resolved to _ipid_. + +`--exact-configuration` +: This changes Cabal to require every dependency be explicitly + specified using `--dependency`, rather than use Cabal's + (very simple) dependency solver. This is useful for programmatic + use of Cabal's API, where you want to error if you didn't + specify enough `--dependency` flags. + `--allow-newer`[=_pkgs_], `--allow-older`[=_pkgs_] : Selectively relax upper or lower bounds in dependencies without editing the package description respectively. diff --git a/Cabal/tests/PackageTests/BuildToolsPath/A.hs b/Cabal/tests/PackageTests/BuildToolsPath/A.hs new file mode 100644 index 00000000000..e5e075ad70c --- /dev/null +++ b/Cabal/tests/PackageTests/BuildToolsPath/A.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-} +module A where + +a :: String +a = "0000" diff --git a/Cabal/tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs b/Cabal/tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs new file mode 100644 index 00000000000..09c949ab176 --- /dev/null +++ b/Cabal/tests/PackageTests/BuildToolsPath/MyCustomPreprocessor.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.IO + +main :: IO () +main = do + (_:source:target:_) <- getArgs + let f '0' = '1' + f c = c + writeFile target . map f =<< readFile source diff --git a/Cabal/tests/PackageTests/BuildToolsPath/build-tools-path.cabal b/Cabal/tests/PackageTests/BuildToolsPath/build-tools-path.cabal new file mode 100644 index 00000000000..12214a34357 --- /dev/null +++ b/Cabal/tests/PackageTests/BuildToolsPath/build-tools-path.cabal @@ -0,0 +1,25 @@ +name: build-tools-path +version: 0.1.0.0 +synopsis: Checks build-tools are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable my-custom-preprocessor + main-is: MyCustomPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 + +library + exposed-modules: A + build-depends: base + build-tools: my-custom-preprocessor + -- ^ Note the internal dependency. + default-language: Haskell2010 + +executable hello-world + main-is: Hello.hs + build-depends: base, build-tools-path + default-language: Haskell2010 + hs-source-dirs: hello diff --git a/Cabal/tests/PackageTests/BuildToolsPath/hello/Hello.hs b/Cabal/tests/PackageTests/BuildToolsPath/hello/Hello.hs new file mode 100644 index 00000000000..89a5e5a026d --- /dev/null +++ b/Cabal/tests/PackageTests/BuildToolsPath/hello/Hello.hs @@ -0,0 +1,6 @@ +module Main where + +import A + +main :: IO () +main = putStrLn a diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Exe/Bad.hs b/Cabal/tests/PackageTests/ConfigureComponent/Exe/Bad.hs new file mode 100644 index 00000000000..65ae4a05d5d --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Exe/Bad.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Exe/Exe.cabal b/Cabal/tests/PackageTests/ConfigureComponent/Exe/Exe.cabal new file mode 100644 index 00000000000..5c2822092fe --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Exe/Exe.cabal @@ -0,0 +1,18 @@ +name: Exe +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +executable goodexe + main-is: Good.hs + build-depends: base + default-language: Haskell2010 + +-- We deliberately don't configure badexe, so that we can build ONLY goodexe +executable badexe + main-is: Bad.hs + build-depends: totally-impossible-dependency-to-fill == 10000.25.6 + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Exe/Good.hs b/Cabal/tests/PackageTests/ConfigureComponent/Exe/Good.hs new file mode 100644 index 00000000000..e8efe592d0c --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Exe/Good.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "OK" diff --git a/Cabal/tests/PackageTests/ConfigureComponent/SubLib/Lib.cabal b/Cabal/tests/PackageTests/ConfigureComponent/SubLib/Lib.cabal new file mode 100644 index 00000000000..85f5d879a9d --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/SubLib/Lib.cabal @@ -0,0 +1,18 @@ +name: Lib +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library sublib + build-depends: base + exposed-modules: Lib + default-language: Haskell2010 + +executable exe + main-is: Exe.hs + build-depends: base, sublib + hs-source-dirs: exe + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/ConfigureComponent/SubLib/Lib.hs b/Cabal/tests/PackageTests/ConfigureComponent/SubLib/Lib.hs new file mode 100644 index 00000000000..1d7d07d5cba --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/SubLib/Lib.hs @@ -0,0 +1,2 @@ +module Lib where +lib = "OK" diff --git a/Cabal/tests/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs b/Cabal/tests/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs new file mode 100644 index 00000000000..6ee3fb933aa --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/SubLib/exe/Exe.hs @@ -0,0 +1,2 @@ +import Lib +main = putStrLn lib diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Test/Lib.hs b/Cabal/tests/PackageTests/ConfigureComponent/Test/Lib.hs new file mode 100644 index 00000000000..1d7d07d5cba --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Test/Lib.hs @@ -0,0 +1,2 @@ +module Lib where +lib = "OK" diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Test/Test.cabal b/Cabal/tests/PackageTests/ConfigureComponent/Test/Test.cabal new file mode 100644 index 00000000000..e1b1eca8182 --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Test/Test.cabal @@ -0,0 +1,18 @@ +name: test-for-cabal +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Lib + build-depends: base + default-language: Haskell2010 + +test-suite testsuite + build-depends: test-for-cabal, testlib, base + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: tests diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs b/Cabal/tests/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs new file mode 100644 index 00000000000..d3104869944 --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Test/testlib/TestLib.hs @@ -0,0 +1,3 @@ +module TestLib where +import Lib +testlib = lib diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Test/testlib/testlib.cabal b/Cabal/tests/PackageTests/ConfigureComponent/Test/testlib/testlib.cabal new file mode 100644 index 00000000000..7ea7e7e3a8a --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Test/testlib/testlib.cabal @@ -0,0 +1,12 @@ +name: testlib +version: 0.1.0.0 +license: BSD3 +author: Edward Z. Yang +maintainer: ezyang@cs.stanford.edu +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: TestLib + build-depends: test-for-cabal, base + default-language: Haskell2010 diff --git a/Cabal/tests/PackageTests/ConfigureComponent/Test/tests/Test.hs b/Cabal/tests/PackageTests/ConfigureComponent/Test/tests/Test.hs new file mode 100644 index 00000000000..63654821ba5 --- /dev/null +++ b/Cabal/tests/PackageTests/ConfigureComponent/Test/tests/Test.hs @@ -0,0 +1,2 @@ +import TestLib +main = putStrLn testlib diff --git a/Cabal/tests/PackageTests/Tests.hs b/Cabal/tests/PackageTests/Tests.hs index 9ebe68fbfb3..20ea7061c22 100644 --- a/Cabal/tests/PackageTests/Tests.hs +++ b/Cabal/tests/PackageTests/Tests.hs @@ -439,6 +439,31 @@ tests config = do _ <- shell "autoreconf" ["-i"] cabal_build [] + tc "ConfigureComponent/Exe" $ do + withPackageDb $ do + cabal_install ["goodexe"] + runExe' "goodexe" [] >>= assertOutputContains "OK" + + tcs "ConfigureComponent/SubLib" "sublib-explicit" $ do + withPackageDb $ do + cabal_install ["sublib", "--cid", "sublib-0.1-abc"] + cabal_install ["exe", "--dependency", "sublib=sublib-0.1-abc"] + runExe' "exe" [] >>= assertOutputContains "OK" + + tcs "ConfigureComponent/SubLib" "sublib" $ do + withPackageDb $ do + cabal_install ["sublib"] + cabal_install ["exe"] + runExe' "exe" [] >>= assertOutputContains "OK" + + tcs "ConfigureComponent/Test" "test" $ do + withPackageDb $ do + cabal_install ["test-for-cabal"] + withPackage "testlib" $ cabal_install [] + cabal "configure" ["testsuite"] + cabal "build" [] + cabal "test" [] + -- Test that per-component copy works, when only building library tc "CopyComponent/Lib" $ withPackageDb $ do @@ -459,6 +484,12 @@ tests config = do runExe' "hello-world" [] >>= assertOutputContains "hello from A" + -- Test PATH-munging + tc "BuildToolsPath" $ do + cabal_build [] + runExe' "hello-world" [] + >>= assertOutputContains "1111" + -- Test that executable recompilation works -- https://github.com/haskell/cabal/issues/3294 tc "Regression/T3294" $ do @@ -580,9 +611,9 @@ tests config = do uid = componentUnitId (targetCLBI target) dir = libdir (absoluteComponentInstallDirs pkg_descr lbi uid NoCopyDest) - assertBool "interface files should NOT be installed" . not + assertBool "interface files should be installed" =<< liftIO (doesFileExist (dir "Foo.hi")) - assertBool "static library should NOT be installed" . not + assertBool "static library should be installed" =<< liftIO (doesFileExist (dir mkLibName uid)) if is_dynamic then @@ -590,7 +621,7 @@ tests config = do =<< liftIO (doesFileExist (dir mkSharedLibName compiler_id uid)) else - assertBool "dynamic library should NOT be installed" . not + assertBool "dynamic library should be installed" =<< liftIO (doesFileExist (dir mkSharedLibName compiler_id uid)) shouldFail $ ghcPkg "describe" ["foo"] diff --git a/cabal-install/Distribution/Client/BuildTarget.hs b/cabal-install/Distribution/Client/BuildTarget.hs index 537b743f9ff..eeeb15a4220 100644 --- a/cabal-install/Distribution/Client/BuildTarget.hs +++ b/cabal-install/Distribution/Client/BuildTarget.hs @@ -8,11 +8,17 @@ -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified build targets +-- Unlike "Distribution.Simple.BuildTarget" these build +-- targets also handle package qualification (so, up to +-- four levels of qualification, as opposed to the former's +-- three.) ----------------------------------------------------------------------------- module Distribution.Client.BuildTarget ( -- * Build targets BuildTarget(..), + -- Don't export me: it's partial (if you try to qualify too + -- much you will error.) --showBuildTarget, QualLevel(..), buildTargetPackage, @@ -431,7 +437,9 @@ showUserBuildTarget = intercalate ":" . components showBuildTarget :: QualLevel -> BuildTarget PackageInfo -> String showBuildTarget ql = showUserBuildTarget . forgetFileStatus - . head . renderBuildTarget ql + . hd . renderBuildTarget ql + where hd [] = error "showBuildTarget: head" + hd (x:_) = x -- ------------------------------------------------------------ diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index 8a5afe80c86..840ecf9a74c 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -63,6 +63,7 @@ buildAction (configFlags, configExFlags, installFlags, haddockFlags) -- repl targets (as opposed to say repl or haddock targets). selectBuildTargets = selectTargets + verbosity BuildDefaultComponents BuildSpecificComponent diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index 1aa072ecd98..8b6115e3e91 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -7,13 +7,10 @@ module Distribution.Client.CmdFreeze ( ) where import Distribution.Client.ProjectPlanning - ( ElaboratedInstallPlan, rebuildInstallPlan ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..) , commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig , findProjectRoot ) -import Distribution.Client.ProjectPlanning.Types - ( ElaboratedConfiguredPackage(..) ) import Distribution.Client.Targets ( UserConstraint(..) ) import Distribution.Solver.Types.ConstraintSource @@ -149,16 +146,16 @@ projectFreezeConstraints plan = flagAssignments = Map.fromList [ (pkgname, flags) - | InstallPlan.Configured pkg <- InstallPlan.toList plan - , let flags = pkgFlagAssignment pkg - pkgname = packageName pkg + | InstallPlan.Configured elab <- InstallPlan.toList plan + , let flags = elabFlagAssignment elab + pkgname = packageName elab , not (null flags) ] localPackages :: Map PackageName () localPackages = Map.fromList - [ (packageName pkg, ()) - | InstallPlan.Configured pkg <- InstallPlan.toList plan - , pkgLocalToProject pkg + [ (packageName elab, ()) + | InstallPlan.Configured elab <- InstallPlan.toList plan + , elabLocalToProject elab ] diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index e277f50147a..3bce9cee581 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -67,6 +67,7 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags) -- repl targets (as opposed to say build or haddock targets). selectReplTargets = selectTargets + verbosity ReplDefaultComponent ReplSpecificComponent diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 84ff09053cb..5545a7dedda 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -266,6 +266,7 @@ instance Semigroup SavedConfig where lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags combinedSavedConfigureFlags = ConfigFlags { + configArgs = lastNonEmpty configArgs, configPrograms_ = configPrograms_ . savedConfigureFlags $ b, -- TODO: NubListify configProgramPaths = lastNonEmpty configProgramPaths, @@ -301,6 +302,7 @@ instance Semigroup SavedConfig where -- TODO: NubListify configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs, configIPID = combine configIPID, + configCID = combine configCID, configDistPref = combine configDistPref, configCabalFilePath = combine configCabalFilePath, configVerbosity = combine configVerbosity, diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index 412f3dbff96..81f6faaa560 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/cabal-install/Distribution/Client/Configure.hs @@ -55,7 +55,7 @@ import Distribution.Simple.PackageIndex import Distribution.Simple.Utils ( defaultPackageDesc ) import Distribution.Package - ( Package(..), UnitId, packageName + ( Package(..), packageName , Dependency(..), thisPackageVersion ) import qualified Distribution.PackageDescription as PkgDesc @@ -203,6 +203,7 @@ configureSetupScript packageDBs , useDistPref = distPref , useLoggingHandle = Nothing , useWorkingDir = Nothing + , useExtraPathEnv = [] , setupCacheLock = lock , useWin32CleanHack = False , forceExternalSetupMethod = forceExternal @@ -244,14 +245,14 @@ configureSetupScript packageDBs defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends maybeSetupBuildInfo - explicitSetupDeps :: Maybe [(UnitId, PackageId)] + explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)] explicitSetupDeps = do -- Check if there is an explicit setup stanza. _buildInfo <- maybeSetupBuildInfo -- Return the setup dependencies computed by the solver ReadyPackage cpkg <- mpkg - return [ ( uid, srcid ) - | ConfiguredId srcid uid <- CD.setupDeps (confPkgDeps cpkg) + return [ ( cid, srcid ) + | ConfiguredId srcid cid <- CD.setupDeps (confPkgDeps cpkg) ] -- | Warn if any constraints or preferences name packages that are not in the diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index c577991d564..92e322905fb 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -768,7 +768,7 @@ showPackageProblem (InvalidDep dep pkgid) = configuredPackageProblems :: Platform -> CompilerInfo -> SolverPackage UnresolvedPkgLoc -> [PackageProblem] configuredPackageProblems platform cinfo - (SolverPackage pkg specifiedFlags stanzas specifiedDeps') = + (SolverPackage pkg specifiedFlags stanzas specifiedDeps' _specifiedExeDeps') = [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] @@ -779,6 +779,7 @@ configuredPackageProblems platform cinfo ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps , not (packageSatisfiesDependency pkgid dep) ] + -- TODO: sanity tests on executable deps where specifiedDeps :: ComponentDeps [PackageId] specifiedDeps = fmap (map solverSrcId) specifiedDeps' diff --git a/cabal-install/Distribution/Client/DistDirLayout.hs b/cabal-install/Distribution/Client/DistDirLayout.hs index 41e8dd25bd3..cdf6f37ec18 100644 --- a/cabal-install/Distribution/Client/DistDirLayout.hs +++ b/cabal-install/Distribution/Client/DistDirLayout.hs @@ -5,17 +5,43 @@ -- The layout of the .\/dist\/ directory where cabal keeps all of it's state -- and build artifacts. -- -module Distribution.Client.DistDirLayout where +module Distribution.Client.DistDirLayout ( + -- 'DistDirLayout' + DistDirLayout(..), + DistDirParams(..), + defaultDistDirLayout, + + -- * 'CabalDirLayout' + CabalDirLayout(..), + defaultCabalDirLayout, +) where import System.FilePath import Distribution.Package - ( PackageId ) + ( PackageId, UnitId(..) ) import Distribution.Compiler import Distribution.Simple.Compiler (PackageDB(..)) import Distribution.Text +import Distribution.Types.ComponentName +import Distribution.System import Distribution.Client.Types ( InstalledPackageId ) +-- | Information which can be used to construct the path to +-- the build directory of a build. This is LESS fine-grained +-- than what goes into the hashed 'InstalledPackageId', +-- 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, + distParamPackageId :: PackageId, + distParamComponentName :: Maybe ComponentName, + distParamCompilerId :: CompilerId, + distParamPlatform :: Platform + -- TODO (see #3343): + -- Flag assignments + -- Optimization + } -- | The layout of the project state directory. Traditionally this has been @@ -31,11 +57,11 @@ data DistDirLayout = DistDirLayout { -- | The directory under dist where we keep the build artifacts for a -- package we're building from a local directory. -- - -- This uses a 'PackageId' not just a 'PackageName' because technically + -- This uses a 'UnitId' not just a 'PackageName' because technically -- we can have multiple instances of the same package in a solution -- (e.g. setup deps). -- - distBuildDirectory :: PackageId -> FilePath, + distBuildDirectory :: DistDirParams -> FilePath, distBuildRootDirectory :: FilePath, -- | The directory under dist where we put the unpacked sources of @@ -55,8 +81,8 @@ data DistDirLayout = DistDirLayout { -- | The location for package-specific cache files (e.g. state used in -- incremental rebuilds). -- - distPackageCacheFile :: PackageId -> String -> FilePath, - distPackageCacheDirectory :: PackageId -> FilePath, + distPackageCacheFile :: DistDirParams -> String -> FilePath, + distPackageCacheDirectory :: DistDirParams -> FilePath, distTempDirectory :: FilePath, distBinDirectory :: FilePath, @@ -88,7 +114,17 @@ defaultDistDirLayout projectRootDirectory = --TODO: switch to just dist at some point, or some other new name distBuildRootDirectory = distDirectory "build" - distBuildDirectory pkgid = distBuildRootDirectory display pkgid + distBuildDirectory params = + distBuildRootDirectory + display (distParamPlatform params) + display (distParamCompilerId params) + display (distParamPackageId params) + (case fmap componentNameString (distParamComponentName params) of + Nothing -> "" + Just Nothing -> "" + Just (Just str) -> "c" str) + (case distParamUnitId params of -- For Backpack + SimpleUnitId _ -> "") distUnpackedSrcRootDirectory = distDirectory "src" distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory @@ -97,8 +133,8 @@ defaultDistDirLayout projectRootDirectory = distProjectCacheDirectory = distDirectory "cache" distProjectCacheFile name = distProjectCacheDirectory name - distPackageCacheDirectory pkgid = distBuildDirectory pkgid "cache" - distPackageCacheFile pkgid name = distPackageCacheDirectory pkgid name + distPackageCacheDirectory params = distBuildDirectory params "cache" + distPackageCacheFile params name = distPackageCacheDirectory params name distTempDirectory = distDirectory "tmp" diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index dee92c97477..ca04073b4af 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -32,7 +32,7 @@ module Distribution.Client.Install ( import Data.Foldable ( traverse_ ) import Data.List - ( isPrefixOf, nub, sort, (\\) ) + ( isPrefixOf, nub, sort, (\\), find ) import qualified Data.Map as Map import qualified Data.Set as S import Data.Maybe @@ -77,6 +77,7 @@ import Distribution.Client.Dependency.Types import Distribution.Client.FetchUtils import Distribution.Client.HttpUtils ( HttpTransport (..) ) +import Distribution.Solver.Types.PackageFixedDeps import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackages, getInstalledPackages ) @@ -116,7 +117,6 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex -import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb ) import Distribution.Solver.Types.SourcePackage as SourcePackage @@ -150,10 +150,9 @@ import Distribution.Simple.Register (registerPackage) import Distribution.Simple.Program.HcPkg (MultiInstance(..)) import Distribution.Package ( PackageIdentifier(..), PackageId, packageName, packageVersion - , Package(..) + , Package(..), HasUnitId(..) , Dependency(..), thisPackageVersion - , UnitId(..) - , HasUnitId(..) ) + , UnitId(..) ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription ( PackageDescription, GenericPackageDescription(..), Flag(..) @@ -614,7 +613,7 @@ packageStatus installedPkgIndex cpkg = changes :: Installed.InstalledPackageInfo -> ReadyPackage -> [MergeResult PackageIdentifier PackageIdentifier] - changes pkg pkg' = filter changed $ + changes pkg (ReadyPackage pkg') = filter changed $ mergeBy (comparing packageName) -- deps of installed pkg (resolveInstalledIds $ Installed.depends pkg) @@ -1157,12 +1156,11 @@ performInstallations verbosity | otherwise = False substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath - substLogFileName template pkg ipid = fromPathTemplate + substLogFileName template pkg uid = fromPathTemplate . substPathTemplate env $ template - where env = initialPathTemplateEnv (packageId pkg) - ipid - (compilerInfo comp) platform + where env = initialPathTemplateEnv (packageId pkg) uid + (compilerInfo comp) platform miscOptions = InstallMisc { libVersion = flagToMaybe (configCabalVersion configExFlags) @@ -1180,7 +1178,7 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = InstallPlan.execute jobCtl keepGoing depsFailure plan0 $ \pkg -> do buildOutcome <- installPkg pkg - printBuildResult (packageId pkg) (installedPackageId pkg) buildOutcome + printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome return buildOutcome where @@ -1189,7 +1187,7 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = -- Print build log if something went wrong, and 'Installed $PKGID' -- otherwise. printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () - printBuildResult pkgid ipid buildOutcome = case buildOutcome of + printBuildResult pkgid uid buildOutcome = case buildOutcome of (Right _) -> notice verbosity $ "Installed " ++ display pkgid (Left _) -> do notice verbosity $ "Failed to install " ++ display pkgid @@ -1197,7 +1195,7 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = case useLogFile of Nothing -> return () Just (mkLogFileName, _) -> do - let logName = mkLogFileName pkgid ipid + let logName = mkLogFileName pkgid uid putStr $ "Build log ( " ++ logName ++ " ):\n" printFile logName @@ -1232,9 +1230,9 @@ installReadyPackage platform cinfo configFlags -- In the end only one set gets passed to Setup.hs configure, depending on -- the Cabal version we are talking to. configConstraints = [ thisPackageVersion srcid - | ConfiguredId srcid _uid <- CD.nonSetupDeps deps ], - configDependencies = [ (packageName srcid, uid) - | ConfiguredId srcid uid <- CD.nonSetupDeps deps ], + | ConfiguredId srcid _ipid <- CD.nonSetupDeps deps ], + configDependencies = [ (packageName srcid, dep_ipid) + | ConfiguredId srcid dep_ipid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. configExactConfiguration = toFlag True, configBenchmarks = toFlag False, @@ -1416,19 +1414,16 @@ installUnpackedPackage verbosity installLock numJobs -- Install phase onFailure InstallFailed $ criticalSection installLock $ do -- Actual installation - withWin32SelfUpgrade verbosity ipid configFlags + withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg $ do setup Cabal.copyCommand copyFlags mLogPath -- Capture installed package configuration file, so that -- it can be incorporated into the final InstallPlan - -- TODO: This is duplicated with - -- Distribution/Client/ProjectBuilding.hs, search for - -- the Note [Updating installedUnitId]. ipkgs <- genPkgConfs mLogPath let ipkgs' = case ipkgs of - [ipkg] -> [ipkg { Installed.installedUnitId = ipid }] - _ -> assert (any ((== ipid) + [ipkg] -> [ipkg { Installed.installedUnitId = uid }] + _ -> assert (any ((== uid) . Installed.installedUnitId) ipkgs) ipkgs let packageDBs = interpretPackageDbFlags @@ -1439,11 +1434,11 @@ installUnpackedPackage verbosity installLock numJobs NoMultiInstance packageDBs ipkg' - return (Right (BuildResult docsResult testsResult ipkgs')) + return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs'))) where pkgid = packageId pkg - ipid = installedUnitId rpkg + uid = installedUnitId rpkg cinfo = compilerInfo comp buildCommand' = buildCommand conf buildFlags _ = emptyBuildFlags { @@ -1484,7 +1479,7 @@ installUnpackedPackage verbosity installLock numJobs } where CompilerId flavor _ = compilerInfoId cinfo - env = initialPathTemplateEnv pkgid ipid cinfo platform + env = initialPathTemplateEnv pkgid uid cinfo platform userInstall = fromFlagOrDefault defaultUserInstall (configUserInstall configFlags') @@ -1531,7 +1526,7 @@ installUnpackedPackage verbosity installLock numJobs case useLogFile of Nothing -> return Nothing Just (mkLogFileName, _) -> do - let logFileName = mkLogFileName (packageId pkg) ipid + let logFileName = mkLogFileName (packageId pkg) uid logDir = takeDirectory logFileName unless (null logDir) $ createDirectoryIfMissing True logDir logFileExists <- doesFileExist logFileName @@ -1574,7 +1569,7 @@ withWin32SelfUpgrade :: Verbosity -> PackageDescription -> IO a -> IO a withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do +withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do defaultDirs <- InstallDirs.defaultInstallDirs compFlavor @@ -1602,10 +1597,10 @@ withWin32SelfUpgrade verbosity ipid configFlags cinfo platform pkg action = do templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault defaultDirs (configInstallDirs configFlags) absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid ipid + pkgid uid cinfo InstallDirs.NoCopyDest platform templateDirs substTemplate = InstallDirs.fromPathTemplate . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid ipid + where env = InstallDirs.initialPathTemplateEnv pkgid uid cinfo platform diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs index ce1289e23ab..66167b1c641 100644 --- a/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal-install/Distribution/Client/InstallPlan.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | @@ -21,10 +22,13 @@ module Distribution.Client.InstallPlan ( GenericInstallPlan, PlanPackage, GenericPlanPackage(..), + IsUnit, -- * Operations on 'InstallPlan's new, toList, + planIndepGoals, + depends, fromSolverInstallPlan, configureInstallPlan, @@ -63,27 +67,27 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Package - ( PackageIdentifier(..), Package(..) + ( Package(..) , HasUnitId(..), UnitId(..) ) import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl import Distribution.Text - ( display ) +import Text.PrettyPrint import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan) import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.InstSolverPackage -- TODO: Need this when we compute final UnitIds -- import qualified Distribution.Simple.Configure as Configure import Data.List - ( foldl', intercalate ) + ( foldl' ) import Data.Maybe - ( fromMaybe, catMaybes, isJust ) + ( fromMaybe, isJust ) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Compat.Binary (Binary(..)) @@ -151,18 +155,26 @@ import Prelude hiding (lookup) -- dependencies in cabal-install should consider what to do with these -- dependencies; if we give a 'PackageInstalled' instance it would be too easy -- to get this wrong (and, for instance, call graph traversal functions from --- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'. +-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'. data GenericPlanPackage ipkg srcpkg = PreExisting ipkg | Configured srcpkg deriving (Eq, Show, Generic) -instance (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +type IsUnit a = (IsNode a, Key a ~ UnitId) + +depends :: IsUnit a => a -> [UnitId] +depends = nodeNeighbors + +-- 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 -- TODO: change me - nodeKey = installedUnitId - nodeNeighbors = CD.flatDeps . depends + type Key (GenericPlanPackage ipkg srcpkg) = UnitId + nodeKey (PreExisting ipkg) = nodeKey ipkg + nodeKey (Configured spkg) = nodeKey spkg + nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg + nodeNeighbors (Configured spkg) = nodeNeighbors spkg instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg) @@ -175,18 +187,17 @@ instance (Package ipkg, Package srcpkg) => packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg -instance (PackageFixedDeps srcpkg, - PackageFixedDeps ipkg) => - PackageFixedDeps (GenericPlanPackage ipkg srcpkg) where - depends (PreExisting pkg) = depends pkg - depends (Configured pkg) = depends pkg - instance (HasUnitId ipkg, HasUnitId srcpkg) => HasUnitId (GenericPlanPackage ipkg srcpkg) where installedUnitId (PreExisting ipkg) = installedUnitId ipkg installedUnitId (Configured spkg) = installedUnitId spkg +instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) => + HasConfiguredId (GenericPlanPackage ipkg srcpkg) where + configuredId (PreExisting ipkg) = configuredId ipkg + configuredId (Configured pkg) = configuredId pkg + data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { planIndex :: !(PlanIndex ipkg srcpkg), planIndepGoals :: !IndependentGoals @@ -199,13 +210,6 @@ type InstallPlan = GenericInstallPlan type PlanIndex ipkg srcpkg = Graph (GenericPlanPackage ipkg srcpkg) -invariant :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg -> Bool -invariant plan = - valid (planIndepGoals plan) - (planIndex plan) - -- | Smart constructor that deals with caching the 'Graph' representation. -- mkInstallPlan :: PlanIndex ipkg srcpkg @@ -220,8 +224,7 @@ mkInstallPlan index indepGoals = internalError :: String -> a internalError msg = error $ "InstallPlan: internal error: " ++ msg -instance (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg, +instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, Binary ipkg, Binary srcpkg) => Binary (GenericInstallPlan ipkg srcpkg) where put GenericInstallPlan { @@ -233,16 +236,19 @@ instance (HasUnitId ipkg, PackageFixedDeps ipkg, (index, indepGoals) <- get return $! mkInstallPlan index indepGoals -showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg) +showPlanIndex :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) => PlanIndex ipkg srcpkg -> String -showPlanIndex index = - intercalate "\n" (map showPlanPackage (Graph.toList index)) - where showPlanPackage p = - showPlanPackageTag p ++ " " - ++ display (packageId p) ++ " (" - ++ display (installedUnitId p) ++ ")" - -showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg) +showPlanIndex index = renderStyle defaultStyle $ + vcat (map dispPlanPackage (Graph.toList index)) + where dispPlanPackage p = + hang (hsep [ text (showPlanPackageTag p) + , disp (packageId p) + , parens (disp (nodeKey p))]) 2 + (vcat (map disp (nodeNeighbors p))) + +showInstallPlan :: (Package ipkg, Package srcpkg, + IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> String showInstallPlan = showPlanIndex . planIndex @@ -252,16 +258,10 @@ showPlanPackageTag (Configured _) = "Configured" -- | Build an installation plan from a valid set of resolved packages. -- -new :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => IndependentGoals +new :: IndependentGoals -> PlanIndex ipkg srcpkg - -> Either [PlanProblem ipkg srcpkg] - (GenericInstallPlan ipkg srcpkg) -new indepGoals index = - case problems indepGoals index of - [] -> Right (mkInstallPlan index indepGoals) - probs -> Left probs + -> GenericInstallPlan ipkg srcpkg +new indepGoals index = mkInstallPlan index indepGoals toList :: GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg] @@ -273,12 +273,10 @@ toList = Graph.toList . planIndex -- the dependencies of a package or set of packages without actually -- installing the package itself, as when doing development. -- -remove :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +remove :: (IsUnit ipkg, IsUnit srcpkg) => (GenericPlanPackage ipkg srcpkg -> Bool) -> GenericInstallPlan ipkg srcpkg - -> Either [PlanProblem ipkg srcpkg] - (GenericInstallPlan ipkg srcpkg) + -> GenericInstallPlan ipkg srcpkg remove shouldRemove plan = new (planIndepGoals plan) newIndex where @@ -289,13 +287,13 @@ remove shouldRemove plan = -- must have exactly the same dependencies as the source one was configured -- with. -- -preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +preexisting :: (IsUnit ipkg, + IsUnit srcpkg) => UnitId -> ipkg -> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg -preexisting pkgid ipkg plan = assert (invariant plan') plan' +preexisting pkgid ipkg plan = plan' where plan' = plan { planIndex = Graph.insert (PreExisting ipkg) @@ -307,8 +305,7 @@ preexisting pkgid ipkg plan = assert (invariant plan') plan' -- | Lookup a package in the plan. -- -lookup :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +lookup :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> UnitId -> Maybe (GenericPlanPackage ipkg srcpkg) @@ -339,71 +336,8 @@ revDirectDeps plan pkgid = Nothing -> internalError "revDirectDeps: package not in graph" --- ------------------------------------------------------------ --- * Checking validity of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is 'acyclic', --- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the --- plan has to have a valid configuration (see 'configuredPackageValid'). --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => IndependentGoals - -> PlanIndex ipkg srcpkg - -> Bool -valid indepGoals index = - null $ problems indepGoals index - -data PlanProblem ipkg srcpkg = - PackageMissingDeps (GenericPlanPackage ipkg srcpkg) - [PackageIdentifier] - | PackageCycle [GenericPlanPackage ipkg srcpkg] - | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) - (GenericPlanPackage ipkg srcpkg) - --- | 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 :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => IndependentGoals - -> PlanIndex ipkg srcpkg - -> [PlanProblem ipkg srcpkg] -problems _indepGoals index = - - [ PackageMissingDeps pkg - (catMaybes - (map - (fmap packageId . flip Graph.lookup index) - missingDeps)) - | (pkg, missingDeps) <- Graph.broken index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- Graph.cycles index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- Graph.toList index - , Just pkg' <- map (flip Graph.lookup index) - (CD.flatDeps (depends 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 --- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: GenericPlanPackage ipkg srcpkg - -> GenericPlanPackage ipkg srcpkg - -> Bool -stateDependencyRelation (PreExisting _) (PreExisting _) = True -stateDependencyRelation (Configured _) (PreExisting _) = True -stateDependencyRelation (Configured _) (Configured _) = True -stateDependencyRelation (PreExisting _) (Configured _) = False - @@ -430,79 +364,85 @@ reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan) +-- Alert alert! Why does SolverId map to a LIST of plan packages? +-- The sordid story has to do with 'build-depends' on a package +-- with libraries and executables. In an ideal world, we would +-- ONLY depend on the library in this situation. But c.f. #3661 +-- some people rely on the build-depends to ALSO implicitly +-- depend on an executable. +-- +-- I don't want to commit to a strategy yet, so the only possible +-- thing you can do in this case is return EVERYTHING and let +-- the client filter out what they want (executables? libraries? +-- etc). This similarly implies we can't return a 'ConfiguredId' +-- because that's not enough information. + fromSolverInstallPlan :: - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - -- Maybe this should be a UnitId not ConfiguredId? - => ( (SolverId -> ConfiguredId) + (IsUnit ipkg, IsUnit srcpkg) + => ( (SolverId -> [GenericPlanPackage ipkg srcpkg]) -> SolverInstallPlan.SolverPlanPackage - -> GenericPlanPackage ipkg srcpkg) + -> [GenericPlanPackage ipkg srcpkg] ) -> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = - mkInstallPlan (Graph.fromList pkgs') + mkInstallPlan (Graph.fromList pkgs'') (SolverInstallPlan.planIndepGoals plan) where - (_, pkgs') = foldl' f' (Map.empty, []) (SolverInstallPlan.reverseTopologicalOrder plan) + (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, []) + (SolverInstallPlan.reverseTopologicalOrder plan) - f' (pidMap, pkgs) pkg = (pidMap', pkg' : pkgs) + f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs) where - pkg' = f (mapDep pidMap) pkg - - pidMap' - = case sid of - PreExistingId _pid uid -> - assert (uid == uid') pidMap - PlannedId pid -> - Map.insert pid uid' pidMap - where - sid = nodeKey pkg - uid' = nodeKey pkg' - - mapDep _ (PreExistingId pid uid) = ConfiguredId pid uid - mapDep pidMap (PlannedId pid) - | Just uid <- Map.lookup pid pidMap - = ConfiguredId pid uid - -- 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 (this also assumes that the graph - -- is not broken). - | otherwise - = error ("fromSolverInstallPlan mapDep: " ++ display pid) + 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 " ++ display uid) + mapDep pidMap _ (PlannedId pid) + | Just pkgs <- Map.lookup pid pidMap = pkgs + | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid) + -- This shouldn't happen, since mapDep should only be called + -- on neighbor SolverId, which must have all been done already + -- by the reverse top-sort (we assume the graph is not broken). -- | Conversion of 'SolverInstallPlan' to 'InstallPlan'. -- Similar to 'elaboratedInstallPlan' configureInstallPlan :: SolverInstallPlan -> InstallPlan configureInstallPlan solverPlan = flip fromSolverInstallPlan solverPlan $ \mapDep planpkg -> - case planpkg of - SolverInstallPlan.PreExisting pkg _ -> - PreExisting pkg + [case planpkg of + SolverInstallPlan.PreExisting pkg -> + PreExisting (instSolverPkgIPI pkg) SolverInstallPlan.Configured pkg -> Configured (configureSolverPackage mapDep pkg) + ] where - configureSolverPackage :: (SolverId -> ConfiguredId) + configureSolverPackage :: (SolverId -> [PlanPackage]) -> SolverPackage UnresolvedPkgLoc -> ConfiguredPackage UnresolvedPkgLoc configureSolverPackage mapDep spkg = ConfiguredPackage { - confPkgId = SimpleUnitId - $ Configure.computeComponentId + confPkgId = Configure.computeComponentId + Cabal.NoFlag Cabal.NoFlag (packageId spkg) PD.CLibName - -- TODO: this is a hack that won't work for Backpack. - (map ((\(SimpleUnitId cid0) -> cid0) . confInstId) - (CD.libraryDeps deps)) + (map confInstId (CD.libraryDeps deps)) (solverPkgFlags spkg), confPkgSource = solverPkgSource spkg, confPkgFlags = solverPkgFlags spkg, confPkgStanzas = solverPkgStanzas spkg, confPkgDeps = deps + -- NB: no support for executable dependencies } where - deps = fmap (map mapDep) (solverPkgDeps spkg) + deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg) -- ------------------------------------------------------------ @@ -559,8 +499,7 @@ 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 :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +ready :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> ([GenericReadyPackage srcpkg], Processing) ready plan = @@ -569,13 +508,13 @@ ready plan = where !processing = Processing - (Set.fromList [ installedUnitId pkg | pkg <- readyPackages ]) - (Set.fromList [ installedUnitId pkg | PreExisting pkg <- toList plan ]) + (Set.fromList [ nodeKey pkg | pkg <- readyPackages ]) + (Set.fromList [ nodeKey pkg | PreExisting pkg <- toList plan ]) Set.empty readyPackages = [ ReadyPackage pkg | Configured pkg <- toList plan - , all isPreExisting (directDeps plan (installedUnitId pkg)) + , all isPreExisting (directDeps plan (nodeKey pkg)) ] isPreExisting (PreExisting {}) = True @@ -586,8 +525,7 @@ ready plan = -- and return any packages that are newly in the processing state (ie ready to -- process), along with the updated 'Processing' state. -- -completed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +completed :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> UnitId -> ([GenericReadyPackage srcpkg], Processing) @@ -603,20 +541,19 @@ completed plan (Processing processingSet completedSet failedSet) pkgid = -- each direct reverse dep where all direct deps are completed newlyReady = [ dep | dep <- revDirectDeps plan pkgid - , all ((`Set.member` completedSet') . installedUnitId) - (directDeps plan (installedUnitId dep)) + , all ((`Set.member` completedSet') . nodeKey) + (directDeps plan (nodeKey dep)) ] processingSet' = foldl' (flip Set.insert) (Set.delete pkgid processingSet) - (map installedUnitId newlyReady) + (map nodeKey newlyReady) processing' = Processing processingSet' completedSet' failedSet asReadyPackage (Configured pkg) = ReadyPackage pkg asReadyPackage _ = error "InstallPlan.completed: internal error" -failed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +failed :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> UnitId -> ([srcpkg], Processing) @@ -632,7 +569,7 @@ failed plan (Processing processingSet completedSet failedSet) pkgid = where processingSet' = Set.delete pkgid processingSet failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds - newlyFailedIds = map installedUnitId newlyFailed + newlyFailedIds = map nodeKey newlyFailed newlyFailed = fromMaybe (internalError "package not in graph") $ Graph.revClosure (planIndex plan) [pkgid] processing' = Processing processingSet' completedSet failedSet' @@ -640,8 +577,7 @@ failed plan (Processing processingSet completedSet failedSet) pkgid = asConfiguredPackage (Configured pkg) = pkg asConfiguredPackage _ = internalError "not in configured state" -processingInvariant :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> Bool processingInvariant plan (Processing processingSet completedSet failedSet) = @@ -660,7 +596,7 @@ processingInvariant plan (Processing processingSet completedSet failedSet) = | pkgid <- Set.toList processingSet ++ Set.toList failedSet ] where processingClosure = Set.fromList - . map installedUnitId + . map nodeKey . fromMaybe (internalError "processingClosure") . Graph.revClosure (planIndex plan) . Set.toList @@ -681,8 +617,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 :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +executionOrder :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg] executionOrder plan = @@ -695,7 +630,7 @@ executionOrder plan = waitForTasks processing p todo = p : tryNewTasks processing' (todo++nextpkgs) where - (nextpkgs, processing') = completed plan processing (installedUnitId p) + (nextpkgs, processing') = completed plan processing (nodeKey p) -- ------------------------------------------------------------ @@ -724,8 +659,7 @@ lookupBuildOutcome = Map.lookup . installedUnitId -- can be reversed to keep going and build as many packages as possible. -- execute :: forall m ipkg srcpkg result failure. - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg, + (IsUnit ipkg, IsUnit srcpkg, Monad m) => JobControl m (UnitId, Either failure result) -> Bool -- ^ Keep going after failure @@ -763,7 +697,7 @@ execute jobCtl keepGoing depFailure plan installPkg = | otherwise = do sequence_ [ spawnJob jobCtl $ do result <- installPkg pkg - return (installedUnitId pkg, result) + return (nodeKey pkg, result) | pkg <- newpkgs ] waitForTasks results tasksFailed processing @@ -795,5 +729,5 @@ execute jobCtl keepGoing depFailure plan installPkg = (depsfailed, processing') = failed plan processing pkgid results' = Map.insert pkgid result results `Map.union` depResults depResults = Map.fromList - [ (installedUnitId deppkg, Left (depFailure deppkg)) + [ (nodeKey deppkg, Left (depFailure deppkg)) | deppkg <- depsfailed ] diff --git a/cabal-install/Distribution/Client/PackageHash.hs b/cabal-install/Distribution/Client/PackageHash.hs index 2f56e5672e6..63e61ee01e8 100644 --- a/cabal-install/Distribution/Client/PackageHash.hs +++ b/cabal-install/Distribution/Client/PackageHash.hs @@ -29,7 +29,7 @@ module Distribution.Client.PackageHash ( ) where import Distribution.Package - ( PackageId, PackageIdentifier(..), mkUnitId ) + ( PackageId, PackageIdentifier(..), ComponentId(..) ) import Distribution.System ( Platform, OS(Windows), buildOS ) import Distribution.PackageDescription @@ -43,6 +43,7 @@ import Distribution.Text ( display ) import Distribution.Client.Types ( InstalledPackageId ) +import qualified Distribution.Solver.Types.ComponentDeps as CD import qualified Hackage.Security.Client as Sec @@ -85,7 +86,7 @@ hashedInstalledPackageId -- hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkUnitId $ + ComponentId $ display pkgHashPkgId -- to be a bit user friendly ++ "-" ++ showHashValue (hashPackageHashInputs pkghashinputs) @@ -110,7 +111,7 @@ hashedInstalledPackageIdLong pkghashinputs@PackageHashInputs{pkgHashPkgId} = -- hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = - mkUnitId $ + ComponentId $ intercalate "-" -- max length now 64 [ truncateStr 14 (display name) @@ -133,6 +134,7 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} = -- data PackageHashInputs = PackageHashInputs { pkgHashPkgId :: PackageId, + pkgHashComponent :: Maybe CD.Component, pkgHashSourceHash :: PackageSourceHash, pkgHashDirectDeps :: Set InstalledPackageId, pkgHashOtherConfig :: PackageHashConfigInputs @@ -188,6 +190,7 @@ hashPackageHashInputs = hashValue . renderPackageHashInputs renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString renderPackageHashInputs PackageHashInputs{ pkgHashPkgId, + pkgHashComponent, pkgHashSourceHash, pkgHashDirectDeps, pkgHashOtherConfig = @@ -209,6 +212,7 @@ renderPackageHashInputs PackageHashInputs{ -- use the config file infrastructure so it can be read back in again. LBS.pack $ unlines $ catMaybes [ entry "pkgid" display pkgHashPkgId + , mentry "component" show pkgHashComponent , entry "src" showHashValue pkgHashSourceHash , entry "deps" (intercalate ", " . map display . Set.toList) pkgHashDirectDeps @@ -239,6 +243,7 @@ renderPackageHashInputs PackageHashInputs{ ] where entry key format value = Just (key ++ ": " ++ format value) + mentry key format value = fmap (\v -> key ++ ": " ++ format v) value opt key def format value | value == def = Nothing | otherwise = entry key format value diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index 5d3522610eb..1dc4e2e0278 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -1,12 +1,16 @@ {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NamedFieldPuns, DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE ConstraintKinds #-} -- | -- module Distribution.Client.ProjectBuilding ( -- * Dry run phase BuildStatus(..), + buildStatusToString, BuildStatusMap, BuildStatusRebuild(..), BuildReason(..), @@ -26,12 +30,13 @@ import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.RebuildMonad import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types import Distribution.Client.Types hiding (BuildOutcomes, BuildOutcome, BuildResult(..), BuildFailure(..)) import Distribution.Client.InstallPlan - ( GenericInstallPlan, GenericPlanPackage ) + ( GenericInstallPlan, GenericPlanPackage, IsUnit ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.DistDirLayout import Distribution.Client.FileMonitor @@ -44,10 +49,6 @@ import Distribution.Client.Setup (filterConfigureFlags) import Distribution.Client.SrcDist (allPackageSourceFiles) import Distribution.Client.Utils (removeExistingFile) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import Distribution.Solver.Types.PackageFixedDeps - import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.InstalledPackageInfo (InstalledPackageInfo) import qualified Distribution.InstalledPackageInfo as Installed @@ -64,6 +65,7 @@ import Distribution.Version import Distribution.Verbosity import Distribution.Text import Distribution.ParseUtils ( showPWarning ) +import Distribution.Compat.Graph (IsNode(..)) import Data.Map (Map) import qualified Data.Map as Map @@ -122,7 +124,7 @@ import System.Directory -- -- This is used as the result of the dry-run of building an install plan. -- -type BuildStatusMap = Map InstalledPackageId BuildStatus +type BuildStatusMap = Map UnitId BuildStatus -- | The build status for an individual package is the state that the -- package is in /prior/ to initiating a (re)build. @@ -162,6 +164,13 @@ data BuildStatus = -- and it does not need to be built. | BuildStatusUpToDate BuildResult +buildStatusToString :: BuildStatus -> String +buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting" +buildStatusToString BuildStatusDownload = "BuildStatusDownload" +buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp +buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp +buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate" + -- | For a package that is going to be built or rebuilt, the state it's in now. -- -- So again, this tells us why a package needs to be rebuilt and what build @@ -179,8 +188,10 @@ data BuildStatusRebuild = -- -- The optional registration info here tells us if we've registered the -- package already, or if we stil need to do that after building. + -- @Just Nothing@ indicates that we know that no registration is + -- necessary (e.g., executable.) -- - | BuildStatusBuild (Maybe [InstalledPackageInfo]) BuildReason + | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason data BuildReason = -- | The depencencies of this package have been (re)built so the build @@ -227,10 +238,12 @@ buildStatusRequiresBuild _ = True -- the 'ElaboratedInstallPlan' with packages switched to the -- 'InstallPlan.Installed' state when we find that they're already up to date. -- -rebuildTargetsDryRun :: DistDirLayout +rebuildTargetsDryRun :: Verbosity + -> DistDirLayout + -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, BuildStatusMap) -rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do +rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \installPlan -> do -- Do the various checks to work out the 'BuildStatus' of each package pkgsBuildStatus <- foldMInstallPlanDepOrder installPlan dryRunPkg @@ -239,17 +252,18 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do -- 'InstallPlan.Installed'. let installPlan' = improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus + debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan' return (installPlan', pkgsBuildStatus) where dryRunPkg :: ElaboratedPlanPackage - -> ComponentDeps [BuildStatus] + -> [BuildStatus] -> IO BuildStatus dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = return BuildStatusPreExisting dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do - mloc <- checkFetched (pkgSourceLocation pkg) + mloc <- checkFetched (elabPkgSourceLocation pkg) case mloc of Nothing -> return BuildStatusDownload @@ -271,11 +285,11 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do dryRunTarballPkg pkg depsBuildStatus tarball dryRunTarballPkg :: ElaboratedConfiguredPackage - -> ComponentDeps [BuildStatus] + -> [BuildStatus] -> FilePath -> IO BuildStatus dryRunTarballPkg pkg depsBuildStatus tarball = - case pkgBuildStyle pkg of + case elabBuildStyle pkg of BuildAndInstall -> return (BuildStatusUnpack tarball) BuildInplaceOnly -> do -- TODO: [nice to have] use a proper file monitor rather than this dir exists test @@ -287,7 +301,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do srcdir = distUnpackedSrcDirectory (packageId pkg) dryRunLocalPkg :: ElaboratedConfiguredPackage - -> ComponentDeps [BuildStatus] + -> [BuildStatus] -> FilePath -> IO BuildStatus dryRunLocalPkg pkg depsBuildStatus srcdir = do @@ -305,7 +319,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do return (BuildStatusUpToDate buildResult) where packageFileMonitor = - newPackageFileMonitor distDirLayout (packageId pkg) + newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg) -- | A specialised traversal over the packages in an install plan. @@ -318,30 +332,28 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do -- foldMInstallPlanDepOrder :: forall m ipkg srcpkg b. - (Monad m, - HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) + (Monad m, IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> (GenericPlanPackage ipkg srcpkg -> - ComponentDeps [b] -> m b) - -> m (Map InstalledPackageId b) + [b] -> m b) + -> m (Map UnitId b) foldMInstallPlanDepOrder plan0 visit = go Map.empty (InstallPlan.reverseTopologicalOrder plan0) where - go :: Map InstalledPackageId b + go :: Map UnitId b -> [GenericPlanPackage ipkg srcpkg] - -> m (Map InstalledPackageId b) + -> m (Map UnitId 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 - let depresults :: ComponentDeps [b] + let depresults :: [b] depresults = - fmap (map (\ipkgid -> let Just result = Map.lookup ipkgid results - in result)) - (depends pkg) + map (\ipkgid -> let Just result = Map.lookup ipkgid results + in result) + (InstallPlan.depends pkg) result <- visit pkg depresults - let results' = Map.insert (installedPackageId pkg) result results + let results' = Map.insert (nodeKey pkg) result results go results' pkgs improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan @@ -349,22 +361,24 @@ improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan -> ElaboratedInstallPlan improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = replaceWithPrePreExisting installPlan - [ (installedPackageId pkg, ipkgs) + [ (installedUnitId pkg, mipkg) | InstallPlan.Configured pkg <- InstallPlan.reverseTopologicalOrder installPlan - , let ipkgid = installedPackageId pkg - Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus - , BuildStatusUpToDate (BuildResult { buildResultLibInfo = ipkgs }) + , let uid = installedUnitId pkg + Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus + , BuildStatusUpToDate (BuildResult { buildResultLibInfo = mipkg }) <- [pkgBuildStatus] ] where replaceWithPrePreExisting = - foldl' (\plan (ipkgid, ipkgs) -> - case find (\ipkg -> installedPackageId ipkg == ipkgid) ipkgs of - Just ipkg -> InstallPlan.preexisting ipkgid ipkg plan - Nothing -> unexpected) - unexpected = - error "improveInstallPlanWithUpToDatePackages: dep on non lib package" + foldl' (\plan (uid, mipkg) -> + -- TODO: A grievous hack. Better to have a special type + -- of entry representing pre-existing executables. + let stub_ipkg = Installed.emptyInstalledPackageInfo { + Installed.installedUnitId = uid + } + ipkg = fromMaybe stub_ipkg mipkg + in InstallPlan.preexisting uid ipkg plan) ----------------------------- @@ -384,7 +398,7 @@ improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = data PackageFileMonitor = PackageFileMonitor { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (), pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc, - pkgFileMonitorReg :: FileMonitor () [InstalledPackageInfo] + pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) } -- | This is all the components of the 'BuildResult' other than the @@ -395,22 +409,22 @@ data PackageFileMonitor = PackageFileMonitor { -- type BuildResultMisc = (DocsResult, TestsResult) -newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor -newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid = +newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor +newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams = PackageFileMonitor { pkgFileMonitorConfig = - newFileMonitor (distPackageCacheFile pkgid "config"), + newFileMonitor (distPackageCacheFile dparams "config"), pkgFileMonitorBuild = FileMonitor { - fileMonitorCacheFile = distPackageCacheFile pkgid "build", + fileMonitorCacheFile = distPackageCacheFile dparams "build", fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt, fileMonitorCheckIfOnlyValueChanged = True }, pkgFileMonitorReg = - newFileMonitor (distPackageCacheFile pkgid "registration") + newFileMonitor (distPackageCacheFile dparams "registration") } -- | Helper function for 'checkPackageFileMonitorChanged', @@ -421,8 +435,8 @@ newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid = -- packageFileMonitorKeyValues :: ElaboratedConfiguredPackage -> (ElaboratedConfiguredPackage, Set ComponentName) -packageFileMonitorKeyValues pkg = - (pkgconfig, buildComponents) +packageFileMonitorKeyValues elab = + (elab_config, buildComponents) where -- The first part is the value used to guard (re)configuring the package. -- That is, if this value changes then we will reconfigure. @@ -431,17 +445,18 @@ packageFileMonitorKeyValues pkg = -- do not affect the configure step need to be nulled out. Those parts are -- the specific targets that we're going to build. -- - pkgconfig = pkg { - pkgBuildTargets = [], - pkgReplTarget = Nothing, - pkgBuildHaddocks = False - } + elab_config = + elab { + elabBuildTargets = [], + elabReplTarget = Nothing, + elabBuildHaddocks = False + } -- The second part is the value used to guard the build step. So this is -- more or less the opposite of the first part, as it's just the info about -- what targets we're going to build. -- - buildComponents = pkgBuildTargetWholeComponents pkg + buildComponents = elabBuildTargetWholeComponents elab -- | Do all the checks on whether a package has changed and thus needs either -- rebuilding or reconfiguring and rebuilding. @@ -449,7 +464,7 @@ packageFileMonitorKeyValues pkg = checkPackageFileMonitorChanged :: PackageFileMonitor -> ElaboratedConfiguredPackage -> FilePath - -> ComponentDeps [BuildStatus] + -> [BuildStatus] -> IO (Either BuildStatusRebuild BuildResult) checkPackageFileMonitorChanged PackageFileMonitor{..} pkg srcdir depsBuildStatus = do @@ -466,7 +481,7 @@ checkPackageFileMonitorChanged PackageFileMonitor{..} -- The configChanged here includes the identity of the dependencies, -- so depsBuildStatus is just needed for the changes in the content -- of depencencies. - | any buildStatusRequiresBuild (CD.flatDeps depsBuildStatus) -> do + | any buildStatusRequiresBuild depsBuildStatus -> do regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () let mreg = changedToMaybe regChanged return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) @@ -504,12 +519,12 @@ checkPackageFileMonitorChanged PackageFileMonitor{..} where buildReason = BuildReasonEphemeralTargets - (MonitorUnchanged buildResult _, MonitorUnchanged ipkgs _) -> + (MonitorUnchanged buildResult _, MonitorUnchanged mipkg _) -> return $ Right BuildResult { buildResultDocs = docsResult, buildResultTests = testsResult, buildResultLogFile = Nothing, - buildResultLibInfo = ipkgs + buildResultLibInfo = mipkg } where (docsResult, testsResult) = buildResult @@ -562,12 +577,12 @@ updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild} updatePackageRegFileMonitor :: PackageFileMonitor -> FilePath - -> [InstalledPackageInfo] + -> Maybe InstalledPackageInfo -> IO () updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} - srcdir ipkgs = + srcdir mipkg = updateFileMonitor pkgFileMonitorReg srcdir Nothing - [] () ipkgs + [] () mipkg invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = @@ -593,7 +608,16 @@ data BuildResult = BuildResult { buildResultDocs :: DocsResult, buildResultTests :: TestsResult, buildResultLogFile :: Maybe FilePath, - buildResultLibInfo :: [InstalledPackageInfo] + -- | If the build was for a library, this field will be @Just@; + -- otherwise, it will be @Nothing@. What about internal + -- libraries? This never occurs, because a build result is either + -- for a per-component build (in which case there won't + -- be multiple libraries), or a package with no internal + -- libraries (internal libraries with Custom setups are NOT + -- supported, and even if they were supported, we could + -- assume the Cabal library version was recent enough to + -- support per-component build.). + buildResultLibInfo :: Maybe InstalledPackageInfo } deriving Show @@ -653,8 +677,8 @@ rebuildTargets verbosity cacheLock <- newLock -- serialise access to setup exe cache --TODO: [code cleanup] eliminate setup exe cache - createDirectoryIfMissingVerbose verbosity False distBuildRootDirectory - createDirectoryIfMissingVerbose verbosity False distTempDirectory + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory + createDirectoryIfMissingVerbose verbosity True distTempDirectory mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse -- Before traversing the install plan, pre-emptively find all packages that @@ -668,8 +692,8 @@ rebuildTargets verbosity installPlan $ \pkg -> handle (return . Left) $ fmap Right $ --TODO: review exception handling - let ipkgid = installedPackageId pkg - Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in + let uid = installedUnitId pkg + Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in rebuildTarget verbosity @@ -687,10 +711,10 @@ rebuildTargets verbosity packageDBsToUse = -- all the package dbs we may need to create (Set.toList . Set.fromList) [ pkgdb - | InstallPlan.Configured pkg <- InstallPlan.toList installPlan - , (pkgdb:_) <- map reverse [ pkgBuildPackageDBStack pkg, - pkgRegisterPackageDBStack pkg, - pkgSetupPackageDBStack pkg ] + | InstallPlan.Configured elab <- InstallPlan.toList installPlan + , (pkgdb:_) <- map reverse [ elabBuildPackageDBStack elab, + elabRegisterPackageDBStack elab, + elabSetupPackageDBStack elab ] ] -- | Given all the context and resources, (re)build an individual package. @@ -735,10 +759,10 @@ rebuildTarget verbosity unpackTarballPhase tarball = withTarballLocalDirectory verbosity distDirLayout tarball - (packageId pkg) (pkgBuildStyle pkg) - (pkgDescriptionOverride pkg) $ + (packageId pkg) (elabDistDirParams sharedPackageConfig pkg) (elabBuildStyle pkg) + (elabPkgDescriptionOverride pkg) $ - case pkgBuildStyle pkg of + case elabBuildStyle pkg of BuildAndInstall -> buildAndInstall BuildInplaceOnly -> buildInplace buildStatus where @@ -749,11 +773,11 @@ rebuildTarget verbosity -- would only start from download or unpack phases. -- rebuildPhase buildStatus srcdir = - assert (pkgBuildStyle pkg == BuildInplaceOnly) $ + assert (elabBuildStyle pkg == BuildInplaceOnly) $ buildInplace buildStatus srcdir builddir where - builddir = distBuildDirectory (packageId pkg) + builddir = distBuildDirectory (elabDistDirParams sharedPackageConfig pkg) buildAndInstall srcdir builddir = buildAndInstallUnpackedPackage @@ -801,11 +825,12 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body pkgsToDownload body where pkgsToDownload = - [ pkgSourceLocation pkg - | InstallPlan.Configured pkg + ordNub $ + [ elabPkgSourceLocation elab + | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan - , let ipkgid = installedPackageId pkg - Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus + , let uid = installedUnitId elab + Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] @@ -817,9 +842,9 @@ waitAsyncPackageDownload :: Verbosity -> AsyncFetchMap -> ElaboratedConfiguredPackage -> IO DownloadedSourceLocation -waitAsyncPackageDownload verbosity downloadMap pkg = do +waitAsyncPackageDownload verbosity downloadMap elab = do pkgloc <- waitAsyncFetchPackage verbosity downloadMap - (pkgSourceLocation pkg) + (elabPkgSourceLocation elab) case downloadedSourceLocation pkgloc of Just loc -> return loc Nothing -> fail "waitAsyncPackageDownload: unexpected source location" @@ -846,12 +871,15 @@ withTarballLocalDirectory -> DistDirLayout -> FilePath -> PackageId + -> DistDirParams -> BuildStyle -> Maybe CabalFileText - -> (FilePath -> FilePath -> IO a) + -> (FilePath -> -- Source directory + FilePath -> -- Build directory + IO a) -> IO a withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} - tarball pkgid buildstyle pkgTextOverride + tarball pkgid dparams buildstyle pkgTextOverride buildPkg = case buildstyle of -- In this case we make a temp dir, unpack the tarball to there and @@ -871,15 +899,15 @@ withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} BuildInplaceOnly -> do let srcrootdir = distUnpackedSrcRootDirectory srcdir = distUnpackedSrcDirectory pkgid - builddir = distBuildDirectory pkgid + builddir = distBuildDirectory dparams -- TODO: [nice to have] use a proper file monitor rather than this dir exists test exists <- doesDirectoryExist srcdir unless exists $ do - createDirectoryIfMissingVerbose verbosity False srcrootdir + createDirectoryIfMissingVerbose verbosity True srcrootdir unpackPackageTarball verbosity tarball srcrootdir pkgid pkgTextOverride moveTarballShippedDistDirectory verbosity distDirLayout - srcrootdir pkgid + srcrootdir pkgid dparams buildPkg srcdir builddir @@ -925,9 +953,9 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = -- system, though we'll still need to keep this hack for older packages. -- moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout - -> FilePath -> PackageId -> IO () + -> FilePath -> PackageId -> DistDirParams -> IO () moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} - parentdir pkgid = do + parentdir pkgid dparams = do distDirExists <- doesDirectoryExist tarballDistDir when distDirExists $ do debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '" @@ -936,7 +964,7 @@ moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory} renameDirectory tarballDistDir targetDistDir where tarballDistDir = parentdir display pkgid "dist" - targetDistDir = distBuildDirectory pkgid + targetDistDir = distBuildDirectory dparams buildAndInstallUnpackedPackage :: Verbosity @@ -961,7 +989,7 @@ buildAndInstallUnpackedPackage verbosity rpkg@(ReadyPackage pkg) srcdir builddir = do - createDirectoryIfMissingVerbose verbosity False builddir + createDirectoryIfMissingVerbose verbosity True builddir initLogFile --TODO: [code cleanup] deal consistently with talking to older Setup.hs versions, much like @@ -974,20 +1002,25 @@ buildAndInstallUnpackedPackage verbosity --TODO: [required feature] docs and tests --TODO: [required feature] sudo re-exec + let dispname = case elabPkgOrComp pkg of + ElabPackage _ -> display pkgid + ElabComponent comp -> display pkgid ++ " " + ++ maybe "custom" display (compComponentName comp) + -- Configure phase when isParallelBuild $ - notice verbosity $ "Configuring " ++ display pkgid ++ "..." + notice verbosity $ "Configuring " ++ dispname ++ "..." annotateFailure mlogFile ConfigureFailed $ - setup configureCommand configureFlags + setup' configureCommand configureFlags configureArgs -- Build phase when isParallelBuild $ - notice verbosity $ "Building " ++ display pkgid ++ "..." + notice verbosity $ "Building " ++ dispname ++ "..." annotateFailure mlogFile BuildFailed $ setup buildCommand buildFlags -- Install phase - ipkgs <- + mipkg <- annotateFailure mlogFile InstallFailed $ do --TODO: [required eventually] need to lock installing this ipkig so other processes don't -- stomp on our files, since we don't have ABI compat, not safe to replace @@ -1000,7 +1033,7 @@ buildAndInstallUnpackedPackage verbosity setup Cabal.copyCommand copyFlags LBS.writeFile - (InstallDirs.prefix (pkgInstallDirs pkg) "cabal-hash.txt") $ + (InstallDirs.prefix (elabInstallDirs pkg) "cabal-hash.txt") $ (renderPackageHashInputs (packageHashInputs pkgshared pkg)) -- here's where we could keep track of the installed files ourselves if @@ -1011,32 +1044,20 @@ buildAndInstallUnpackedPackage verbosity -- then when it's done, move it to its final location, to reduce problems -- with installs failing half-way. Could also register and then move. - if pkgRequiresRegistration pkg + if elabRequiresRegistration pkg then do - ipkgs <- generateInstalledPackageInfos -- 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. + ipkg0 <- generateInstalledPackageInfo + let ipkg = ipkg0 { Installed.installedUnitId = uid } - -- See Note [Updating installedUnitId] - let ipkgs' = case ipkgs of - -- Case A and B - [ipkg] -> [ipkg { Installed.installedUnitId = ipkgid }] - -- Case C - _ -> ipkgs - unless (any ((== ipkgid) . Installed.installedUnitId) ipkgs') $ - die $ "the package " ++ display (packageId pkg) ++ " was expected " - ++ " to produce registeration info for the unit Id " - ++ display ipkgid ++ " but it actually produced info for " - ++ intercalate ", " - (map (display . Installed.installedUnitId) ipkgs') criticalSection registerLock $ - forM_ ipkgs' $ \ipkg' -> Cabal.registerPackage verbosity compiler progdb HcPkg.MultiInstance - (pkgRegisterPackageDBStack pkg) ipkg' - return ipkgs' - else return [] + (elabRegisterPackageDBStack pkg) ipkg + return (Just ipkg) + else return Nothing --TODO: [required feature] docs and test phases let docsResult = DocsNotTried @@ -1046,12 +1067,12 @@ buildAndInstallUnpackedPackage verbosity buildResultDocs = docsResult, buildResultTests = testsResult, buildResultLogFile = mlogFile, - buildResultLibInfo = ipkgs + buildResultLibInfo = mipkg } where pkgid = packageId rpkg - ipkgid = installedPackageId rpkg + uid = installedUnitId rpkg isParallelBuild = buildSettingNumJobs >= 2 @@ -1059,13 +1080,14 @@ buildAndInstallUnpackedPackage verbosity configureFlags v = flip filterConfigureFlags v $ setupHsConfigureFlags rpkg pkgshared verbosity builddir + configureArgs = setupHsConfigureArgs pkg buildCommand = Cabal.buildCommand defaultProgramConfiguration buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir - generateInstalledPackageInfos :: IO [InstalledPackageInfo] - generateInstalledPackageInfos = - withTempInstalledPackageInfoFiles + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile verbosity distTempDirectory $ \pkgConfDest -> do let registerFlags _ = setupHsRegisterFlags pkg pkgshared @@ -1079,19 +1101,22 @@ buildAndInstallUnpackedPackage verbosity isParallelBuild cacheLock setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = + setup cmd flags = setup' cmd flags [] + + setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO () + setup' cmd flags args = withLogging $ \mLogFileHandle -> setupWrapper verbosity scriptOptions { useLoggingHandle = mLogFileHandle } - (Just (pkgDescription pkg)) - cmd flags [] + (Just (elabPkgDescription pkg)) + cmd flags args mlogFile :: Maybe FilePath mlogFile = case buildSettingLogFile of Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid ipkgid) + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) initLogFile = case mlogFile of @@ -1132,14 +1157,14 @@ buildInplaceUnpackedPackage verbosity --TODO: [code cleanup] there is duplication between the distdirlayout and the builddir here -- builddir is not enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity False builddir - createDirectoryIfMissingVerbose verbosity False (distPackageCacheDirectory pkgid) + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose verbosity True (distPackageCacheDirectory dparams) -- Configure phase -- whenReConfigure $ do annotateFailureNoLog ConfigureFailed $ - setup configureCommand configureFlags [] + setup configureCommand configureFlags configureArgs invalidatePackageRegFileMonitor packageFileMonitor updatePackageConfigFileMonitor packageFileMonitor srcdir pkg @@ -1165,78 +1190,28 @@ buildInplaceUnpackedPackage verbosity pkg buildStatus allSrcFiles buildResult - ipkgs <- whenReRegister $ + -- PURPOSELY omitted: no copy! + + mipkg <- whenReRegister $ annotateFailureNoLog InstallFailed $ do -- Register locally - ipkgs <- if pkgRequiresRegistration pkg + mipkg <- if elabRequiresRegistration pkg then do - ipkgs <- generateInstalledPackageInfos + ipkg0 <- generateInstalledPackageInfo -- 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. - - -- Note [Updating installedUnitId] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- This is a bit tricky. There are three variables we - -- care about: - -- - -- 1. Does the Setup script we're interfacing with - -- support --ipid? (Only if version >= 1.23) - -- If not, we have to explicitly update the - -- the UID that was recorded. - -- - -- 2. Does the Setup script we're interfacing with - -- support internal libraries? (Only if - -- version >= 1.25). If so, there may be - -- multiple IPIs... and it would be wrong to - -- update them all to the same UID (you need - -- to generate derived UIDs for each - -- subcomponent.) - -- - -- 3. Does GHC require that the IPID be input at - -- configure time? (Only if GHC >= 8.0, which - -- also implies Cabal version >= 1.23, as earlier - -- Cabal's don't know how to do this properly). - -- If so, it is IMPERMISSIBLE to update the - -- UID that was recorded. - -- - -- This means that there are three situations: - -- - -- A. Cabal < 1.23 - -- B. Cabal >= 1.23 && < 1.25 - -- C. Cabal >= 1.25 - -- - -- We consider each in turn: - -- - -- A. There is only ever one IPI, and we must - -- update it. - -- - -- B. There is only ever one IPI, but because - -- --ipid is supported, the installedUnitId of - -- this IPI is ipkgid (so it's harmless to - -- overwrite). - -- - -- C. There may be multiple IPIs, but because - -- --ipid is supported they always have the - -- right installedUnitIds. - -- - let ipkgs' = case ipkgs of - -- Case A and B - [ipkg] -> [ipkg { Installed.installedUnitId = ipkgid }] - -- Case C - _ -> assert (any ((== ipkgid) . Installed.installedUnitId) - ipkgs) ipkgs + let ipkg = ipkg0 { Installed.installedUnitId = ipkgid } criticalSection registerLock $ - forM_ ipkgs' $ \ipkg' -> Cabal.registerPackage verbosity compiler progdb HcPkg.NoMultiInstance - (pkgRegisterPackageDBStack pkg) - ipkg' - return ipkgs' + (elabRegisterPackageDBStack pkg) + ipkg + return (Just ipkg) - else return [] + else return Nothing - updatePackageRegFileMonitor packageFileMonitor srcdir ipkgs - return ipkgs + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + return mipkg -- Repl phase -- @@ -1253,42 +1228,43 @@ buildInplaceUnpackedPackage verbosity buildResultDocs = docsResult, buildResultTests = testsResult, buildResultLogFile = Nothing, - buildResultLibInfo = ipkgs + buildResultLibInfo = mipkg } where - pkgid = packageId rpkg - ipkgid = installedPackageId rpkg + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg isParallelBuild = buildSettingNumJobs >= 2 - packageFileMonitor = newPackageFileMonitor distDirLayout pkgid + packageFileMonitor = newPackageFileMonitor distDirLayout dparams whenReConfigure action = case buildStatus of BuildStatusConfigure _ -> action _ -> return () whenRebuild action - | null (pkgBuildTargets pkg) = return () + | null (elabBuildTargets pkg) = return () | otherwise = action whenRepl action - | isNothing (pkgReplTarget pkg) = return () + | isNothing (elabReplTarget pkg) = return () | otherwise = action whenHaddock action - | pkgBuildHaddocks pkg = action + | elabBuildHaddocks pkg = action | otherwise = return () whenReRegister action = case buildStatus of BuildStatusConfigure _ -> action BuildStatusBuild Nothing _ -> action - BuildStatusBuild (Just ipkgs) _ -> return ipkgs + BuildStatusBuild (Just mipkg) _ -> return mipkg configureCommand = Cabal.configureCommand defaultProgramConfiguration configureFlags v = flip filterConfigureFlags v $ setupHsConfigureFlags rpkg pkgshared verbosity builddir + configureArgs = setupHsConfigureArgs pkg buildCommand = Cabal.buildCommand defaultProgramConfiguration buildFlags _ = setupHsBuildFlags pkg pkgshared @@ -1312,12 +1288,12 @@ buildInplaceUnpackedPackage verbosity setup cmd flags args = setupWrapper verbosity scriptOptions - (Just (pkgDescription pkg)) + (Just (elabPkgDescription pkg)) cmd flags args - generateInstalledPackageInfos :: IO [InstalledPackageInfo] - generateInstalledPackageInfos = - withTempInstalledPackageInfoFiles + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile verbosity distTempDirectory $ \pkgConfDest -> do let registerFlags _ = setupHsRegisterFlags pkg pkgshared @@ -1353,10 +1329,10 @@ annotateFailure mlogFile annotate action = handler = throwIO . BuildFailure mlogFile . annotate . toException -withTempInstalledPackageInfoFiles :: Verbosity -> FilePath +withTempInstalledPackageInfoFile :: Verbosity -> FilePath -> (FilePath -> IO ()) - -> IO [InstalledPackageInfo] -withTempInstalledPackageInfoFiles verbosity tempdir action = + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do -- make absolute since @action@ will often change directory abs_dir <- canonicalizePath dir @@ -1364,14 +1340,7 @@ withTempInstalledPackageInfoFiles verbosity tempdir action = let pkgConfDest = abs_dir "pkgConf" action pkgConfDest - is_dir <- doesDirectoryExist pkgConfDest - - let notHidden = not . isHidden - isHidden name = "." `isPrefixOf` name - if is_dir - then mapM (readPkgConf pkgConfDest) . sort . filter notHidden - =<< getDirectoryContents pkgConfDest - else fmap (:[]) $ readPkgConf "." pkgConfDest + readPkgConf "." pkgConfDest where pkgConfParseFailed :: Installed.PError -> IO a pkgConfParseFailed perror = diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 2059e0c3c5b..e5be5281613 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -532,6 +532,7 @@ convertToLegacyAllPackageConfig } where configFlags = ConfigFlags { + configArgs = mempty, configPrograms_ = mempty, configProgramPaths = mempty, configProgramArgs = mempty, @@ -568,6 +569,7 @@ convertToLegacyAllPackageConfig configDependencies = mempty, configExtraIncludeDirs = mempty, configIPID = mempty, + configCID = mempty, configConfigurationsFlags = mempty, configTests = mempty, configCoverage = mempty, --TODO: don't merge @@ -595,6 +597,7 @@ convertToLegacyPerPackageConfig PackageConfig {..} = } where configFlags = ConfigFlags { + configArgs = mempty, configPrograms_ = configPrograms_ mempty, configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths), configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs), @@ -631,6 +634,7 @@ convertToLegacyPerPackageConfig PackageConfig {..} = configDependencies = mempty, configExtraIncludeDirs = packageConfigExtraIncludeDirs, configIPID = mempty, + configCID = mempty, configConfigurationsFlags = packageConfigFlagAssignment, configTests = packageConfigTests, configCoverage = packageConfigCoverage, --TODO: don't merge diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index ea50730a5a7..bede782e857 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -58,11 +58,11 @@ module Distribution.Client.ProjectOrchestration ( import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding import Distribution.Client.Types - ( InstalledPackageId, installedPackageId - , GenericReadyPackage(..), PackageLocation(..) ) + ( GenericReadyPackage(..), PackageLocation(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.BuildTarget ( UserBuildTarget, resolveUserBuildTargets @@ -79,7 +79,7 @@ import qualified Distribution.PackageDescription as PD import Distribution.PackageDescription (FlagAssignment) import Distribution.Simple.Setup (HaddockFlags) -import Distribution.Simple.Utils (die, notice) +import Distribution.Simple.Utils (die, notice, debug) import Distribution.Verbosity import Distribution.Text @@ -183,7 +183,7 @@ runProjectPreBuildPhase -- This also gives us more accurate reasons for the --dry-run output. -- (elaboratedPlan'', pkgsBuildStatus) <- - rebuildTargetsDryRun distDirLayout + rebuildTargetsDryRun verbosity distDirLayout elaboratedShared elaboratedPlan' return ProjectBuildContext { @@ -243,14 +243,34 @@ runProjectBuildPhase verbosity ProjectBuildContext {..} = -- | Adjust an 'ElaboratedInstallPlan' by selecting just those parts of it -- required to build the given user targets. -- --- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable. +-- How to get the 'PackageTarget's from the 'UserBuildTarget' is customisable, +-- so that we can change the meaning of @pkgname@ to target a build or +-- repl depending on which command is calling it. -- -selectTargets :: PackageTarget +-- Conceptually, every target identifies one or more roots in the +-- 'ElaboratedInstallPlan', which we then use to determine the closure +-- of what packages need to be built, dropping everything from +-- 'ElaboratedInstallPlan' that is unnecessary. +-- +-- There is a complication, however: In an ideal world, every +-- possible target would be a node in the graph. However, it is +-- currently not possible (and possibly not even desirable) to invoke a +-- Setup script to build *just* one file. Similarly, it is not possible +-- to invoke a pre Cabal-1.25 custom Setup script and build only one +-- component. In these cases, we want to build the entire package, BUT +-- only actually building some of the files/components. This is what +-- 'pkgBuildTargets', 'pkgReplTarget' and 'pkgBuildHaddock' control. +-- Arguably, these should an out-of-band mechanism rather than stored +-- in 'ElaboratedInstallPlan', but it's what we have. We have +-- to fiddle around with the ElaboratedConfiguredPackage roots to say +-- what it will build. +-- +selectTargets :: Verbosity -> PackageTarget -> (ComponentTarget -> PackageTarget) -> [UserBuildTarget] -> ElaboratedInstallPlan -> IO ElaboratedInstallPlan -selectTargets targetDefaultComponents targetSpecificComponent +selectTargets verbosity targetDefaultComponents targetSpecificComponent userBuildTargets installPlan = do -- Match the user targets against the available targets. If no targets are @@ -277,6 +297,7 @@ selectTargets targetDefaultComponents targetSpecificComponent targetSpecificComponent installPlan buildTargets + debug verbosity ("buildTargets': " ++ show buildTargets') -- Finally, prune the install plan to cover just those target packages -- and their deps. @@ -284,8 +305,8 @@ selectTargets targetDefaultComponents targetSpecificComponent return (pruneInstallPlanToTargets buildTargets' installPlan) where localPackages = - [ (pkgDescription pkg, pkgSourceLocation pkg) - | InstallPlan.Configured pkg <- InstallPlan.toList installPlan ] + [ (elabPkgDescription elab, elabPkgSourceLocation elab) + | InstallPlan.Configured elab <- InstallPlan.toList installPlan ] --TODO: [code cleanup] is there a better way to identify local packages? @@ -295,13 +316,14 @@ resolveAndCheckTargets :: PackageTarget -> ElaboratedInstallPlan -> [BuildTarget PackageName] -> Either [BuildTargetProblem] - (Map InstalledPackageId [PackageTarget]) + (Map UnitId [PackageTarget]) resolveAndCheckTargets targetDefaultComponents targetSpecificComponent installPlan targets = case partitionEithers (map checkTarget targets) of ([], targets') -> Right $ Map.fromListWith (++) - [ (ipkgid, [t]) | (ipkgid, t) <- targets' ] + [ (uid, [t]) | (uids, t) <- targets' + , uid <- uids ] (problems, _) -> Left problems where -- TODO [required eventually] currently all build targets refer to packages @@ -342,17 +364,20 @@ resolveAndCheckTargets targetDefaultComponents = Left (BuildTargetNotInProject (buildTargetPackage t)) - projAllPkgs, projLocalPkgs :: Map PackageName InstalledPackageId + -- NB: It's a list of 'InstalledPackageId', because each component + -- in the install plan from a single package needs to be associated with + -- the same 'PackageName'. + projAllPkgs, projLocalPkgs :: Map PackageName [UnitId] projAllPkgs = - Map.fromList - [ (packageName pkg, installedPackageId pkg) + Map.fromListWith (++) + [ (packageName pkg, [installedUnitId pkg]) | pkg <- InstallPlan.toList installPlan ] projLocalPkgs = - Map.fromList - [ (packageName pkg, installedPackageId pkg) - | InstallPlan.Configured pkg <- InstallPlan.toList installPlan - , case pkgSourceLocation pkg of + Map.fromListWith (++) + [ (packageName elab, [installedUnitId elab]) + | InstallPlan.Configured elab <- InstallPlan.toList installPlan + , case elabPkgSourceLocation elab of LocalUnpackedPackage _ -> True; _ -> False --TODO: [code cleanup] is there a better way to identify local packages? ] @@ -411,26 +436,31 @@ printPlan verbosity = notice verbosity $ unlines $ ("In order, the following " ++ wouldWill ++ " be built (use -v for more details):") - : map showPkg pkgs + : map (\(ReadyPackage pkg) -> showPkg pkg (elabPkgOrComp pkg)) pkgs where pkgs = InstallPlan.executionOrder elaboratedPlan wouldWill | buildSettingDryRun = "would" | otherwise = "will" - showPkg pkg = display (packageId pkg) + showPkg elab (ElabPackage _) = display (packageId elab) + showPkg elab (ElabComponent comp) = + display (packageId elab) ++ + " (" ++ maybe "custom" display (compComponentName comp) ++ ")" showPkgAndReason :: ElaboratedReadyPackage -> String - showPkgAndReason (ReadyPackage pkg) = - display (packageId pkg) ++ - showTargets pkg ++ - showFlagAssignment (nonDefaultFlags pkg) ++ - showStanzas pkg ++ - let buildStatus = pkgsBuildStatus Map.! installedPackageId pkg in + showPkgAndReason (ReadyPackage elab) = + display (installedUnitId elab) ++ + (case elabPkgOrComp elab of + ElabPackage pkg -> showTargets elab ++ showStanzas pkg + ElabComponent comp -> + " (" ++ maybe "custom" display (compComponentName comp) ++ ")") ++ + showFlagAssignment (nonDefaultFlags elab) ++ + let buildStatus = pkgsBuildStatus Map.! installedUnitId elab in " (" ++ showBuildStatus buildStatus ++ ")" nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment - nonDefaultFlags pkg = pkgFlagAssignment pkg \\ pkgFlagDefaults pkg + nonDefaultFlags elab = elabFlagAssignment elab \\ elabFlagDefaults elab showStanzas pkg = concat $ [ " *test" @@ -438,10 +468,10 @@ printPlan verbosity ++ [ " *bench" | BenchStanzas `Set.member` pkgStanzasEnabled pkg ] - showTargets pkg - | null (pkgBuildTargets pkg) = "" + showTargets elab + | null (elabBuildTargets elab) = "" | otherwise - = " (" ++ unwords [ showComponentTarget pkg t | t <- pkgBuildTargets pkg ] + = " (" ++ unwords [ showComponentTarget (packageId elab) t | t <- elabBuildTargets elab ] ++ ")" -- TODO: [code cleanup] this should be a proper function in a proper place diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs index 2dc10699c23..2b6f31d50de 100644 --- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs @@ -9,9 +9,8 @@ module Distribution.Client.ProjectPlanOutput ( ) where import Distribution.Client.ProjectPlanning.Types - ( ElaboratedInstallPlan, ElaboratedConfiguredPackage(..) - , ElaboratedSharedConfig(..) ) import Distribution.Client.DistDirLayout +import Distribution.Client.Types import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J @@ -66,27 +65,35 @@ encodePlanAsJson elaboratedInstallPlan _elaboratedSharedConfig = J.object [ "type" J..= J.String "pre-existing" , "id" J..= jdisplay (installedUnitId ipi) - , "components" J..= J.object - [ "lib" J..= J.object [ "depends" J..= map jdisplay (installedDepends ipi) ] ] + , "depends" J..= map jdisplay (installedDepends ipi) ] - -- ecp :: ElaboratedConfiguredPackage - toJ (InstallPlan.Configured ecp) = - J.object + -- pkg :: ElaboratedPackage + toJ (InstallPlan.Configured elab) = + J.object $ [ "type" J..= J.String "configured" - , "id" J..= (jdisplay . installedUnitId) ecp - , "components" J..= components + , "id" J..= (jdisplay . installedUnitId) elab , "flags" J..= J.object [ fn J..= v - | (PD.FlagName fn,v) <- pkgFlagAssignment ecp ] - ] - where - components = J.object - [ comp2str c J..= J.object - [ "depends" J..= map (jdisplay . installedUnitId) v ] - | (c,v) <- ComponentDeps.toList (pkgDependencies ecp) ] + | (PD.FlagName fn,v) <- + elabFlagAssignment elab ] + ] ++ + case elabPkgOrComp elab of + ElabPackage pkg -> + let components = J.object $ + [ comp2str c J..= J.object + [ "depends" J..= map (jdisplay . confInstId) v ] + | (c,v) <- ComponentDeps.toList (pkgLibDependencies pkg) ] ++ + [ comp2str c J..= J.object + [ "exe-depends" J..= map (jdisplay . confInstId) v ] + | (c,v) <- ComponentDeps.toList (pkgExeDependencies pkg) ] + in ["components" J..= components] + ElabComponent _ -> + ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) + ,"exe-depends" J..= map jdisplay (elabExeDependencies elab)] -- TODO: maybe move this helper to "ComponentDeps" module? -- Or maybe define a 'Text' instance? + comp2str :: ComponentDeps.Component -> String comp2str c = case c of ComponentDeps.ComponentLib -> "lib" ComponentDeps.ComponentSubLib s -> "lib:" <> s diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 970b7dea990..8584e3af1f1 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} -- | Planning how to build everything in a project. -- @@ -26,11 +29,12 @@ module Distribution.Client.ProjectPlanning ( -- * Utils required for building pkgHasEphemeralBuildTargets, - pkgBuildTargetWholeComponents, + elabBuildTargetWholeComponents, -- * Setup.hs CLI flags for building setupHsScriptOptions, setupHsConfigureFlags, + setupHsConfigureArgs, setupHsBuildFlags, setupHsBuildArgs, setupHsReplFlags, @@ -71,16 +75,17 @@ import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.System +import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.PackageDescription as Cabal import qualified Distribution.PackageDescription as PD import qualified Distribution.PackageDescription.Configuration as PD @@ -100,7 +105,6 @@ import qualified Distribution.Simple.LocalBuildInfo as Cabal import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.Register as Cabal import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Utils hiding (matchFileGlob) import Distribution.Version @@ -108,13 +112,12 @@ import Distribution.Verbosity import Distribution.Text import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph(IsNode(..)) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set -import qualified Data.Graph as OldGraph -import qualified Data.Tree as Tree #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif @@ -127,7 +130,7 @@ import Data.Either import Data.Monoid import Data.Function import System.FilePath -import System.Directory (doesDirectoryExist) +import System.Directory (doesDirectoryExist, getDirectoryContents) ------------------------------------------------------------------------------ -- * Elaborated install plan @@ -181,43 +184,69 @@ import System.Directory (doesDirectoryExist) -- | Check that an 'ElaboratedConfiguredPackage' actually makes -- sense under some 'ElaboratedSharedConfig'. -sanityCheckElaboratedConfiguredPackage :: ElaboratedSharedConfig - -> ElaboratedConfiguredPackage - -> a - -> a +sanityCheckElaboratedConfiguredPackage + :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> a + -> a sanityCheckElaboratedConfiguredPackage sharedConfig - pkg@ElaboratedConfiguredPackage{..} - ret = - - -- we should only have enabled stanzas that actually can be built - -- (according to the solver) - assert (pkgStanzasEnabled `Set.isSubsetOf` pkgStanzasAvailable) - - -- the stanzas that the user explicitly requested should be - -- enabled (by the previous test, they are also available) - . assert (Map.keysSet (Map.filter id pkgStanzasRequested) - `Set.isSubsetOf` pkgStanzasEnabled) - - -- the stanzas explicitly disabled should not be available - . assert (Set.null (Map.keysSet (Map.filter not pkgStanzasRequested) - `Set.intersection` pkgStanzasAvailable)) + elab@ElaboratedConfiguredPackage{..} = + (case elabPkgOrComp of + ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg + ElabComponent comp -> sanityCheckElaboratedComponent elab comp) -- either a package is being built inplace, or the -- 'installedPackageId' we assigned is consistent with -- the 'hashedInstalledPackageId' we would compute from -- the elaborated configured package - . assert (pkgBuildStyle == BuildInplaceOnly || - installedPackageId pkg == hashedInstalledPackageId - (packageHashInputs sharedConfig pkg)) + . assert (elabBuildStyle == BuildInplaceOnly || + unitIdComponentId elabUnitId == hashedInstalledPackageId + (packageHashInputs sharedConfig elab)) + + -- the stanzas explicitly disabled should not be available + . assert (Set.null (Map.keysSet (Map.filter not elabStanzasRequested) + `Set.intersection` elabStanzasAvailable)) -- either a package is built inplace, or we are not attempting to -- build any test suites or benchmarks (we never build these -- for remote packages!) - . assert (pkgBuildStyle == BuildInplaceOnly || - Set.null pkgStanzasAvailable) - - $ ret + . assert (elabBuildStyle == BuildInplaceOnly || + Set.null elabStanzasAvailable) + +sanityCheckElaboratedComponent + :: ElaboratedConfiguredPackage + -> ElaboratedComponent + -> a + -> a +sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} + ElaboratedComponent{..} = + + -- Should not be building bench or test if not inplace. + assert (elabBuildStyle == BuildInplaceOnly || + case compComponentName of + Nothing -> True + Just CLibName -> True + Just (CSubLibName _) -> True + Just (CExeName _) -> True + Just (CBenchName _) -> False + Just (CTestName _) -> False) + + +sanityCheckElaboratedPackage + :: ElaboratedConfiguredPackage + -> ElaboratedPackage + -> a + -> a +sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..} + ElaboratedPackage{..} = + -- we should only have enabled stanzas that actually can be built + -- (according to the solver) + assert (pkgStanzasEnabled `Set.isSubsetOf` elabStanzasAvailable) + -- the stanzas that the user explicitly requested should be + -- enabled (by the previous test, they are also available) + . assert (Map.keysSet (Map.filter id elabStanzasRequested) + `Set.isSubsetOf` pkgStanzasEnabled) ------------------------------------------------------------------------------ -- * Deciding what to do: making an 'ElaboratedInstallPlan' @@ -282,6 +311,7 @@ rebuildInstallPlan verbosity elaboratedShared) <- phaseElaboratePlan projectConfigTransient compilerEtc solverPlan localPackages + return (elaboratedPlan, elaboratedShared, projectConfig) -- The improved plan changes each time we install something, whereas @@ -310,8 +340,8 @@ rebuildInstallPlan verbosity phaseReadProjectConfig = do liftIO $ do info verbosity "Project settings changed, reconfiguring..." - createDirectoryIfMissingVerbose verbosity False distDirectory - createDirectoryIfMissingVerbose verbosity False distProjectCacheDirectory + createDirectoryIfMissingVerbose verbosity True distDirectory + createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory projectConfig <- readProjectConfig verbosity projectRootDir @@ -517,25 +547,26 @@ rebuildInstallPlan verbosity getPackageSourceHashes verbosity withRepoCtx solverPlan defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler - return $ - elaborateInstallPlan - platform compiler progdb - distDirLayout - cabalDirLayout - solverPlan - localPackages - sourcePackageHashes - defaultInstallDirs - projectConfigShared - projectConfigLocalPackages - (getMapMappend projectConfigSpecificPackage) + let (elaboratedPlan, elaboratedShared) = + elaborateInstallPlan + platform compiler progdb + distDirLayout + cabalDirLayout + solverPlan + localPackages + sourcePackageHashes + defaultInstallDirs + projectConfigShared + projectConfigLocalPackages + (getMapMappend projectConfigSpecificPackage) + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan) + return (elaboratedPlan, elaboratedShared) where withRepoCtx = projectConfigWithSolverRepoContext verbosity cabalPackageCacheDirectory projectConfigShared projectConfigBuildOnly - -- Update the files we maintain that reflect our current build environment. -- In particular we maintain a JSON representation of the elaborated -- install plan. @@ -574,9 +605,12 @@ rebuildInstallPlan verbosity storePkgIndex <- getPackageDBContents verbosity compiler progdb platform storePackageDb + storeExeIndex <- getExecutableDBContents storeDirectory let improvedPlan = improveInstallPlanWithPreExistingPackages storePkgIndex + storeExeIndex elaboratedPlan + liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) return improvedPlan where @@ -634,6 +668,20 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do Cabal.getPackageDBContents verbosity compiler packagedb progdb +-- | Return the list of all already installed executables +getExecutableDBContents + :: FilePath -- store directory + -> Rebuild (Set ComponentId) +getExecutableDBContents storeDirectory = do + monitorFiles [monitorFileGlob (FilePathGlob (FilePathRoot storeDirectory) (GlobFile [WildCard]))] + paths <- liftIO $ getDirectoryContents storeDirectory + return (Set.fromList (map ComponentId (filter valid paths))) + where + valid "." = False + valid ".." = False + valid "package.db" = False + valid _ = True + getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) -> Rebuild SourcePackageDb getSourcePackages verbosity withRepoCtx = do @@ -658,7 +706,7 @@ createPackageDBIfMissing verbosity compiler progdb (SpecificPackageDB dbPath) = do exists <- liftIO $ Cabal.doesPackageDBExist dbPath unless exists $ do - createDirectoryIfMissingVerbose verbosity False (takeDirectory dbPath) + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) Cabal.createPackageDB verbosity compiler progdb False dbPath createPackageDBIfMissing _ _ _ _ = return () @@ -1010,63 +1058,306 @@ elaborateInstallPlan platform compiler compilerprogdb elaboratedInstallPlan = flip InstallPlan.fromSolverInstallPlan solverPlan $ \mapDep planpkg -> case planpkg of - SolverInstallPlan.PreExisting pkg _ -> - InstallPlan.PreExisting pkg + SolverInstallPlan.PreExisting pkg -> + [InstallPlan.PreExisting (instSolverPkgIPI pkg)] SolverInstallPlan.Configured pkg -> - InstallPlan.Configured - (elaborateSolverPackage mapDep pkg) - - elaborateSolverPackage :: (SolverId -> ConfiguredId) - -> SolverPackage UnresolvedPkgLoc - -> ElaboratedConfiguredPackage - elaborateSolverPackage - mapDep - pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) - flags stanzas deps0) = - elaboratedPackage + -- SolverPackage + let pd = PD.packageDescription (packageDescription (solverPkgSource pkg)) + eligible + -- At this point in time, only non-Custom setup scripts + -- are supported. 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 that, delete this guard. + | fromMaybe PD.Custom (PD.buildType pd) == PD.Custom + = False + -- Only non-Custom or sufficiently recent Custom + -- scripts can be expanded. + | otherwise + = (fromMaybe PD.Custom (PD.buildType pd) /= PD.Custom + -- This is when we started distributing dependencies + -- per component (instead of glomming them altogether + -- and distributing to everything.) I didn't feel + -- like implementing the legacy behavior. + && PD.specVersion pd >= Version [1,7,1] [] + ) + || PD.specVersion pd >= Version [2,0,0] [] + in map InstallPlan.Configured $ if eligible + then elaborateSolverToComponents mapDep pkg + else [elaborateSolverToPackage mapDep pkg] + + elaborateSolverToComponents + :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> [ElaboratedConfiguredPackage] + elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) + = snd (mapAccumL buildComponent (Map.empty, Map.empty) comps_graph) where - -- Knot tying: the final elaboratedPackage includes the + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep spkg + comps_graph = + case Cabal.mkComponentsGraph + elabEnabledSpec + elabPkgDescription + elabInternalPackages of + Left _ -> error ("component cycle in " ++ display elabPkgSourceId) + Right g -> g + + buildComponent :: (Map PackageName ConfiguredId, Map String (ConfiguredId, FilePath)) + -> (Cabal.Component, [Cabal.ComponentName]) + -> ((Map PackageName ConfiguredId, Map String (ConfiguredId, FilePath)), + ElaboratedConfiguredPackage) + buildComponent (internal_map, exe_map) (comp, _cdeps) = + ((internal_map', exe_map'), elab) + where + elab = elab0 { + elabUnitId = SimpleUnitId cid, -- Backpack later! + elabInstallDirs = install_dirs, + elabRequiresRegistration = requires_reg, + elabPkgOrComp = ElabComponent $ ElaboratedComponent {..} + } + + cid :: ComponentId + cid = case elabBuildStyle of + BuildInplaceOnly -> + ComponentId $ + display elabPkgSourceId ++ "-inplace" ++ + (case Cabal.componentNameString cname of + Nothing -> "" + Just s -> "-" ++ s) + BuildAndInstall -> + hashedInstalledPackageId + (packageHashInputs + elaboratedSharedConfig + elab) -- knot tied + + cname = Cabal.componentName comp + requires_reg = case cname of + CLibName -> True + CSubLibName _ -> True + _ -> False + compComponentName = Just cname + compSolverName = CD.componentNameToComponent cname + compLibDependencies = + concatMap (elaborateLibSolverId mapDep) + (CD.select (== compSolverName) deps0) ++ + internal_lib_deps + compExeDependencies = + (map confInstId $ + concatMap (elaborateExeSolverId mapDep) + (CD.select (== compSolverName) exe_deps0)) ++ + internal_exe_deps + compExeDependencyPaths = + concatMap (elaborateExePath mapDep) + (CD.select (== compSolverName) exe_deps0) ++ + internal_exe_paths + + bi = Cabal.componentBuildInfo comp + confid = ConfiguredId elabPkgSourceId cid + + compSetupDependencies = concatMap (elaborateLibSolverId mapDep) (CD.setupDeps deps0) + internal_lib_deps + = [ confid' + | Dependency pkgname _ <- PD.targetBuildDepends bi + , Just confid' <- [Map.lookup pkgname internal_map] ] + (internal_exe_deps, internal_exe_paths) + = unzip $ + [ (confInstId confid', path) + | Dependency (PackageName toolname) _ <- PD.buildTools bi + , toolname `elem` map PD.exeName (PD.executables elabPkgDescription) + , Just (confid', path) <- [Map.lookup toolname exe_map] + ] + + internal_map' = case cname of + CLibName + -> Map.insert (packageName elabPkgSourceId) confid internal_map + CSubLibName libname + -> Map.insert (PackageName libname) confid internal_map + _ -> internal_map + exe_map' = case cname of + CExeName exename + -> Map.insert exename (confid, inplace_bin_dir) exe_map + _ -> exe_map + + -- NB: For inplace NOT InstallPaths.bindir installDirs; for an + -- inplace build those values are utter nonsense. So we + -- have to guess where the directory is going to be. + -- Fortunately this is "stable" part of Cabal API. + -- But the way we get the build directory is A HORRIBLE + -- HACK. + inplace_bin_dir + | shouldBuildInplaceOnly spkg + = distBuildDirectory + (elabDistDirParams elaboratedSharedConfig elab) + "build" case Cabal.componentNameString cname of + Just n -> n + Nothing -> "" + | otherwise + = InstallDirs.bindir install_dirs + + install_dirs + | shouldBuildInplaceOnly spkg + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + elabPkgSourceId + (SimpleUnitId cid) + (compilerInfo compiler) + InstallDirs.NoCopyDest + platform + defaultInstallDirs) { + + InstallDirs.libsubdir = "", -- absoluteInstallDirs sets these as + InstallDirs.datasubdir = "" -- 'undefined' but we have to use + } -- them as "Setup.hs configure" args + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs + cabalDirLayout + (compilerId compiler) + cid + + elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ConfiguredId] + elaborateLibSolverId mapDep = map configuredId . filter is_lib . mapDep + where is_lib (InstallPlan.PreExisting _) = True + is_lib (InstallPlan.Configured elab) = + case elabPkgOrComp elab of + ElabPackage _ -> True + ElabComponent comp -> compSolverName comp == CD.ComponentLib + + elaborateExeSolverId :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [ConfiguredId] + elaborateExeSolverId mapDep = map configuredId . filter is_exe . mapDep + where is_exe (InstallPlan.PreExisting _) = False + is_exe (InstallPlan.Configured elab) = + case elabPkgOrComp elab of + ElabPackage _ -> True + ElabComponent comp -> + case compSolverName comp of + CD.ComponentExe _ -> True + _ -> False + + elaborateExePath :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverId -> [FilePath] + elaborateExePath mapDep = concatMap get_exe_path . mapDep + where + -- Pre-existing executables are assumed to be in PATH + -- already. In fact, this should be impossible. + -- Modest duplication with 'inplace_bin_dir' + get_exe_path (InstallPlan.PreExisting _) = [] + get_exe_path (InstallPlan.Configured elab) = + [if elabBuildStyle elab == BuildInplaceOnly + then distBuildDirectory + (elabDistDirParams elaboratedSharedConfig elab) + "build" + case elabPkgOrComp elab of + ElabPackage _ -> "" + ElabComponent comp -> + case fmap Cabal.componentNameString + (compComponentName comp) of + Just (Just n) -> n + _ -> "" + else InstallDirs.bindir (elabInstallDirs elab)] + + elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToPackage + mapDep + pkg@(SolverPackage (SourcePackage pkgid _gdesc _srcloc _descOverride) + _flags _stanzas deps0 exe_deps0) = + -- Knot tying: the final elab includes the -- pkgInstalledId, which is calculated by hashing many -- of the other fields of the elaboratedPackage. - -- - elaboratedPackage = ElaboratedConfiguredPackage {..} - - deps = fmap (map elaborateSolverId) deps0 + elab + where + elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon mapDep pkg + elab = elab0 { + elabUnitId = SimpleUnitId pkgInstalledId, + elabInstallDirs = install_dirs, + elabRequiresRegistration = requires_reg, + elabPkgOrComp = ElabPackage $ ElaboratedPackage {..} + } - elaborateSolverId = mapDep + deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 + requires_reg = PD.hasPublicLib elabPkgDescription pkgInstalledId | shouldBuildInplaceOnly pkg - = mkUnitId (display pkgid ++ "-inplace") + = ComponentId (display pkgid ++ "-inplace") | otherwise - = assert (isJust pkgSourceHash) $ + = assert (isJust elabPkgSourceHash) $ hashedInstalledPackageId (packageHashInputs elaboratedSharedConfig - elaboratedPackage) -- recursive use of elaboratedPackage + elab) -- recursive use of elab | otherwise = error $ "elaborateInstallPlan: non-inplace package " ++ " is missing a source hash: " ++ display pkgid - -- All the other fields of the ElaboratedConfiguredPackage - -- - pkgSourceId = pkgid - pkgDescription = let Right (desc, _) = + pkgLibDependencies = deps + pkgExeDependencies = fmap (concatMap (elaborateExeSolverId mapDep)) exe_deps0 + pkgExeDependencyPaths = fmap (concatMap (elaborateExePath mapDep)) exe_deps0 + + -- Filled in later + pkgStanzasEnabled = Set.empty + + install_dirs + | shouldBuildInplaceOnly pkg + -- use the ordinary default install dirs + = (InstallDirs.absoluteInstallDirs + pkgid + (SimpleUnitId pkgInstalledId) + (compilerInfo compiler) + InstallDirs.NoCopyDest + platform + defaultInstallDirs) { + + InstallDirs.libsubdir = "", -- absoluteInstallDirs sets these as + InstallDirs.datasubdir = "" -- 'undefined' but we have to use + } -- them as "Setup.hs configure" args + + | otherwise + -- use special simplified install dirs + = storePackageInstallDirs + cabalDirLayout + (compilerId compiler) + pkgInstalledId + + elaborateSolverToCommon :: (SolverId -> [ElaboratedPlanPackage]) + -> SolverPackage UnresolvedPkgLoc + -> ElaboratedConfiguredPackage + elaborateSolverToCommon mapDep + pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride) + flags stanzas deps0 _exe_deps0) = + elaboratedPackage + where + elaboratedPackage = ElaboratedConfiguredPackage {..} + + -- These get filled in later + elabUnitId = error "elaborateSolverToCommon: elabUnitId" + elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp" + elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs" + elabRequiresRegistration = error "elaborateSolverToCommon: elabRequiresRegistration" + + elabPkgSourceId = pkgid + elabPkgDescription = let Right (desc, _) = PD.finalizePD - flags enabled (const True) + flags elabEnabledSpec (const True) platform (compilerInfo compiler) [] gdesc in desc - pkgFlagAssignment = flags - pkgFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag) + elabInternalPackages = Cabal.getInternalPackages gdesc + elabFlagAssignment = flags + elabFlagDefaults = [ (Cabal.flagName flag, Cabal.flagDefault flag) | flag <- PD.genPackageFlags gdesc ] - pkgDependencies = deps - enabled = enableStanzas stanzas - pkgStanzasAvailable = Set.fromList stanzas - pkgStanzasRequested = + + elabEnabledSpec = enableStanzas stanzas + elabStanzasAvailable = Set.fromList stanzas + elabStanzasRequested = -- NB: even if a package stanza is requested, if the package -- doesn't actually have any of that stanza we omit it from -- the request, to ensure that we don't decide that this @@ -1074,9 +1365,9 @@ elaborateInstallPlan platform compiler compilerprogdb -- because the ElaboratedConfiguredPackage is where we test -- whether or not there have been changes.) Map.fromList $ [ (TestStanzas, v) | v <- maybeToList tests - , _ <- PD.testSuites pkgDescription ] + , _ <- PD.testSuites elabPkgDescription ] ++ [ (BenchStanzas, v) | v <- maybeToList benchmarks - , _ <- PD.benchmarks pkgDescription ] + , _ <- PD.benchmarks elabPkgDescription ] where tests, benchmarks :: Maybe Bool tests = perPkgOptionMaybe pkgid packageConfigTests @@ -1090,108 +1381,87 @@ elaborateInstallPlan platform compiler compilerprogdb -- but this function doesn't know what is installed (since -- we haven't improved the plan yet), so we do it in another pass. -- Check the comments of those functions for more details. - pkgStanzasEnabled = Set.empty - pkgBuildTargets = [] - pkgReplTarget = Nothing - pkgBuildHaddocks = False - - pkgSourceLocation = srcloc - pkgSourceHash = Map.lookup pkgid sourcePackageHashes - pkgLocalToProject = isLocalToProject pkg - pkgBuildStyle = if shouldBuildInplaceOnly pkg + elabBuildTargets = [] + elabReplTarget = Nothing + elabBuildHaddocks = False + + elabPkgSourceLocation = srcloc + elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes + elabLocalToProject = isLocalToProject pkg + elabBuildStyle = if shouldBuildInplaceOnly pkg then BuildInplaceOnly else BuildAndInstall - pkgBuildPackageDBStack = buildAndRegisterDbs - pkgRegisterPackageDBStack = buildAndRegisterDbs - pkgRequiresRegistration = PD.hasPublicLib pkgDescription + elabBuildPackageDBStack = buildAndRegisterDbs + elabRegisterPackageDBStack = buildAndRegisterDbs - pkgSetupScriptStyle = packageSetupScriptStyle pkgDescription - pkgSetupScriptCliVersion = packageSetupScriptSpecVersion - pkgSetupScriptStyle pkgDescription deps - pkgSetupPackageDBStack = buildAndRegisterDbs + elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription + -- Computing the deps here is a little awful + deps = fmap (concatMap (elaborateLibSolverId mapDep)) deps0 + elabSetupScriptCliVersion = packageSetupScriptSpecVersion + elabSetupScriptStyle elabPkgDescription deps + elabSetupPackageDBStack = buildAndRegisterDbs buildAndRegisterDbs | shouldBuildInplaceOnly pkg = inplacePackageDbs | otherwise = storePackageDbs - pkgDescriptionOverride = descOverride + elabPkgDescriptionOverride = descOverride - pkgVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively - pkgSharedLib = pkgid `Set.member` pkgsUseSharedLibrary - pkgDynExe = perPkgOptionFlag pkgid False packageConfigDynExe - pkgGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still + elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively + elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary + elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe + elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still - pkgProfExe = perPkgOptionFlag pkgid False packageConfigProf - pkgProfLib = pkgid `Set.member` pkgsUseProfilingLibrary + elabProfExe = perPkgOptionFlag pkgid False packageConfigProf + elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary - (pkgProfExeDetail, - pkgProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault + (elabProfExeDetail, + elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault packageConfigProfDetail packageConfigProfLibDetail - pkgCoverage = perPkgOptionFlag pkgid False packageConfigCoverage + elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage - pkgOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization - pkgSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs - pkgStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs - pkgStripExes = perPkgOptionFlag pkgid False packageConfigStripExes - pkgDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo + elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization + elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs + elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs + elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes + elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo -- Combine the configured compiler prog settings with the user-supplied -- config. For the compiler progs any user-supplied config was taken -- into account earlier when configuring the compiler so its ok that -- our configured settings for the compiler override the user-supplied -- config here. - pkgProgramPaths = Map.fromList + elabProgramPaths = Map.fromList [ (programId prog, programPath prog) | prog <- configuredPrograms compilerprogdb ] <> perPkgOptionMapLast pkgid packageConfigProgramPaths - pkgProgramArgs = Map.fromList + elabProgramArgs = Map.fromList [ (programId prog, args) | prog <- configuredPrograms compilerprogdb , let args = programOverrideArgs prog , not (null args) ] <> perPkgOptionMapMappend pkgid packageConfigProgramArgs - pkgProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra - pkgConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs - pkgExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs - pkgExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs - pkgExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs - pkgProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix - pkgProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix - - pkgInstallDirs - | shouldBuildInplaceOnly pkg - -- use the ordinary default install dirs - = (InstallDirs.absoluteInstallDirs - pkgid - pkgInstalledId - (compilerInfo compiler) - InstallDirs.NoCopyDest - platform - defaultInstallDirs) { - - InstallDirs.libsubdir = "", -- absoluteInstallDirs sets these as - InstallDirs.datasubdir = "" -- 'undefined' but we have to use - } -- them as "Setup.hs configure" args - - | otherwise - -- use special simplified install dirs - = storePackageInstallDirs - cabalDirLayout - (compilerId compiler) - pkgInstalledId - - pkgHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle - pkgHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml - pkgHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation - pkgHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables - pkgHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites - pkgHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks - pkgHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal - pkgHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss - pkgHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour - pkgHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss - pkgHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra + elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs + elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs + 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 + elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables + elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites + elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks + elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal + elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss + elabHaddockHscolour = perPkgOptionFlag pkgid False packageConfigHaddockHscolour + elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss + elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a @@ -1306,7 +1576,6 @@ elaborateInstallPlan platform compiler compilerprogdb -- + vanilla libs & exes, exe needs lib, recursive -- + ghci or shared lib needed by TH, recursive, ghc version dependent - --------------------------- -- Build targets -- @@ -1348,7 +1617,7 @@ elaboratePackageTargets ElaboratedConfiguredPackage{..} targets = pkgDefaultComponents = [ ComponentTarget cname WholeComponent - | c <- Cabal.pkgComponents pkgDescription + | c <- Cabal.pkgComponents elabPkgDescription , PD.buildable (Cabal.componentBuildInfo c) , let cname = Cabal.componentName c , enabledOptionalStanza cname @@ -1357,7 +1626,7 @@ elaboratePackageTargets ElaboratedConfiguredPackage{..} targets = enabledOptionalStanza cname = case componentOptionalStanza cname of Nothing -> True - Just stanza -> Map.lookup stanza pkgStanzasRequested + Just stanza -> Map.lookup stanza elabStanzasRequested == Just True -- Not all Cabal Setup.hs versions support sub-component targets, so switch @@ -1389,22 +1658,21 @@ elaboratePackageTargets ElaboratedConfiguredPackage{..} targets = (t:_) -> [t] [] -> ts - pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool -pkgHasEphemeralBuildTargets pkg = - isJust (pkgReplTarget pkg) - || (not . null) [ () | ComponentTarget _ subtarget <- pkgBuildTargets pkg +pkgHasEphemeralBuildTargets elab = + isJust (elabReplTarget elab) + || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab , subtarget /= WholeComponent ] -- | The components that we'll build all of, meaning that after they're built -- we can skip building them again (unlike with building just some modules or -- other files within a component). -- -pkgBuildTargetWholeComponents :: ElaboratedConfiguredPackage +elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage -> Set ComponentName -pkgBuildTargetWholeComponents pkg = +elabBuildTargetWholeComponents elab = Set.fromList - [ cname | ComponentTarget cname WholeComponent <- pkgBuildTargets pkg ] + [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ] ------------------------------------------------------------------------------ @@ -1416,17 +1684,39 @@ pkgBuildTargetWholeComponents pkg = -- targets. Also, update the package config to specify which optional stanzas -- to enable, and which targets within each package to build. -- -pruneInstallPlanToTargets :: Map InstalledPackageId [PackageTarget] +pruneInstallPlanToTargets :: Map UnitId [PackageTarget] -> ElaboratedInstallPlan -> ElaboratedInstallPlan pruneInstallPlanToTargets perPkgTargetsMap = - either (\_ -> assert False undefined) id - . InstallPlan.new (IndependentGoals False) + InstallPlan.new (IndependentGoals False) . Graph.fromList -- We have to do this in two passes . pruneInstallPlanPass2 . pruneInstallPlanPass1 perPkgTargetsMap . InstallPlan.toList +-- | This is a temporary data type, where we temporarily +-- override the graph dependencies of an 'ElaboratedPackage', +-- so we can take a closure over them. We'll throw out the +-- overriden dependencies when we're done so it's strictly temporary. +-- +-- For 'ElaboratedComponent', this the cached unit IDs always +-- coincide with the real thing. +data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId] + +instance Package PrunedPackage where + packageId (PrunedPackage elab _) = packageId elab + +instance HasUnitId PrunedPackage where + installedUnitId = nodeKey + +instance IsNode PrunedPackage where + type Key PrunedPackage = UnitId + nodeKey (PrunedPackage elab _) = nodeKey elab + nodeNeighbors (PrunedPackage _ deps) = deps + +fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage +fromPrunedPackage (PrunedPackage elab _) = elab + -- | The first pass does three things: -- -- * Set the build targets based on the user targets (but not rev deps yet). @@ -1436,36 +1726,51 @@ pruneInstallPlanToTargets 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 :: Map InstalledPackageId [PackageTarget] +pruneInstallPlanPass1 :: Map UnitId [PackageTarget] -> [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] pruneInstallPlanPass1 perPkgTargetsMap pkgs = - map fst $ - dependencyClosure - (installedPackageId . fst) -- the pkg id - snd -- the pruned deps - [ (pkg', pruneOptionalDependencies pkg') - | pkg <- pkgs - , let pkg' = mapConfiguredPackage - (pruneOptionalStanzas . setBuildTargets) pkg - ] - (Map.keys perPkgTargetsMap) + map (mapConfiguredPackage fromPrunedPackage) + (fromMaybe [] $ Graph.closure g roots) where + pkgs' = map (mapConfiguredPackage prune) pkgs + g = Graph.fromList pkgs' + + prune elab = + let elab' = (pruneOptionalStanzas . setElabBuildTargets) elab + in PrunedPackage elab' (pruneOptionalDependencies elab') + + roots = mapMaybe find_root pkgs' + find_root (InstallPlan.Configured (PrunedPackage elab _)) = + if not (null (elabBuildTargets elab) + && isNothing (elabReplTarget elab) + && not (elabBuildHaddocks elab)) + then Just (installedUnitId elab) + else Nothing + find_root _ = Nothing + -- Elaborate and set the targets we'll build for this package. This is just -- based on the targets from the user, not targets implied by reverse -- dependencies. Those comes in the second pass once we know the rev deps. -- - setBuildTargets pkg = - pkg { - pkgBuildTargets = buildTargets, - pkgReplTarget = replTarget, - pkgBuildHaddocks = buildHaddocks + setElabBuildTargets elab = + elab { + elabBuildTargets = mapMaybe targetForElab buildTargets, + elabReplTarget = replTarget >>= targetForElab, + elabBuildHaddocks = buildHaddocks } where (buildTargets, replTarget, buildHaddocks) - = elaboratePackageTargets pkg targets + = elaboratePackageTargets elab targets targets = fromMaybe [] - $ Map.lookup (installedPackageId pkg) perPkgTargetsMap + $ Map.lookup (installedUnitId elab) perPkgTargetsMap + targetForElab tgt@(ComponentTarget cname _) = + case elabPkgOrComp elab of + ElabPackage _ -> Just tgt -- always valid + ElabComponent comp + -- Only if the component name matches + | compComponentName comp == Just cname -> Just tgt + | otherwise -> Nothing -- Decide whether or not to enable testsuites and benchmarks -- @@ -1483,12 +1788,17 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs = -- disabled. Technically this introduces a little bit of stateful -- behaviour to make this "sticky", but it should be benign. -- - pruneOptionalStanzas pkg = pkg { pkgStanzasEnabled = stanzas } + pruneOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + pruneOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } = + elab { + elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas }) + } where stanzas :: Set OptionalStanza - stanzas = optionalStanzasRequiredByTargets pkg - <> optionalStanzasRequestedByDefault pkg - <> optionalStanzasWithDepsAvailable availablePkgs pkg + stanzas = optionalStanzasRequiredByTargets elab + <> optionalStanzasRequestedByDefault elab + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + pruneOptionalStanzas elab = elab -- Calculate package dependencies but cut out those needed only by -- optional stanzas that we've determined we will not enable. @@ -1496,24 +1806,24 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs = -- the optional stanzas and we'll make further tweaks to the optional -- stanzas in the next pass. -- - pruneOptionalDependencies :: ElaboratedPlanPackage -> [InstalledPackageId] - pruneOptionalDependencies (InstallPlan.Configured pkg) = - (CD.flatDeps . CD.filterDeps keepNeeded) (depends pkg) + pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId] + pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ } + = InstallPlan.depends elab -- no pruning + pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } + = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg) where keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas keepNeeded _ _ = True stanzas = pkgStanzasEnabled pkg - pruneOptionalDependencies pkg = - CD.flatDeps (depends pkg) optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage -> Set OptionalStanza optionalStanzasRequiredByTargets pkg = Set.fromList [ stanza - | ComponentTarget cname _ <- pkgBuildTargets pkg - ++ maybeToList (pkgReplTarget pkg) + | ComponentTarget cname _ <- elabBuildTargets pkg + ++ maybeToList (elabReplTarget pkg) , stanza <- maybeToList (componentOptionalStanza cname) ] @@ -1522,11 +1832,11 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs = optionalStanzasRequestedByDefault = Map.keysSet . Map.filter (id :: Bool -> Bool) - . pkgStanzasRequested + . elabStanzasRequested availablePkgs = Set.fromList - [ installedPackageId pkg + [ installedUnitId pkg | InstallPlan.PreExisting pkg <- pkgs ] -- | Given a set of already installed packages @availablePkgs@, @@ -1535,17 +1845,19 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs = -- to implement "sticky" testsuites, where once we have installed -- all of the deps needed for the test suite, we go ahead and -- enable it always. -optionalStanzasWithDepsAvailable :: Set InstalledPackageId +optionalStanzasWithDepsAvailable :: Set UnitId -> ElaboratedConfiguredPackage + -> ElaboratedPackage -> Set OptionalStanza -optionalStanzasWithDepsAvailable availablePkgs pkg = +optionalStanzasWithDepsAvailable availablePkgs elab pkg = Set.fromList [ stanza - | stanza <- Set.toList (pkgStanzasAvailable pkg) - , let deps :: [InstalledPackageId] - deps = map installedPackageId - $ CD.select (optionalStanzaDeps stanza) - (pkgDependencies pkg) + | stanza <- Set.toList (elabStanzasAvailable elab) + , let deps :: [UnitId] + deps = CD.select (optionalStanzaDeps stanza) + -- TODO: probably need to select other + -- dep types too eventually + (pkgOrderDependencies pkg) , all (`Set.member` availablePkgs) deps ] where @@ -1586,43 +1898,63 @@ pruneInstallPlanPass2 :: [ElaboratedPlanPackage] pruneInstallPlanPass2 pkgs = map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs where - setStanzasDepsAndTargets pkg = - pkg { - pkgStanzasEnabled = stanzas, - pkgDependencies = CD.filterDeps keepNeeded (pkgDependencies pkg), - pkgBuildTargets = pkgBuildTargets pkg ++ targetsRequiredForRevDeps + setStanzasDepsAndTargets elab = + elab { + elabBuildTargets = elabBuildTargets elab + ++ libTargetsRequiredForRevDeps + ++ exeTargetsRequiredForRevDeps, + elabPkgOrComp = + case elabPkgOrComp elab of + ElabPackage pkg -> + let stanzas = pkgStanzasEnabled pkg + <> optionalStanzasWithDepsAvailable availablePkgs elab pkg + keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas + keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas + keepNeeded _ _ = True + in ElabPackage $ pkg { + pkgStanzasEnabled = stanzas, + pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), + pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), + pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) + } + r@(ElabComponent _) -> r } where - stanzas :: Set OptionalStanza - stanzas = pkgStanzasEnabled pkg - <> optionalStanzasWithDepsAvailable availablePkgs pkg - - keepNeeded (CD.ComponentTest _) _ = TestStanzas `Set.member` stanzas - keepNeeded (CD.ComponentBench _) _ = BenchStanzas `Set.member` stanzas - keepNeeded _ _ = True - - targetsRequiredForRevDeps = + libTargetsRequiredForRevDeps = [ ComponentTarget Cabal.defaultLibName WholeComponent - -- if anything needs this pkg, build the library component - | installedPackageId pkg `Set.member` hasReverseLibDeps + | installedUnitId elab `Set.member` hasReverseLibDeps + ] + exeTargetsRequiredForRevDeps = + -- TODO: allow requesting executable with different name + -- than package name + [ ComponentTarget (Cabal.CExeName (unPackageName (packageName (elabPkgSourceId elab)))) + WholeComponent + | installedUnitId elab `Set.member` hasReverseExeDeps ] - --TODO: also need to track build-tool rev-deps for exes - - availablePkgs :: Set InstalledPackageId - availablePkgs = Set.fromList (map installedPackageId pkgs) - hasReverseLibDeps :: Set InstalledPackageId - hasReverseLibDeps = - Set.fromList [ depid | pkg <- pkgs - , depid <- CD.flatDeps (depends pkg) ] + availablePkgs :: Set UnitId + availablePkgs = Set.fromList (map installedUnitId pkgs) -mapConfiguredPackage :: (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage) - -> ElaboratedPlanPackage - -> ElaboratedPlanPackage + hasReverseLibDeps :: Set UnitId + hasReverseLibDeps = + Set.fromList [ SimpleUnitId (confInstId depid) + | InstallPlan.Configured pkg <- pkgs + , depid <- elabLibDependencies pkg ] + + hasReverseExeDeps :: Set UnitId + hasReverseExeDeps = + Set.fromList [ SimpleUnitId depid + | InstallPlan.Configured pkg <- pkgs + , depid <- elabExeDependencies pkg ] + +mapConfiguredPackage :: (srcpkg -> srcpkg') + -> InstallPlan.GenericPlanPackage ipkg srcpkg + -> InstallPlan.GenericPlanPackage ipkg srcpkg' mapConfiguredPackage f (InstallPlan.Configured pkg) = InstallPlan.Configured (f pkg) -mapConfiguredPackage _ pkg = pkg +mapConfiguredPackage _ (InstallPlan.PreExisting pkg) = + InstallPlan.PreExisting pkg componentOptionalStanza :: Cabal.ComponentName -> Maybe OptionalStanza componentOptionalStanza (Cabal.CTestName _) = Just TestStanzas @@ -1630,39 +1962,6 @@ componentOptionalStanza (Cabal.CBenchName _) = Just BenchStanzas componentOptionalStanza _ = Nothing -dependencyClosure :: (pkg -> InstalledPackageId) - -> (pkg -> [InstalledPackageId]) - -> [pkg] - -> [InstalledPackageId] - -> [pkg] -dependencyClosure pkgid deps allpkgs = - map vertexToPkg - . concatMap Tree.flatten - . OldGraph.dfs graph - . map pkgidToVertex - where - (graph, vertexToPkg, pkgidToVertex) = dependencyGraph pkgid deps allpkgs - --- TODO: Convert this to use Distribution.Compat.Graph, via a newtype --- which explicitly carries the accessors. -dependencyGraph :: (pkg -> InstalledPackageId) - -> (pkg -> [InstalledPackageId]) - -> [pkg] - -> (OldGraph.Graph, - OldGraph.Vertex -> pkg, - InstalledPackageId -> OldGraph.Vertex) -dependencyGraph pkgid deps pkgs = - (graph, vertexToPkg', pkgidToVertex') - where - (graph, vertexToPkg, pkgidToVertex) = - OldGraph.graphFromEdges [ ( pkg, pkgid pkg, deps pkg ) - | pkg <- pkgs ] - vertexToPkg' = (\(pkg,_,_) -> pkg) - . vertexToPkg - pkgidToVertex' = fromMaybe (error "dependencyGraph: lookup failure") - . pkgidToVertex - - --------------------------- -- Setup.hs script policy -- @@ -1858,24 +2157,27 @@ setupHsScriptOptions :: ElaboratedReadyPackage -> Bool -> Lock -> SetupScriptOptions -setupHsScriptOptions (ReadyPackage ElaboratedConfiguredPackage{..}) +-- TODO: Fix this so custom is a separate component. Custom can ALWAYS +-- be a separate component!!! +setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) ElaboratedSharedConfig{..} srcdir builddir isParallelBuild cacheLock = SetupScriptOptions { - useCabalVersion = thisVersion pkgSetupScriptCliVersion, - useCabalSpecVersion = Just pkgSetupScriptCliVersion, + useCabalVersion = thisVersion elabSetupScriptCliVersion, + useCabalSpecVersion = Just elabSetupScriptCliVersion, useCompiler = Just pkgConfigCompiler, usePlatform = Just pkgConfigPlatform, - usePackageDB = pkgSetupPackageDBStack, + usePackageDB = elabSetupPackageDBStack, usePackageIndex = Nothing, useDependencies = [ (uid, srcid) - | ConfiguredId srcid uid <- CD.setupDeps pkgDependencies ], + | ConfiguredId srcid uid <- elabSetupDependencies elab ], useDependenciesExclusive = True, - useVersionMacros = pkgSetupScriptStyle == SetupCustomExplicitDeps, + useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, useProgramConfig = pkgConfigCompilerProgs, useDistPref = builddir, useLoggingHandle = Nothing, -- this gets set later useWorkingDir = Just srcdir, + useExtraPathEnv = elabExeDependencyPaths elab, useWin32CleanHack = False, --TODO: [required eventually] forceExternalSetupMethod = isParallelBuild, setupCacheLock = Just cacheLock @@ -1928,74 +2230,91 @@ setupHsConfigureFlags :: ElaboratedReadyPackage -> Verbosity -> FilePath -> Cabal.ConfigFlags -setupHsConfigureFlags (ReadyPackage - pkg@ElaboratedConfiguredPackage{..}) +setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) sharedConfig@ElaboratedSharedConfig{..} verbosity builddir = - sanityCheckElaboratedConfiguredPackage sharedConfig pkg + sanityCheckElaboratedConfiguredPackage sharedConfig elab (Cabal.ConfigFlags {..}) where + configArgs = mempty -- unused, passed via args configDistPref = toFlag builddir configCabalFilePath = mempty configVerbosity = toFlag verbosity - configIPID = toFlag (display (installedUnitId pkg)) + configIPID = case elabPkgOrComp of + ElabPackage pkg -> toFlag (display (pkgInstalledId pkg)) + ElabComponent _ -> mempty + configCID = case elabPkgOrComp of + ElabPackage _ -> mempty + ElabComponent _ -> toFlag (unitIdComponentId elabUnitId) - configProgramPaths = Map.toList pkgProgramPaths - configProgramArgs = Map.toList pkgProgramArgs - configProgramPathExtra = toNubList pkgProgramPathExtra + configProgramPaths = Map.toList elabProgramPaths + configProgramArgs = Map.toList elabProgramArgs + configProgramPathExtra = toNubList elabProgramPathExtra configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler) configHcPath = mempty -- we use configProgramPaths instead configHcPkg = mempty -- we use configProgramPaths instead - configVanillaLib = toFlag pkgVanillaLib - configSharedLib = toFlag pkgSharedLib - configDynExe = toFlag pkgDynExe - configGHCiLib = toFlag pkgGHCiLib + configVanillaLib = toFlag elabVanillaLib + configSharedLib = toFlag elabSharedLib + configDynExe = toFlag elabDynExe + configGHCiLib = toFlag elabGHCiLib configProfExe = mempty - configProfLib = toFlag pkgProfLib - configProf = toFlag pkgProfExe + configProfLib = toFlag elabProfLib + configProf = toFlag elabProfExe -- configProfDetail is for exe+lib, but overridden by configProfLibDetail -- so we specify both so we can specify independently - configProfDetail = toFlag pkgProfExeDetail - configProfLibDetail = toFlag pkgProfLibDetail + configProfDetail = toFlag elabProfExeDetail + configProfLibDetail = toFlag elabProfLibDetail - configCoverage = toFlag pkgCoverage + configCoverage = toFlag elabCoverage configLibCoverage = mempty - configOptimization = toFlag pkgOptimization - configSplitObjs = toFlag pkgSplitObjs - configStripExes = toFlag pkgStripExes - configStripLibs = toFlag pkgStripLibs - configDebugInfo = toFlag pkgDebugInfo + configOptimization = toFlag elabOptimization + configSplitObjs = toFlag elabSplitObjs + configStripExes = toFlag elabStripExes + configStripLibs = toFlag elabStripLibs + configDebugInfo = toFlag elabDebugInfo configAllowOlder = mempty -- we use configExactConfiguration True configAllowNewer = mempty -- we use configExactConfiguration True - configConfigurationsFlags = pkgFlagAssignment - configConfigureArgs = pkgConfigureScriptArgs - configExtraLibDirs = pkgExtraLibDirs - configExtraFrameworkDirs = pkgExtraFrameworkDirs - configExtraIncludeDirs = pkgExtraIncludeDirs - configProgPrefix = maybe mempty toFlag pkgProgPrefix - configProgSuffix = maybe mempty toFlag pkgProgSuffix + configConfigurationsFlags = elabFlagAssignment + configConfigureArgs = elabConfigureScriptArgs + configExtraLibDirs = elabExtraLibDirs + configExtraFrameworkDirs = elabExtraFrameworkDirs + configExtraIncludeDirs = elabExtraIncludeDirs + configProgPrefix = maybe mempty toFlag elabProgPrefix + configProgSuffix = maybe mempty toFlag elabProgSuffix configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate) - pkgInstallDirs + elabInstallDirs -- we only use configDependencies, unless we're talking to an old Cabal -- in which case we use configConstraints - configDependencies = [ (packageName srcid, uid) - | ConfiguredId srcid uid <- CD.nonSetupDeps pkgDependencies ] - configConstraints = [ thisPackageVersion srcid - | ConfiguredId srcid _uid <- CD.nonSetupDeps pkgDependencies ] + -- NB: This does NOT use InstallPlan.depends, which includes executable + -- dependencies which should NOT be fed in here (also you don't have + -- enough info anyway) + configDependencies = [ (packageName srcid, cid) + | ConfiguredId srcid cid <- elabLibDependencies elab ] + configConstraints = + case elabPkgOrComp of + ElabPackage _ -> + [ thisPackageVersion srcid + | ConfiguredId srcid _uid <- elabLibDependencies elab ] + ElabComponent _ -> [] + -- explicitly clear, then our package db stack -- TODO: [required eventually] have to do this differently for older Cabal versions - configPackageDBs = Nothing : map Just pkgBuildPackageDBStack + configPackageDBs = Nothing : map Just elabBuildPackageDBStack - configTests = toFlag (TestStanzas `Set.member` pkgStanzasEnabled) - configBenchmarks = toFlag (BenchStanzas `Set.member` pkgStanzasEnabled) + configTests = case elabPkgOrComp of + ElabPackage pkg -> toFlag (TestStanzas `Set.member` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty + configBenchmarks = case elabPkgOrComp of + ElabPackage pkg -> toFlag (BenchStanzas `Set.member` pkgStanzasEnabled pkg) + ElabComponent _ -> mempty configExactConfiguration = toFlag True configFlagError = mempty --TODO: [research required] appears not to be implemented @@ -2005,12 +2324,21 @@ setupHsConfigureFlags (ReadyPackage configPrograms_ = mempty -- never use, shouldn't exist +setupHsConfigureArgs :: ElaboratedConfiguredPackage + -> [String] +setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = [] +setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) = + [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)] + where + cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup") + (compComponentName comp) + setupHsBuildFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig -> Verbosity -> FilePath -> Cabal.BuildFlags -setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = +setupHsBuildFlags _ _ verbosity builddir = Cabal.BuildFlags { buildProgramPaths = mempty, --unused, set at configure time buildProgramArgs = mempty, --unused, set at configure time @@ -2023,26 +2351,10 @@ setupHsBuildFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String] -setupHsBuildArgs pkg = - map (showComponentTarget pkg) (pkgBuildTargets pkg) - - -showComponentTarget :: ElaboratedConfiguredPackage -> ComponentTarget -> String -showComponentTarget pkg = - showBuildTarget . toBuildTarget - where - showBuildTarget t = - Cabal.showBuildTarget (qlBuildTarget t) (packageId pkg) t - - qlBuildTarget Cabal.BuildTargetComponent{} = Cabal.QL2 - qlBuildTarget _ = Cabal.QL3 - - toBuildTarget :: ComponentTarget -> Cabal.BuildTarget - toBuildTarget (ComponentTarget cname subtarget) = - case subtarget of - WholeComponent -> Cabal.BuildTargetComponent cname - ModuleTarget mname -> Cabal.BuildTargetModule cname mname - FileTarget fname -> Cabal.BuildTargetFile cname fname +setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) + = map (showComponentTarget (packageId elab)) (elabBuildTargets elab) +setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ }) + = [] setupHsReplFlags :: ElaboratedConfiguredPackage @@ -2050,7 +2362,7 @@ setupHsReplFlags :: ElaboratedConfiguredPackage -> Verbosity -> FilePath -> Cabal.ReplFlags -setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = +setupHsReplFlags _ _ verbosity builddir = Cabal.ReplFlags { replProgramPaths = mempty, --unused, set at configure time replProgramArgs = mempty, --unused, set at configure time @@ -2061,8 +2373,8 @@ setupHsReplFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] -setupHsReplArgs pkg = - maybe [] (\t -> [showComponentTarget pkg t]) (pkgReplTarget pkg) +setupHsReplArgs elab = + maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) --TODO: should be able to give multiple modules in one component @@ -2089,13 +2401,13 @@ setupHsRegisterFlags :: ElaboratedConfiguredPackage -> FilePath -> FilePath -> Cabal.RegisterFlags -setupHsRegisterFlags ElaboratedConfiguredPackage {pkgBuildStyle} _ +setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ verbosity builddir pkgConfFile = Cabal.RegisterFlags { regPackageDB = mempty, -- misfeature regGenScript = mempty, -- never use regGenPkgConf = toFlag (Just pkgConfFile), - regInPlace = case pkgBuildStyle of + regInPlace = case elabBuildStyle of BuildInplaceOnly -> toFlag True _ -> toFlag False, regPrintId = mempty, -- never use @@ -2111,22 +2423,24 @@ setupHsHaddockFlags :: ElaboratedConfiguredPackage -> Verbosity -> FilePath -> Cabal.HaddockFlags -setupHsHaddockFlags ElaboratedConfiguredPackage{..} _ verbosity builddir = +-- TODO: reconsider whether or not Executables/TestSuites/... +-- needed for component +setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.HaddockFlags { haddockProgramPaths = mempty, --unused, set at configure time haddockProgramArgs = mempty, --unused, set at configure time - haddockHoogle = toFlag pkgHaddockHoogle, - haddockHtml = toFlag pkgHaddockHtml, - haddockHtmlLocation = maybe mempty toFlag pkgHaddockHtmlLocation, + haddockHoogle = toFlag elabHaddockHoogle, + haddockHtml = toFlag elabHaddockHtml, + haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation, haddockForHackage = mempty, --TODO: new flag - haddockExecutables = toFlag pkgHaddockExecutables, - haddockTestSuites = toFlag pkgHaddockTestSuites, - haddockBenchmarks = toFlag pkgHaddockBenchmarks, - haddockInternal = toFlag pkgHaddockInternal, - haddockCss = maybe mempty toFlag pkgHaddockCss, - haddockHscolour = toFlag pkgHaddockHscolour, - haddockHscolourCss = maybe mempty toFlag pkgHaddockHscolourCss, - haddockContents = maybe mempty toFlag pkgHaddockContents, + haddockExecutables = toFlag elabHaddockExecutables, + haddockTestSuites = toFlag elabHaddockTestSuites, + haddockBenchmarks = toFlag elabHaddockBenchmarks, + haddockInternal = toFlag elabHaddockInternal, + haddockCss = maybe mempty toFlag elabHaddockCss, + haddockHscolour = toFlag elabHaddockHscolour, + haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, + haddockContents = maybe mempty toFlag elabHaddockContents, haddockDistPref = toFlag builddir, haddockKeepTempFiles = mempty, --TODO: from build settings haddockVerbosity = toFlag verbosity @@ -2190,18 +2504,25 @@ packageHashInputs :: ElaboratedSharedConfig -> PackageHashInputs packageHashInputs pkgshared - pkg@ElaboratedConfiguredPackage{ - pkgSourceId, - pkgSourceHash = Just srchash, - pkgDependencies - } = + elab@(ElaboratedConfiguredPackage { + elabPkgSourceHash = Just srchash + }) = PackageHashInputs { - pkgHashPkgId = pkgSourceId, + pkgHashPkgId = packageId elab, + pkgHashComponent = Nothing, pkgHashSourceHash = srchash, - pkgHashDirectDeps = Set.fromList - [ installedPackageId dep - | dep <- CD.select relevantDeps pkgDependencies ], - pkgHashOtherConfig = packageHashConfigInputs pkgshared pkg + 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 (compLibDependencies comp) + ++ compExeDependencies comp), + pkgHashOtherConfig = packageHashConfigInputs pkgshared elab } where -- Obviously the main deps are relevant @@ -2229,27 +2550,27 @@ packageHashConfigInputs PackageHashConfigInputs { pkgHashCompilerId = compilerId pkgConfigCompiler, pkgHashPlatform = pkgConfigPlatform, - pkgHashFlagAssignment = pkgFlagAssignment, - pkgHashConfigureScriptArgs = pkgConfigureScriptArgs, - pkgHashVanillaLib = pkgVanillaLib, - pkgHashSharedLib = pkgSharedLib, - pkgHashDynExe = pkgDynExe, - pkgHashGHCiLib = pkgGHCiLib, - pkgHashProfLib = pkgProfLib, - pkgHashProfExe = pkgProfExe, - pkgHashProfLibDetail = pkgProfLibDetail, - pkgHashProfExeDetail = pkgProfExeDetail, - pkgHashCoverage = pkgCoverage, - pkgHashOptimization = pkgOptimization, - pkgHashSplitObjs = pkgSplitObjs, - pkgHashStripLibs = pkgStripLibs, - pkgHashStripExes = pkgStripExes, - pkgHashDebugInfo = pkgDebugInfo, - pkgHashExtraLibDirs = pkgExtraLibDirs, - pkgHashExtraFrameworkDirs = pkgExtraFrameworkDirs, - pkgHashExtraIncludeDirs = pkgExtraIncludeDirs, - pkgHashProgPrefix = pkgProgPrefix, - pkgHashProgSuffix = pkgProgSuffix + pkgHashFlagAssignment = elabFlagAssignment, + pkgHashConfigureScriptArgs = elabConfigureScriptArgs, + pkgHashVanillaLib = elabVanillaLib, + pkgHashSharedLib = elabSharedLib, + pkgHashDynExe = elabDynExe, + pkgHashGHCiLib = elabGHCiLib, + pkgHashProfLib = elabProfLib, + pkgHashProfExe = elabProfExe, + pkgHashProfLibDetail = elabProfLibDetail, + pkgHashProfExeDetail = elabProfExeDetail, + pkgHashCoverage = elabCoverage, + pkgHashOptimization = elabOptimization, + pkgHashSplitObjs = elabSplitObjs, + pkgHashStripLibs = elabStripLibs, + pkgHashStripExes = elabStripExes, + pkgHashDebugInfo = elabDebugInfo, + pkgHashExtraLibDirs = elabExtraLibDirs, + pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, + pkgHashExtraIncludeDirs = elabExtraIncludeDirs, + pkgHashProgPrefix = elabProgPrefix, + pkgHashProgSuffix = elabProgSuffix } @@ -2258,9 +2579,10 @@ packageHashConfigInputs -- installed packages whenever they exist. -- improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex + -> Set ComponentId -> ElaboratedInstallPlan -> ElaboratedInstallPlan -improveInstallPlanWithPreExistingPackages installedPkgIndex installPlan = +improveInstallPlanWithPreExistingPackages installedPkgIndex installedExes installPlan = replaceWithPreExisting installPlan [ ipkg | InstallPlan.Configured pkg @@ -2275,9 +2597,17 @@ improveInstallPlanWithPreExistingPackages installedPkgIndex installPlan = -- since overwriting is never safe. canPackageBeImproved pkg = - PackageIndex.lookupUnitId - installedPkgIndex (installedPackageId pkg) + case PackageIndex.lookupUnitId + installedPkgIndex (installedUnitId pkg) of + Just x -> Just x + Nothing | SimpleUnitId cid <- installedUnitId pkg + , cid `Set.member` installedExes + -- Same hack as replacewithPrePreExisting + -> Just (Installed.emptyInstalledPackageInfo { + Installed.installedUnitId = installedUnitId pkg + }) + | otherwise -> Nothing replaceWithPreExisting = foldl' (\plan ipkg -> InstallPlan.preexisting - (installedPackageId ipkg) ipkg plan) + (installedUnitId ipkg) ipkg plan) diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index afcefde7323..6ba3f3a9e77 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} -- | Types used while planning how to build everything in a project. -- @@ -10,6 +12,17 @@ module Distribution.Client.ProjectPlanning.Types ( -- * Elaborated install plan types ElaboratedInstallPlan, ElaboratedConfiguredPackage(..), + + elabDistDirParams, + elabExeDependencyPaths, + elabLibDependencies, + elabExeDependencies, + elabSetupDependencies, + + ElaboratedPackageOrComponent(..), + ElaboratedComponent(..), + ElaboratedPackage(..), + pkgOrderDependencies, ElaboratedPlanPackage, ElaboratedSharedConfig(..), ElaboratedReadyPackage, @@ -19,6 +32,7 @@ module Distribution.Client.ProjectPlanning.Types ( -- * Build targets PackageTarget(..), ComponentTarget(..), + showComponentTarget, SubComponentTarget(..), -- * Setup script @@ -32,13 +46,16 @@ import Distribution.Client.InstallPlan ( GenericInstallPlan, GenericPlanPackage ) import Distribution.Client.SolverInstallPlan ( SolverInstallPlan ) +import Distribution.Client.DistDirLayout +import Distribution.Types.ComponentEnabledSpec import Distribution.Package hiding (InstalledPackageId, installedPackageId) import Distribution.System import qualified Distribution.PackageDescription as Cabal import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Compiler +import qualified Distribution.Simple.BuildTarget as Cabal import Distribution.Simple.Program.Db import Distribution.ModuleName (ModuleName) import Distribution.Simple.LocalBuildInfo (ComponentName(..)) @@ -46,15 +63,18 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.InstallDirs (PathTemplate) import Distribution.Version +import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Simple.Utils (ordNub) import Data.Map (Map) import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS import Distribution.Compat.Binary import GHC.Generics (Generic) +import qualified Data.Monoid as Mon @@ -93,28 +113,50 @@ instance Binary ElaboratedSharedConfig data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage { + -- | The 'UnitId' which uniquely identifies this item in a build plan + elabUnitId :: UnitId, - pkgInstalledId :: InstalledPackageId, - pkgSourceId :: PackageId, + -- | The 'PackageId' of the originating package + elabPkgSourceId :: PackageId, - -- | TODO: [code cleanup] we don't need this, just a few bits from it: - -- build type, spec version - pkgDescription :: Cabal.PackageDescription, + -- | Mapping from 'PackageName's to 'ComponentName', for every + -- package that is overloaded with an internal component name + elabInternalPackages :: Map PackageName ComponentName, - -- | A total flag assignment for the package - pkgFlagAssignment :: Cabal.FlagAssignment, + -- | A total flag assignment for the package. + -- TODO: Actually this can be per-component if we drop + -- all flags that don't affect a component. + elabFlagAssignment :: Cabal.FlagAssignment, -- | The original default flag assignment, used only for reporting. - pkgFlagDefaults :: Cabal.FlagAssignment, + elabFlagDefaults :: Cabal.FlagAssignment, - -- | The exact dependencies (on other plan packages) - -- - pkgDependencies :: ComponentDeps [ConfiguredId], + elabPkgDescription :: Cabal.PackageDescription, + + -- | Where the package comes from, e.g. tarball, local dir etc. This + -- is not the same as where it may be unpacked to for the build. + elabPkgSourceLocation :: PackageLocation (Maybe FilePath), + + -- | The hash of the source, e.g. the tarball. We don't have this for + -- local source dir packages. + elabPkgSourceHash :: Maybe PackageSourceHash, + + -- | Is this package one of the ones specified by location in the + -- project file? (As opposed to a dependency, or a named package pulled + -- in) + elabLocalToProject :: Bool, + + -- | Are we going to build and install this package to the store, or are + -- we going to build it and register it locally. + elabBuildStyle :: BuildStyle, + + -- | Another way of phrasing 'pkgStanzasAvailable'. + elabEnabledSpec :: ComponentEnabledSpec, -- | Which optional stanzas (ie testsuites, benchmarks) can be built. -- This means the solver produced a plan that has them available. -- This doesn't necessary mean we build them by default. - pkgStanzasAvailable :: Set OptionalStanza, + elabStanzasAvailable :: Set OptionalStanza, -- | Which optional stanzas the user explicitly asked to enable or -- to disable. This tells us which ones we build by default, and @@ -134,108 +176,211 @@ data ElaboratedConfiguredPackage -- 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.) - pkgStanzasRequested :: Map OptionalStanza Bool, - - -- | Which optional stanzas (ie testsuites, benchmarks) will actually - -- be enabled during the package configure step. - pkgStanzasEnabled :: Set OptionalStanza, - - -- | Where the package comes from, e.g. tarball, local dir etc. This - -- is not the same as where it may be unpacked to for the build. - pkgSourceLocation :: PackageLocation (Maybe FilePath), - - -- | The hash of the source, e.g. the tarball. We don't have this for - -- local source dir packages. - pkgSourceHash :: Maybe PackageSourceHash, - - --pkgSourceDir ? -- currently passed in later because they can use temp locations - --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc - - -- | Is this package one of the ones specified by location in the - -- project file? (As opposed to a dependency, or a named package pulled - -- in) - pkgLocalToProject :: Bool, - - -- | Are we going to build and install this package to the store, or are - -- we going to build it and register it locally. - pkgBuildStyle :: BuildStyle, - - pkgSetupPackageDBStack :: PackageDBStack, - pkgBuildPackageDBStack :: PackageDBStack, - pkgRegisterPackageDBStack :: PackageDBStack, - - -- | The package contains a library and so must be registered - pkgRequiresRegistration :: Bool, - pkgDescriptionOverride :: Maybe CabalFileText, - - pkgVanillaLib :: Bool, - pkgSharedLib :: Bool, - pkgDynExe :: Bool, - pkgGHCiLib :: Bool, - pkgProfLib :: Bool, - pkgProfExe :: Bool, - pkgProfLibDetail :: ProfDetailLevel, - pkgProfExeDetail :: ProfDetailLevel, - pkgCoverage :: Bool, - pkgOptimization :: OptimisationLevel, - pkgSplitObjs :: Bool, - pkgStripLibs :: Bool, - pkgStripExes :: Bool, - pkgDebugInfo :: DebugInfoLevel, - - pkgProgramPaths :: Map String FilePath, - pkgProgramArgs :: Map String [String], - pkgProgramPathExtra :: [FilePath], - pkgConfigureScriptArgs :: [String], - pkgExtraLibDirs :: [FilePath], - pkgExtraFrameworkDirs :: [FilePath], - pkgExtraIncludeDirs :: [FilePath], - pkgProgPrefix :: Maybe PathTemplate, - pkgProgSuffix :: Maybe PathTemplate, - - pkgInstallDirs :: InstallDirs.InstallDirs FilePath, - - pkgHaddockHoogle :: Bool, - pkgHaddockHtml :: Bool, - pkgHaddockHtmlLocation :: Maybe String, - pkgHaddockExecutables :: Bool, - pkgHaddockTestSuites :: Bool, - pkgHaddockBenchmarks :: Bool, - pkgHaddockInternal :: Bool, - pkgHaddockCss :: Maybe FilePath, - pkgHaddockHscolour :: Bool, - pkgHaddockHscolourCss :: Maybe FilePath, - pkgHaddockContents :: Maybe PathTemplate, + elabStanzasRequested :: Map OptionalStanza Bool, + + elabSetupPackageDBStack :: PackageDBStack, + elabBuildPackageDBStack :: PackageDBStack, + elabRegisterPackageDBStack :: PackageDBStack, + + -- | The package/component contains/is a library and so must be registered + elabRequiresRegistration :: Bool, + + elabPkgDescriptionOverride :: Maybe CabalFileText, + + -- TODO: make per-component variants of these flags + elabVanillaLib :: Bool, + elabSharedLib :: Bool, + elabDynExe :: Bool, + elabGHCiLib :: Bool, + elabProfLib :: Bool, + elabProfExe :: Bool, + elabProfLibDetail :: ProfDetailLevel, + elabProfExeDetail :: ProfDetailLevel, + elabCoverage :: Bool, + elabOptimization :: OptimisationLevel, + elabSplitObjs :: Bool, + elabStripLibs :: Bool, + elabStripExes :: Bool, + elabDebugInfo :: DebugInfoLevel, + + elabProgramPaths :: Map String FilePath, + elabProgramArgs :: Map String [String], + elabProgramPathExtra :: [FilePath], + elabConfigureScriptArgs :: [String], + elabExtraLibDirs :: [FilePath], + elabExtraFrameworkDirs :: [FilePath], + elabExtraIncludeDirs :: [FilePath], + elabProgPrefix :: Maybe PathTemplate, + elabProgSuffix :: Maybe PathTemplate, + + elabInstallDirs :: InstallDirs.InstallDirs FilePath, + + elabHaddockHoogle :: Bool, + elabHaddockHtml :: Bool, + elabHaddockHtmlLocation :: Maybe String, + elabHaddockExecutables :: Bool, + elabHaddockTestSuites :: Bool, + elabHaddockBenchmarks :: Bool, + elabHaddockInternal :: Bool, + elabHaddockCss :: Maybe FilePath, + elabHaddockHscolour :: Bool, + elabHaddockHscolourCss :: Maybe FilePath, + elabHaddockContents :: Maybe PathTemplate, -- Setup.hs related things: -- | One of four modes for how we build and interact with the Setup.hs -- script, based on whether it's a build-type Custom, with or without -- explicit deps and the cabal spec version the .cabal file needs. - pkgSetupScriptStyle :: SetupScriptStyle, + elabSetupScriptStyle :: SetupScriptStyle, -- | The version of the Cabal command line interface that we are using -- for this package. This is typically the version of the Cabal lib -- that the Setup.hs is built against. - pkgSetupScriptCliVersion :: Version, + elabSetupScriptCliVersion :: Version, -- Build time related: - pkgBuildTargets :: [ComponentTarget], - pkgReplTarget :: Maybe ComponentTarget, - pkgBuildHaddocks :: Bool - } - deriving (Eq, Show, Generic) + elabBuildTargets :: [ComponentTarget], + elabReplTarget :: Maybe ComponentTarget, + elabBuildHaddocks :: Bool, -instance Binary ElaboratedConfiguredPackage + --pkgSourceDir ? -- currently passed in later because they can use temp locations + --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc + + -- | Component/package specific information + elabPkgOrComp :: ElaboratedPackageOrComponent + } + deriving (Eq, Show, Generic) instance Package ElaboratedConfiguredPackage where - packageId = pkgSourceId + packageId = elabPkgSourceId + +instance HasConfiguredId ElaboratedConfiguredPackage where + configuredId elab = ConfiguredId (packageId elab) (unitIdComponentId (elabUnitId elab)) instance HasUnitId ElaboratedConfiguredPackage where - installedUnitId = pkgInstalledId + installedUnitId = elabUnitId + +instance IsNode ElaboratedConfiguredPackage where + type Key ElaboratedConfiguredPackage = UnitId + nodeKey = elabUnitId + nodeNeighbors elab = case elabPkgOrComp elab of + -- Important not to have duplicates: otherwise InstallPlan gets + -- confused. NB: this DOES include setup deps. + ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg)) + ElabComponent comp -> compOrderDependencies comp + +instance Binary ElaboratedConfiguredPackage + +data ElaboratedPackageOrComponent + = ElabPackage ElaboratedPackage + | ElabComponent ElaboratedComponent + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackageOrComponent + +elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams +elabDistDirParams shared elab = DistDirParams { + distParamUnitId = installedUnitId elab, + distParamPackageId = elabPkgSourceId elab, + distParamComponentName = case elabPkgOrComp elab of + ElabComponent comp -> compComponentName comp + ElabPackage _ -> Nothing, + distParamCompilerId = compilerId (pkgConfigCompiler shared), + distParamPlatform = pkgConfigPlatform shared + } + +-- | The library dependencies (i.e., the libraries we depend on, NOT +-- the dependencies of the library), NOT including setup dependencies. +elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabLibDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) +elabLibDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compLibDependencies comp + +elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId] +elabExeDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = map confInstId (CD.nonSetupDeps (pkgExeDependencies pkg)) +elabExeDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compExeDependencies comp + +elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath] +elabExeDependencyPaths ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = CD.nonSetupDeps (pkgExeDependencyPaths pkg) +elabExeDependencyPaths ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compExeDependencyPaths comp + +elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabSetupDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg } + = CD.setupDeps (pkgLibDependencies pkg) +elabSetupDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } + = compSetupDependencies comp + + +-- | Some extra metadata associated with an +-- 'ElaboratedConfiguredPackage' which indicates that the "package" +-- in question is actually a single component to be built. Arguably +-- it would be clearer if there were an ADT which branched into +-- package work items and component work items, but I've structured +-- it this way to minimize change to the existing code (which I +-- don't feel qualified to rewrite.) +data ElaboratedComponent + = ElaboratedComponent { + -- | The name of the component to be built according to the solver + compSolverName :: CD.Component, + -- | The name of the component to be built. Nothing if + -- it's a setup dep. + compComponentName :: Maybe ComponentName, + -- | The library dependencies of this component. + compLibDependencies :: [ConfiguredId], + -- | The executable dependencies of this component. + compExeDependencies :: [ComponentId], + -- | The paths all our executable dependencies will be installed + -- to once they are installed. + compExeDependencyPaths :: [FilePath], + -- | The setup dependencies. TODO: Remove this when setups + -- are components of their own. + compSetupDependencies :: [ConfiguredId] + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedComponent -instance PackageFixedDeps ElaboratedConfiguredPackage where - depends = fmap (map installedPackageId) . pkgDependencies +compOrderDependencies :: ElaboratedComponent -> [UnitId] +compOrderDependencies comp = + -- TODO: Change this with Backpack! + map (SimpleUnitId . confInstId) (compLibDependencies comp) + ++ map SimpleUnitId (compExeDependencies comp) + ++ map (SimpleUnitId . confInstId) (compSetupDependencies comp) + +data ElaboratedPackage + = ElaboratedPackage { + pkgInstalledId :: InstalledPackageId, + + -- | The exact dependencies (on other plan packages) + -- + pkgLibDependencies :: ComponentDeps [ConfiguredId], + + -- | Dependencies on executable packages. + -- + pkgExeDependencies :: ComponentDeps [ConfiguredId], + + -- | Paths where executable dependencies live. + -- + pkgExeDependencyPaths :: ComponentDeps [FilePath], + + -- | Which optional stanzas (ie testsuites, benchmarks) will actually + -- be enabled during the package configure step. + pkgStanzasEnabled :: Set OptionalStanza + } + deriving (Eq, Show, Generic) + +instance Binary ElaboratedPackage + +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies pkg = + fmap (map (SimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` + fmap (map (SimpleUnitId . confInstId)) (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be -- built. @@ -297,6 +442,20 @@ instance Binary PackageTarget instance Binary ComponentTarget instance Binary SubComponentTarget +-- | Unambiguously render a 'ComponentTarget', e.g., to pass +-- to a Cabal Setup script. +showComponentTarget :: PackageId -> ComponentTarget -> String +showComponentTarget pkgid = + Cabal.showBuildTarget pkgid . toBuildTarget + where + toBuildTarget :: ComponentTarget -> Cabal.BuildTarget + toBuildTarget (ComponentTarget cname subtarget) = + case subtarget of + WholeComponent -> Cabal.BuildTargetComponent cname + ModuleTarget mname -> Cabal.BuildTargetModule cname mname + FileTarget fname -> Cabal.BuildTargetFile cname fname + + --------------------------- -- Setup.hs script policy diff --git a/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal-install/Distribution/Client/SetupWrapper.hs index 22ae2dd67cf..985c21034ee 100644 --- a/cabal-install/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/Distribution/Client/SetupWrapper.hs @@ -27,9 +27,8 @@ import Distribution.Version ( Version(..), VersionRange, anyVersion , intersectVersionRanges, orLaterVersion , withinRange ) -import Distribution.InstalledPackageInfo (installedUnitId) import Distribution.Package - ( UnitId(..), PackageIdentifier(..), PackageId, + ( UnitId(..), ComponentId, PackageIdentifier(..), PackageId, PackageName(..), Package(..), packageName , packageVersion, Dependency(..) ) import Distribution.PackageDescription @@ -53,7 +52,7 @@ import Distribution.Simple.Program , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram , ghcjsProgram ) import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar ) + ( programSearchPathAsPATHVar, ProgramSearchPathEntry(ProgramSearchPathDir) ) import Distribution.Simple.Program.Run ( getEffectiveEnvironment ) import qualified Distribution.Simple.Program.Strip as Strip @@ -66,6 +65,8 @@ import Distribution.Simple.Program.GHC ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Client.Types import Distribution.Client.Config ( defaultCabalDir ) import Distribution.Client.IndexUtils @@ -79,7 +80,7 @@ import Distribution.Simple.Utils , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils - ( inDir, tryCanonicalizePath + ( inDir, tryCanonicalizePath, withExtraPathEnv , existsAndIsMoreRecentThan, moreRecentFile, withEnv #if mingw32_HOST_OS , canonicalizePathNoThrow @@ -159,10 +160,12 @@ data SetupScriptOptions = SetupScriptOptions { useDistPref :: FilePath, useLoggingHandle :: Maybe Handle, useWorkingDir :: Maybe FilePath, + -- | Extra things to add to PATH when invoking the setup script. + useExtraPathEnv :: [FilePath], forceExternalSetupMethod :: Bool, -- | List of dependencies to use when building Setup.hs. - useDependencies :: [(UnitId, PackageId)], + useDependencies :: [(ComponentId, PackageId)], -- | Is the list of setup dependencies exclusive? -- @@ -227,6 +230,7 @@ defaultSetupScriptOptions = SetupScriptOptions { useDistPref = defaultDistPref, useLoggingHandle = Nothing, useWorkingDir = Nothing, + useExtraPathEnv = [], useWin32CleanHack = False, forceExternalSetupMethod = False, setupCacheLock = Nothing @@ -303,9 +307,10 @@ internalSetupMethod verbosity options _ bt mkargs = do let args = mkargs cabalVersion info verbosity $ "Using internal setup method with build-type " ++ show bt ++ " and args:\n " ++ show args - inDir (useWorkingDir options) $ + inDir (useWorkingDir options) $ do withEnv "HASKELL_DIST_DIR" (useDistPref options) $ - buildTypeAction bt args + withExtraPathEnv (useExtraPathEnv options) $ + buildTypeAction bt args buildTypeAction :: BuildType -> ([String] -> IO ()) buildTypeAction Simple = Simple.defaultMainArgs @@ -334,7 +339,8 @@ selfExecSetupMethod verbosity options _pkg bt mkargs = do ++ show logHandle searchpath <- programSearchPathAsPATHVar - (getProgramSearchPath (useProgramConfig options)) + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramConfig options)) env <- getEffectiveEnvironment [("PATH", Just searchpath) ,("HASKELL_DIST_DIR", Just (useDistPref options))] @@ -383,7 +389,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do Nothing -> getInstalledPackages verbosity comp (usePackageDB options') conf - cabalLibVersionToUse :: IO (Version, (Maybe UnitId) + cabalLibVersionToUse :: IO (Version, (Maybe ComponentId) ,SetupScriptOptions) cabalLibVersionToUse = case useCabalSpecVersion options of @@ -418,7 +424,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile - installedVersion :: IO (Version, Maybe UnitId + installedVersion :: IO (Version, Maybe InstalledPackageId ,SetupScriptOptions) installedVersion = do (comp, conf, options') <- configureCompiler options @@ -465,7 +471,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration - -> IO (Version, Maybe UnitId + -> IO (Version, Maybe InstalledPackageId ,SetupScriptOptions) installedCabalVersion options' compiler conf = do index <- maybeGetInstalledPackages options' compiler conf @@ -478,7 +484,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do ++ " but no suitable version is installed." pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs in return (packageVersion ipkginfo - ,Just . installedUnitId $ ipkginfo, options'') + ,Just . IPI.installedComponentId $ ipkginfo, options'') bestVersion :: (a -> Version) -> [a] -> a bestVersion f = firstMaximumBy (comparing (preference . f)) @@ -551,7 +557,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do -- | Look up the setup executable in the cache; update the cache if the setup -- executable is not found. getCachedSetupExecutable :: SetupScriptOptions - -> Version -> Maybe UnitId + -> Version -> Maybe InstalledPackageId -> IO FilePath getCachedSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId = do @@ -586,7 +592,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do -- Currently this is GHC/GHCJS only. It should really be generalised. -- compileSetupExecutable :: SetupScriptOptions - -> Version -> Maybe UnitId -> Bool + -> Version -> Maybe ComponentId -> Bool -> IO FilePath compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId forceCompile = do @@ -623,7 +629,7 @@ externalSetupMethod verbosity options pkg bt mkargs = do if any hasCabal (useDependencies options') then [] else cabalDep - addRenaming (ipid, _) = (ipid, defaultRenaming) + addRenaming (ipid, _) = (SimpleUnitId ipid, defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if @@ -688,7 +694,8 @@ externalSetupMethod verbosity options pkg bt mkargs = do where doInvoke path' = do searchpath <- programSearchPathAsPATHVar - (getProgramSearchPath (useProgramConfig options')) + (map ProgramSearchPathDir (useExtraPathEnv options') ++ + getProgramSearchPath (useProgramConfig options')) env <- getEffectiveEnvironment [("PATH", Just searchpath) ,("HASKELL_DIST_DIR", Just (useDistPref options))] diff --git a/cabal-install/Distribution/Client/SolverInstallPlan.hs b/cabal-install/Distribution/Client/SolverInstallPlan.hs index bfa064095b1..0a6cd44a6a2 100644 --- a/cabal-install/Distribution/Client/SolverInstallPlan.hs +++ b/cabal-install/Distribution/Client/SolverInstallPlan.hs @@ -125,7 +125,7 @@ showInstallPlan :: SolverInstallPlan -> String showInstallPlan = showPlanIndex . planIndex showPlanPackage :: SolverPlanPackage -> String -showPlanPackage (PreExisting ipkg _) = "PreExisting " ++ display (packageId ipkg) +showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg) ++ " (" ++ display (installedUnitId ipkg) ++ ")" showPlanPackage (Configured spkg) = "Configured " ++ display (packageId spkg) @@ -207,7 +207,7 @@ showPlanProblem (PackageStateInvalid pkg pkg') = ++ " which is in the " ++ showPlanState pkg' ++ " state" where - showPlanState (PreExisting _ _) = "pre-existing" + showPlanState (PreExisting _) = "pre-existing" showPlanState (Configured _) = "configured" -- | For an invalid plan, produce a detailed list of problems as human readable @@ -279,7 +279,7 @@ nonSetupClosure index pkgids0 = closure Graph.empty pkgids0 Just _ -> closure completed pkgids Nothing -> closure completed' pkgids' where completed' = Graph.insert pkg completed - pkgids' = CD.nonSetupDeps (resolverPackageDeps pkg) ++ pkgids + pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids -- | Compute the root sets of a plan -- @@ -310,7 +310,7 @@ libraryRoots index = -- | The setup dependencies of each package in the plan setupRoots :: SolverPlanIndex -> [[SolverId]] setupRoots = filter (not . null) - . map (CD.setupDeps . resolverPackageDeps) + . map (CD.setupDeps . resolverPackageLibDeps) . Graph.toList -- | Given a package index where we assume we want to use all the packages @@ -342,7 +342,7 @@ dependencyInconsistencies' index = | -- For each package @pkg@ pkg <- Graph.toList index -- Find out which @sid@ @pkg@ depends on - , sid <- CD.nonSetupDeps (resolverPackageDeps pkg) + , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@) , Just dep <- [Graph.lookup sid index] ] @@ -358,8 +358,8 @@ dependencyInconsistencies' index = reallyIsInconsistent [p1, p2] = let pid1 = nodeKey p1 pid2 = nodeKey p2 - in pid1 `notElem` CD.nonSetupDeps (resolverPackageDeps p2) - && pid2 `notElem` CD.nonSetupDeps (resolverPackageDeps p1) + in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2) + && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1) reallyIsInconsistent _ = True diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index ac3b9bd9cda..3db012e969e 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -21,7 +22,8 @@ module Distribution.Client.Types where import Distribution.Package ( PackageName, PackageId, Package(..) - , UnitId(..), HasUnitId(..) ) + , UnitId(..), ComponentId(..), HasUnitId(..) + , PackageInstalled(..), unitIdComponentId ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.PackageDescription @@ -31,11 +33,13 @@ import Distribution.Version import Distribution.Solver.Types.PackageIndex ( PackageIndex ) +import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.SourcePackage +import Distribution.Compat.Graph (IsNode(..)) import Data.Map (Map) import Network.URI (URI(..), URIAuth(..), nullURI) @@ -74,10 +78,7 @@ instance Binary SourcePackageDb -- slightly and we may distinguish these two types and have an explicit -- conversion when we register units with the compiler. -- -type InstalledPackageId = UnitId - -installedPackageId :: HasUnitId pkg => pkg -> InstalledPackageId -installedPackageId = installedUnitId +type InstalledPackageId = ComponentId -- | A 'ConfiguredPackage' is a not-yet-installed package along with the @@ -85,8 +86,11 @@ installedPackageId = installedUnitId -- the sense that it provides all the configuration information and so the -- final configure process will be independent of the environment. -- +-- 'ConfiguredPackage' is assumed to not support Backpack. Only the +-- @new-build@ codepath supports Backpack. +-- data ConfiguredPackage loc = ConfiguredPackage { - confPkgId :: UnitId, -- the generated 'UnitId' for this package + confPkgId :: InstalledPackageId, confPkgSource :: SourcePackage loc, -- package info, including repo confPkgFlags :: FlagAssignment, -- complete flag assignment for the package confPkgStanzas :: [OptionalStanza], -- list of enabled optional stanzas for the package @@ -98,8 +102,28 @@ data ConfiguredPackage loc = ConfiguredPackage { } deriving (Eq, Show, Generic) +-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'. +-- This type class is mostly used to conveniently finesse between +-- 'ElaboratedPackage' and 'ElaboratedComponent'. +-- +instance HasConfiguredId (ConfiguredPackage loc) where + configuredId pkg = ConfiguredId (packageId pkg) (confPkgId pkg) + +-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed +-- to never have a nontrivial 'UnitId' +instance PackageFixedDeps (ConfiguredPackage loc) where + depends = fmap (map (SimpleUnitId . confInstId)) . confPkgDeps + +instance IsNode (ConfiguredPackage loc) where + type Key (ConfiguredPackage loc) = UnitId + nodeKey = SimpleUnitId . confPkgId + -- TODO: if we update ConfiguredPackage to support order-only + -- dependencies, need to include those here + nodeNeighbors = CD.flatDeps . depends + instance (Binary loc) => Binary (ConfiguredPackage loc) + -- | A ConfiguredId is a package ID for a configured package. -- -- Once we configure a source package we know it's UnitId. It is still @@ -108,14 +132,11 @@ instance (Binary loc) => Binary (ConfiguredPackage loc) -- -- An already installed package of course is also "configured" (all it's -- configuration parameters and dependencies have been specified). --- --- TODO: I wonder if it would make sense to promote this datatype to Cabal --- and use it consistently instead of UnitIds? data ConfiguredId = ConfiguredId { confSrcId :: PackageId - , confInstId :: UnitId + , confInstId :: ComponentId } - deriving (Eq, Generic) + deriving (Eq, Ord, Generic) instance Binary ConfiguredId @@ -125,22 +146,35 @@ instance Show ConfiguredId where instance Package ConfiguredId where packageId = confSrcId -instance HasUnitId ConfiguredId where - installedUnitId = confInstId - instance Package (ConfiguredPackage loc) where packageId cpkg = packageId (confPkgSource cpkg) -instance PackageFixedDeps (ConfiguredPackage loc) where - depends cpkg = fmap (map installedUnitId) (confPkgDeps cpkg) - +-- Never has nontrivial UnitId instance HasUnitId (ConfiguredPackage loc) where - installedUnitId = confPkgId + installedUnitId = SimpleUnitId . confPkgId + +instance PackageInstalled (ConfiguredPackage loc) where + installedDepends = CD.flatDeps . depends + +class HasConfiguredId a where + configuredId :: a -> ConfiguredId + +-- NB: This instance is slightly dangerous, in that you'll lose +-- information about the specific UnitId you depended on. +instance HasConfiguredId InstalledPackageInfo where + configuredId ipkg = ConfiguredId (packageId ipkg) (unitIdComponentId (installedUnitId ipkg)) -- | 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, HasUnitId, Binary) + deriving (Eq, Show, Generic, Package, PackageFixedDeps, + 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) @@ -287,8 +321,12 @@ data BuildFailure = PlanningFailed instance Exception BuildFailure +-- Note that the @Maybe InstalledPackageInfo@ is a slight hack: we only +-- the public library's 'InstalledPackageInfo' is stored here, even if +-- there were 'InstalledPackageInfo' from internal libraries. This +-- 'InstalledPackageInfo' is not used anyway, so it makes no difference. data BuildResult = BuildResult DocsResult TestsResult - [InstalledPackageInfo] + (Maybe InstalledPackageInfo) deriving (Show, Generic) data DocsResult = DocsNotTried | DocsFailed | DocsOk diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs index 4fa8719556d..d4cbd92f146 100644 --- a/cabal-install/Distribution/Client/Utils.hs +++ b/cabal-install/Distribution/Client/Utils.hs @@ -4,6 +4,7 @@ module Distribution.Client.Utils ( MergeResult(..) , mergeBy, duplicates, duplicatesBy , readMaybe , inDir, withEnv, logDirChange + , withExtraPathEnv , determineNumJobs, numberOfProcessors , removeExistingFile , withTempFileName @@ -18,7 +19,7 @@ module Distribution.Client.Utils ( MergeResult(..) , relaxEncodingErrors) where -import Distribution.Compat.Environment ( lookupEnv, setEnv, unsetEnv ) +import Distribution.Compat.Environment import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) @@ -31,6 +32,7 @@ import Control.Monad ( when ) import Data.Bits ( (.|.), shiftL, shiftR ) +import System.FilePath import Data.Char ( ord, chr ) #if MIN_VERSION_base(4,6,0) @@ -38,7 +40,7 @@ import Text.Read ( readMaybe ) #endif import Data.List - ( isPrefixOf, sortBy, groupBy ) + ( isPrefixOf, sortBy, groupBy, intercalate ) import Data.Word ( Word8, Word32) import Foreign.C.Types ( CInt(..) ) @@ -47,8 +49,6 @@ import qualified Control.Exception as Exception import System.Directory ( canonicalizePath, doesFileExist, getCurrentDirectory , removeFile, setCurrentDirectory ) -import System.FilePath - ( (), isAbsolute, takeDrive, splitPath, joinPath ) import System.IO ( Handle, hClose, openTempFile #if MIN_VERSION_base(4,4,0) @@ -73,8 +73,6 @@ import System.IO.Error (ioError, mkIOError, doesNotExistErrorType) -- | Generic merging utility. For sorted input lists this is a full outer join. -- --- * The result list never contains @(Nothing, Nothing)@. --- mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] mergeBy cmp = merge where @@ -153,6 +151,23 @@ withEnv k v m = do Nothing -> unsetEnv k Just old -> setEnv k old) +-- | Executes the action, increasing the PATH environment +-- in some way +-- +-- Warning: This operation is NOT thread-safe, because the +-- environment variables are a process-global concept. +withExtraPathEnv :: [FilePath] -> IO a -> IO a +withExtraPathEnv paths m = do + oldPathSplit <- getSearchPath + let newPath = mungePath $ intercalate [searchPathSeparator] (paths ++ oldPathSplit) + oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit + -- TODO: This is a horrible hack to work around the fact that + -- setEnv can't take empty values as an argument + mungePath p | p == "" = "/dev/null" + | otherwise = p + setEnv "PATH" newPath + m `Exception.finally` setEnv "PATH" oldPath + -- | Log directory change in 'make' compatible syntax logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a logDirChange _ Nothing m = m diff --git a/cabal-install/Distribution/Solver/Modular/Assignment.hs b/cabal-install/Distribution/Solver/Modular/Assignment.hs index 9de3c03838a..56303c412b3 100644 --- a/cabal-install/Distribution/Solver/Modular/Assignment.hs +++ b/cabal-install/Distribution/Solver/Modular/Assignment.hs @@ -82,10 +82,10 @@ extend extSupported langSupported pkgPresent var = foldM extendSingle extendSingle a (Pkg pn vr) = if pkgPresent pn vr then Right a else Left (varToConflictSet var, [Pkg pn vr]) - extendSingle a (Dep qpn ci) = + extendSingle a (Dep is_exe qpn ci) = let ci' = M.findWithDefault (Constrained []) qpn a in case (\ x -> M.insert qpn x a) <$> merge ci' ci of - Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d')) + Left (c, (d, d')) -> Left (c, L.map (Dep is_exe qpn) (simplify (P qpn) d d')) Right x -> Right x -- We're trying to remove trivial elements of the conflict. If we're just diff --git a/cabal-install/Distribution/Solver/Modular/Builder.hs b/cabal-install/Distribution/Solver/Modular/Builder.hs index 591679ac34d..722194f145f 100644 --- a/cabal-install/Distribution/Solver/Modular/Builder.hs +++ b/cabal-install/Distribution/Solver/Modular/Builder.hs @@ -55,7 +55,7 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs -- This is important, because in general, if a goal is inserted twice, -- the later addition will have better dependency information. go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs - go g o (ng@(OpenGoal (Simple (Dep qpn _) c) _gr) : ngs) + go g o (ng@(OpenGoal (Simple (Dep _ qpn _) c) _gr) : ngs) | qpn == qpn' = go g o ngs -- we ignore self-dependencies at this point; TODO: more care may be needed | qpn `M.member` g = go (M.adjust ((c, qpn'):) qpn g) o ngs @@ -127,7 +127,7 @@ build = ana go error "Distribution.Solver.Modular.Builder: build.go called with Lang goal" go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Pkg _ _ ) _) _ ) }) = error "Distribution.Solver.Modular.Builder: build.go called with Pkg goal" - go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _) _) gr) }) = + go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep _ qpn@(Q _ pn) _) _) gr) }) = -- If the package does not exist in the index, we construct an emty PChoiceF node for it -- After all, we have no choices here. Alternatively, we could immediately construct -- a Fail node here, but that would complicate the construction of conflict sets. @@ -186,7 +186,9 @@ buildTree idx (IndependentGoals ind) igs = , qualifyOptions = defaultQualifyOptions idx } where - topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal + -- Should a top-level goal allowed to be an executable style + -- dependency? Well, I don't think it would make much difference + topLevelGoal qpn = OpenGoal (Simple (Dep False {- not exe -} qpn (Constrained [])) ()) UserGoal qpns | ind = makeIndependent igs | otherwise = L.map (Q (PackagePath DefaultNamespace Unqualified)) igs diff --git a/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs index bb2e1999c93..10cf411303e 100644 --- a/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs +++ b/cabal-install/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -4,6 +4,7 @@ module Distribution.Solver.Modular.ConfiguredConversion import Data.Maybe import Prelude hiding (pi) +import Data.Either (partitionEithers) import Distribution.Package (UnitId, packageId) @@ -18,6 +19,7 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage +import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage -- | Converts from the solver specific result @CP QPN@ into @@ -28,27 +30,43 @@ convCP :: SI.InstalledPackageIndex -> CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = case convPI qpi of - Left pi -> PreExisting - (fromJust $ SI.lookupUnitId iidx pi) ds' - Right pi -> Configured $ SolverPackage - srcpkg - fa - es - ds' + Left pi -> PreExisting $ + InstSolverPackage { + instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, + instSolverPkgLibDeps = fmap fst ds', + instSolverPkgExeDeps = fmap snd ds' + } + Right pi -> Configured $ + SolverPackage { + solverPkgSource = srcpkg, + solverPkgFlags = fa, + solverPkgStanzas = es, + solverPkgLibDeps = fmap fst ds', + solverPkgExeDeps = fmap snd ds' + } where Just srcpkg = CI.lookupPackageId sidx pi where - ds' :: ComponentDeps [SolverId] - ds' = fmap (map convConfId) ds + 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 (convConfId pi)) +convPI pi = Right (packageId (either id id (convConfId pi))) -convConfId :: PI QPN -> SolverId -convConfId (PI (Q _ pn) (I v loc)) = +convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} +convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = case loc of - Inst pi -> PreExistingId sourceId pi - _otherwise -> PlannedId sourceId + Inst pi -> Left (PreExistingId sourceId pi) + _otherwise + | Exe _ pn' <- q + -- NB: the dependencies of the executable are also + -- qualified. So the way to tell if this is an executable + -- dependency is to make sure the qualifier is pointing + -- 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) where sourceId = PackageIdentifier pn v diff --git a/cabal-install/Distribution/Solver/Modular/Dependency.hs b/cabal-install/Distribution/Solver/Modular/Dependency.hs index d4af4f35648..4c2242ec2d1 100644 --- a/cabal-install/Distribution/Solver/Modular/Dependency.hs +++ b/cabal-install/Distribution/Solver/Modular/Dependency.hs @@ -165,6 +165,9 @@ flattenFlaggedDeps = concatMap aux type TrueFlaggedDeps qpn = FlaggedDeps Component qpn type FalseFlaggedDeps qpn = FlaggedDeps Component qpn +-- | Is this dependency on an executable +type IsExe = Bool + -- | A dependency (constraint) associates a package name with a -- constrained instance. -- @@ -172,20 +175,22 @@ type FalseFlaggedDeps qpn = FlaggedDeps Component 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 'Dep' ought to have two type variables.) -data Dep qpn = Dep qpn (CI qpn) -- dependency on a package +data Dep qpn = Dep IsExe qpn (CI qpn) -- dependency on a package (possibly for executable | Ext Extension -- dependency on a language extension | Lang Language -- dependency on a language version | Pkg PN VR -- dependency on a pkg-config package deriving (Eq, Show) showDep :: Dep QPN -> String -showDep (Dep qpn (Fixed i v) ) = +showDep (Dep is_exe qpn (Fixed i v) ) = (if P qpn /= v then showVar v ++ " => " else "") ++ - showQPN qpn ++ "==" ++ showI i -showDep (Dep qpn (Constrained [(vr, v)])) = - showVar v ++ " => " ++ showQPN qpn ++ showVR vr -showDep (Dep qpn ci ) = - showQPN qpn ++ showCI ci + showQPN qpn ++ + (if is_exe then " (exe) " else "") ++ "==" ++ showI i +showDep (Dep is_exe qpn (Constrained [(vr, v)])) = + showVar v ++ " => " ++ showQPN qpn ++ + (if is_exe then " (exe) " else "") ++ showVR vr +showDep (Dep is_exe qpn ci ) = + showQPN qpn ++ (if is_exe then " (exe) " else "") ++ showCI ci showDep (Ext ext) = "requires " ++ display ext showDep (Lang lang) = "requires " ++ display lang showDep (Pkg pn vr) = "requires pkg-config package " @@ -237,10 +242,11 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep dep ci) comp - | qBase dep = Dep (Q (PackagePath ns (Base pn)) dep) (fmap (Q pp) ci) - | qSetup comp = Dep (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci) - | otherwise = Dep (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci) + goD (Dep is_exe dep ci) comp + | is_exe = Dep is_exe (Q (PackagePath ns (Exe pn dep)) dep) (fmap (Q pp) ci) + | qBase dep = Dep is_exe (Q (PackagePath ns (Base pn)) dep) (fmap (Q pp) ci) + | qSetup comp = Dep is_exe (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci) + | otherwise = Dep is_exe (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) 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 @@ -252,6 +258,7 @@ qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go inheritedQ :: Qualifier inheritedQ = case q of Setup _ -> q + Exe _ _ -> q Unqualified -> q Base _ -> Unqualified @@ -282,7 +289,7 @@ unqualifyDeps = go go1 (Simple dep comp) = Simple (goD dep) comp goD :: Dep QPN -> Dep PN - goD (Dep qpn ci) = Dep (unq qpn) (fmap unq ci) + goD (Dep is_exe qpn ci) = Dep is_exe (unq qpn) (fmap unq ci) goD (Ext ext) = Ext ext goD (Lang lang) = Lang lang goD (Pkg pn vr) = Pkg pn vr @@ -354,7 +361,7 @@ instance ResetVar CI where resetVar v (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetVar v y)) vrs) instance ResetVar Dep where - resetVar v (Dep qpn ci) = Dep qpn (resetVar v ci) + resetVar v (Dep is_exe qpn ci) = Dep is_exe qpn (resetVar v ci) resetVar _ (Ext ext) = Ext ext resetVar _ (Lang lang) = Lang lang resetVar _ (Pkg pn vr) = Pkg pn vr @@ -401,7 +408,7 @@ data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReason -- | Closes a goal, i.e., removes all the extraneous information that we -- need only during the build phase. close :: OpenGoal comp -> Goal QPN -close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr +close (OpenGoal (Simple (Dep _ qpn _) _) gr) = Goal (P qpn) gr close (OpenGoal (Simple (Ext _) _) _ ) = error "Distribution.Solver.Modular.Dependency.close: called on Ext goal" close (OpenGoal (Simple (Lang _) _) _ ) = diff --git a/cabal-install/Distribution/Solver/Modular/Index.hs b/cabal-install/Distribution/Solver/Modular/Index.hs index 7fc55e42735..56a8f708763 100644 --- a/cabal-install/Distribution/Solver/Modular/Index.hs +++ b/cabal-install/Distribution/Solver/Modular/Index.hs @@ -44,7 +44,7 @@ defaultQualifyOptions idx = QO { -- .. which are installed .. , (I _ver (Inst _), PInfo deps _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. - , (Dep dep _ci, _comp) <- flattenFlaggedDeps deps + , (Dep _is_exe dep _ci, _comp) <- flattenFlaggedDeps deps ] , qoSetupIndependent = True } diff --git a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs index 971c7796bfd..48942ffd541 100644 --- a/cabal-install/Distribution/Solver/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Solver/Modular/IndexConversion.hs @@ -87,7 +87,9 @@ convIPId pn' idx ipid = Nothing -> Nothing Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) pn = pkgName (sourcePackageId ipi) - in Just (D.Simple (Dep pn (Fixed i (P pn'))) ()) + in Just (D.Simple (Dep False pn (Fixed i (P pn'))) ()) + -- 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. @@ -118,8 +120,10 @@ convGPD os arch cinfo strfl pi -- and thus cannot actually be solved over. We'll do this -- by creating a set of package names which are "internal" -- and dropping them as we convert. - ipns = S.fromList [ PackageName nm - | (nm, _) <- sub_libs ] + ipns = S.fromList $ [ PackageName nm + | (nm, _) <- sub_libs ] ++ + [ PackageName nm + | (nm, _) <- exes ] conv :: Mon.Monoid a => Component -> (a -> BuildInfo) -> CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN @@ -139,44 +143,6 @@ convGPD os arch cinfo strfl pi in PInfo flagged_deps fds Nothing --- With convenience libraries, we have to do some work. Imagine you --- have the following Cabal file: --- --- name: foo --- library foo-internal --- build-depends: external-a --- library --- build-depends: foo-internal, external-b --- library foo-helper --- build-depends: foo, external-c --- test-suite foo-tests --- build-depends: foo-helper, external-d --- --- What should the final flagged dependency tree be? Ideally, it --- should look like this: --- --- [ Simple (Dep external-a) (Library foo-internal) --- , Simple (Dep external-b) (Library foo) --- , Stanza (SN foo TestStanzas) $ --- [ Simple (Dep external-c) (Library foo-helper) --- , Simple (Dep external-d) (TestSuite foo-tests) ] --- ] --- --- There are two things to note: --- --- 1. First, we eliminated the "local" dependencies foo-internal --- and foo-helper. This are implicitly assumed to refer to "foo" --- so we don't need to have them around. If you forget this, --- Cabal will then try to pick a version for "foo-helper" but --- no such package exists (this is the cost of overloading --- build-depends to refer to both packages and components.) --- --- 2. Second, it is more precise to have external-c be qualified --- by a test stanza, since foo-helper only needs to be built if --- your are building the test suite (and not the main library). --- If you omit it, Cabal will always attempt to depsolve for --- foo-helper even if you aren't building the test suite. - -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@). @@ -214,15 +180,36 @@ convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo -> CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN convCondTree os arch cinfo pi@(PI pn _) fds comp getInfo ipns (CondNode info ds branches) = concatMap - (\d -> filterIPNs ipns d (D.Simple (convDep pn d) comp)) + (\d -> filterIPNs ipns d (D.Simple (convLibDep pn d) comp)) ds -- unconditional package dependencies ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies ++ L.map (\(Dependency pkn vr) -> D.Simple (Pkg pkn vr) comp) (PD.pkgconfigDepends bi) -- unconditional pkg-config dependencies ++ concatMap (convBranch os arch cinfo pi fds comp getInfo ipns) branches + -- build-tools dependencies + ++ concatMap + (\(Dependency (PackageName exe) vr) -> + case packageProvidingBuildTool exe of + Nothing -> [] + Just pn' -> [D.Simple (convExeDep pn (Dependency pn' vr)) comp]) + (PD.buildTools bi) where bi = getInfo info +-- | This function maps known @build-tools@ entries to Haskell package +-- names which provide them. This mapping corresponds exactly to +-- those build-tools that Cabal understands by default +-- ('builtinPrograms'), and are cabal install'able. This mapping is +-- purely for legacy; for other executables, @tool-depends@ should be +-- used instead. +-- +packageProvidingBuildTool :: String -> Maybe PackageName +packageProvidingBuildTool s = + if s `elem` ["hscolour", "haddock", "happy", "alex", "hsc2hs", + "c2hs", "cpphs", "greencard"] + then Just (PackageName s) + else Nothing + -- | Branch interpreter. Mutually recursive with 'convCondTree'. -- -- Here, we try to simplify one of Cabal's condition tree branches into the @@ -300,19 +287,26 @@ convBranch os arch cinfo pi@(PI pn _) fds comp getInfo ipns (c', t', mf') = -- Note that we make assumptions here on the form of the dependencies that -- can occur at this point. In particular, no occurrences of Fixed, and no -- occurrences of multiple version ranges, as all dependencies below this - -- point have been generated using 'convDep'. + -- point have been generated using 'convLibDep'. + -- + -- WARNING: This is quadratic! extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN - extractCommon ps ps' = [ D.Simple (Dep pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp - | D.Simple (Dep pn1 (Constrained [(vr1, _)])) _ <- ps - , D.Simple (Dep pn2 (Constrained [(vr2, _)])) _ <- ps' + extractCommon ps ps' = [ D.Simple (Dep is_exe1 pn1 (Constrained [(vr1 .||. vr2, P pn)])) comp + | D.Simple (Dep is_exe1 pn1 (Constrained [(vr1, _)])) _ <- ps + , D.Simple (Dep is_exe2 pn2 (Constrained [(vr2, _)])) _ <- ps' , pn1 == pn2 + , is_exe1 == is_exe2 ] --- | Convert a Cabal dependency to a solver-specific dependency. -convDep :: PN -> Dependency -> Dep PN -convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, P pn')]) +-- | Convert a Cabal dependency on a library to a solver-specific dependency. +convLibDep :: PN -> Dependency -> Dep PN +convLibDep pn' (Dependency pn vr) = Dep False {- not exe -} pn (Constrained [(vr, P pn')]) + +-- | Convert a Cabal dependency on a executable (build-tools) to a solver-specific dependency. +convExeDep :: PN -> Dependency -> Dep PN +convExeDep pn' (Dependency pn vr) = Dep True pn (Constrained [(vr, P pn')]) -- | Convert setup dependencies convSetupBuildInfo :: PI PN -> SetupBuildInfo -> FlaggedDeps Component PN convSetupBuildInfo (PI pn _i) nfo = - L.map (\d -> D.Simple (convDep pn d) ComponentSetup) (PD.setupDepends nfo) + L.map (\d -> D.Simple (convLibDep pn d) ComponentSetup) (PD.setupDepends nfo) diff --git a/cabal-install/Distribution/Solver/Modular/Linking.hs b/cabal-install/Distribution/Solver/Modular/Linking.hs index d37a7a17fe4..da77d0c4eff 100644 --- a/cabal-install/Distribution/Solver/Modular/Linking.hs +++ b/cabal-install/Distribution/Solver/Modular/Linking.hs @@ -301,7 +301,7 @@ linkDeps target = \blame deps -> do go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState () go1 blame dep rdep = case (dep, rdep) of - (Simple (Dep qpn _) _, ~(Simple (Dep qpn' _) _)) -> do + (Simple (Dep _ qpn _) _, ~(Simple (Dep _ qpn' _) _)) -> do vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs diff --git a/cabal-install/Distribution/Solver/Modular/Package.hs b/cabal-install/Distribution/Solver/Modular/Package.hs index ee521072392..011a62e38dc 100644 --- a/cabal-install/Distribution/Solver/Modular/Package.hs +++ b/cabal-install/Distribution/Solver/Modular/Package.hs @@ -76,8 +76,12 @@ instI :: I -> Bool instI (I _ (Inst _)) = True instI _ = False --- | Is the package in the primary group of packages. In particular this --- does not include packages pulled in as setup deps. +-- | 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 @@ -85,6 +89,7 @@ primaryPP (PackagePath _ns q) = go q go Unqualified = True go (Base _) = True go (Setup _) = False + go (Exe _ _) = False -- | Create artificial parents for each of the package names, making -- them all independent. diff --git a/cabal-install/Distribution/Solver/Modular/Validate.hs b/cabal-install/Distribution/Solver/Modular/Validate.hs index abc021baaa4..38a78e60cbd 100644 --- a/cabal-install/Distribution/Solver/Modular/Validate.hs +++ b/cabal-install/Distribution/Solver/Modular/Validate.hs @@ -153,7 +153,8 @@ validate = cata go let qdeps = qualifyDeps qo 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 = Dep qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps) + -- TODO: is the False here right? + let newactives = Dep False {- not exe -} qpn (Fixed i (P qpn)) : L.map (resetVar (P qpn)) (extractDeps pfa psa qdeps) -- We now try to extend the partial assignment with the new active constraints. let mnppa = extend extSupported langSupported pkgPresent (P qpn) ppa newactives -- In case we continue, we save the scoped dependencies diff --git a/cabal-install/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install/Distribution/Solver/Types/ComponentDeps.hs index 94781b8d0e1..6c36cc6083e 100644 --- a/cabal-install/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install/Distribution/Solver/Types/ComponentDeps.hs @@ -14,6 +14,7 @@ module Distribution.Solver.Types.ComponentDeps ( -- * Fine-grained package dependencies Component(..) + , componentNameToComponent , ComponentDep , ComponentDeps -- opaque -- ** Constructing ComponentDeps @@ -41,6 +42,8 @@ import Distribution.Compat.Semigroup (Semigroup((<>))) import GHC.Generics import Data.Foldable (fold) +import qualified Distribution.Types.ComponentName as CN + #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable(foldMap)) import Data.Monoid (Monoid(..)) @@ -90,6 +93,13 @@ instance Traversable ComponentDeps where instance Binary a => Binary (ComponentDeps a) +componentNameToComponent :: CN.ComponentName -> Component +componentNameToComponent (CN.CLibName) = ComponentLib +componentNameToComponent (CN.CSubLibName s) = ComponentSubLib s +componentNameToComponent (CN.CExeName s) = ComponentExe s +componentNameToComponent (CN.CTestName s) = ComponentTest s +componentNameToComponent (CN.CBenchName s) = ComponentBench s + {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} diff --git a/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs b/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs new file mode 100644 index 00000000000..5c3862a80b7 --- /dev/null +++ b/cabal-install/Distribution/Solver/Types/InstSolverPackage.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveGeneric #-} +module Distribution.Solver.Types.InstSolverPackage + ( InstSolverPackage(..) + ) where + +import Distribution.Compat.Binary (Binary(..)) +import Distribution.Package ( Package(..), HasUnitId(..) ) +import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) +import Distribution.Solver.Types.SolverId +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import GHC.Generics (Generic) + +-- | An 'InstSolverPackage' is a pre-existing installed pacakge +-- specified by the dependency solver. +data InstSolverPackage = InstSolverPackage { + instSolverPkgIPI :: InstalledPackageInfo, + instSolverPkgLibDeps :: ComponentDeps [SolverId], + instSolverPkgExeDeps :: ComponentDeps [SolverId] + } + deriving (Eq, Show, Generic) + +instance Binary InstSolverPackage + +instance Package InstSolverPackage where + packageId = packageId . instSolverPkgIPI + +instance HasUnitId InstSolverPackage where + installedUnitId = installedUnitId . instSolverPkgIPI diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs index f5693fbf4fb..5ba2ecac4e5 100644 --- a/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install/Distribution/Solver/Types/PackagePath.hs @@ -47,6 +47,18 @@ data Qualifier = -- infinite search trees in the solver. Therefore we limit ourselves to -- a single qualifier (within a given namespace). | Setup PackageName + + -- | If we depend on an executable from a package (via + -- @build-tools@), we should solve for the dependencies of that + -- package separately (since we're not going to actually try to + -- link it.) We qualify for EACH package separately; e.g., + -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on + -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that + -- would require a consistent dependency resolution for all + -- of the depended upon executables from a package; if we + -- tracked only @pn2@, that would require us to pick only one + -- version of an executable over the entire install plan.) + | Exe PackageName PackageName deriving (Eq, Ord, Show) -- | String representation of a package path. @@ -68,6 +80,7 @@ showPP (PackagePath ns q) = -- 'Base' qualifier, will always be @base@). go Unqualified = "" go (Setup pn) = display pn ++ "-setup." + go (Exe pn pn2) = display pn ++ "-" ++ display pn2 ++ "-exe." go (Base pn) = display pn ++ "." -- | A qualified entity. Pairs a package path with the entity. diff --git a/cabal-install/Distribution/Solver/Types/ResolverPackage.hs b/cabal-install/Distribution/Solver/Types/ResolverPackage.hs index 34318eed7ce..277f96e1aa3 100644 --- a/cabal-install/Distribution/Solver/Types/ResolverPackage.hs +++ b/cabal-install/Distribution/Solver/Types/ResolverPackage.hs @@ -2,17 +2,19 @@ {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ResolverPackage ( ResolverPackage(..) - , resolverPackageDeps + , resolverPackageLibDeps + , resolverPackageExeDeps ) where +import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (IsNode(..)) -import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Package (Package(..), HasUnitId(..)) +import Distribution.Simple.Utils (ordNub) import GHC.Generics (Generic) -- | The dependency resolver picks either pre-existing installed packages @@ -20,23 +22,29 @@ import GHC.Generics (Generic) -- -- This is like the 'InstallPlan.PlanPackage' but with fewer cases. -- -data ResolverPackage loc = PreExisting InstalledPackageInfo (CD.ComponentDeps [SolverId]) +data ResolverPackage loc = PreExisting InstSolverPackage | Configured (SolverPackage loc) deriving (Eq, Show, Generic) instance Binary loc => Binary (ResolverPackage loc) instance Package (ResolverPackage loc) where - packageId (PreExisting ipkg _) = packageId ipkg + packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg -resolverPackageDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] -resolverPackageDeps (PreExisting _ deps) = deps -resolverPackageDeps (Configured spkg) = solverPkgDeps spkg +resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg +resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg + +resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] +resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg +resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId - nodeKey (PreExisting ipkg _) = PreExistingId (packageId ipkg) (installedUnitId ipkg) + nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) nodeKey (Configured spkg) = PlannedId (packageId spkg) -- Use dependencies for ALL components - nodeNeighbors pkg = CD.flatDeps (resolverPackageDeps pkg) + nodeNeighbors pkg = + ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ + CD.flatDeps (resolverPackageExeDeps pkg) diff --git a/cabal-install/Distribution/Solver/Types/SolverPackage.hs b/cabal-install/Distribution/Solver/Types/SolverPackage.hs index 0bd5f8e8fd7..fc91f717862 100644 --- a/cabal-install/Distribution/Solver/Types/SolverPackage.hs +++ b/cabal-install/Distribution/Solver/Types/SolverPackage.hs @@ -23,7 +23,8 @@ data SolverPackage loc = SolverPackage { solverPkgSource :: SourcePackage loc, solverPkgFlags :: FlagAssignment, solverPkgStanzas :: [OptionalStanza], - solverPkgDeps :: ComponentDeps [SolverId] + solverPkgLibDeps :: ComponentDeps [SolverId], + solverPkgExeDeps :: ComponentDeps [SolverId] } deriving (Eq, Show, Generic) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 626d6c3f79a..a755cf790c0 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -77,6 +77,12 @@ Extra-Source-Files: tests/IntegrationTests/multiple-source/p/p.cabal tests/IntegrationTests/multiple-source/q/Setup.hs tests/IntegrationTests/multiple-source/q/q.cabal + tests/IntegrationTests/new-build/BuildToolsPath.sh + tests/IntegrationTests/new-build/BuildToolsPath/A.hs + tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs + tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal + tests/IntegrationTests/new-build/BuildToolsPath/cabal.project + tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs tests/IntegrationTests/new-build/T3460.sh tests/IntegrationTests/new-build/T3460/C.hs tests/IntegrationTests/new-build/T3460/Setup.hs @@ -88,6 +94,17 @@ Extra-Source-Files: tests/IntegrationTests/new-build/T3460/sub-package-B/B.hs tests/IntegrationTests/new-build/T3460/sub-package-B/Setup.hs tests/IntegrationTests/new-build/T3460/sub-package-B/sub-package-B.cabal + tests/IntegrationTests/new-build/executable/Main.hs + tests/IntegrationTests/new-build/executable/Setup.hs + tests/IntegrationTests/new-build/executable/Test.hs + tests/IntegrationTests/new-build/executable/a.cabal + tests/IntegrationTests/new-build/executable/cabal.project + tests/IntegrationTests/new-build/external_build_tools.sh + tests/IntegrationTests/new-build/external_build_tools/cabal.project + tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs + tests/IntegrationTests/new-build/external_build_tools/client/client.cabal + tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs + tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal tests/IntegrationTests/new-build/monitor_cabal_files.sh tests/IntegrationTests/new-build/monitor_cabal_files/cabal.project tests/IntegrationTests/new-build/monitor_cabal_files/p/P.hs @@ -268,6 +285,7 @@ executable cabal Distribution.Solver.Types.ConstraintSource Distribution.Solver.Types.DependencyResolver Distribution.Solver.Types.InstalledPreference + Distribution.Solver.Types.InstSolverPackage Distribution.Solver.Types.LabeledPackageConstraint Distribution.Solver.Types.OptionalStanza Distribution.Solver.Types.PackageConstraint diff --git a/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh new file mode 100644 index 00000000000..90f3107853e --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath.sh @@ -0,0 +1,3 @@ +. ./common.sh +cd BuildToolsPath +cabal new-build build-tools-path hello-world diff --git a/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs new file mode 100644 index 00000000000..e5e075ad70c --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/A.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -F -pgmF my-custom-preprocessor #-} +module A where + +a :: String +a = "0000" diff --git a/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs new file mode 100644 index 00000000000..09c949ab176 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/MyCustomPreprocessor.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.IO + +main :: IO () +main = do + (_:source:target:_) <- getArgs + let f '0' = '1' + f c = c + writeFile target . map f =<< readFile source diff --git a/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal new file mode 100644 index 00000000000..12214a34357 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/build-tools-path.cabal @@ -0,0 +1,25 @@ +name: build-tools-path +version: 0.1.0.0 +synopsis: Checks build-tools are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable my-custom-preprocessor + main-is: MyCustomPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 + +library + exposed-modules: A + build-depends: base + build-tools: my-custom-preprocessor + -- ^ Note the internal dependency. + default-language: Haskell2010 + +executable hello-world + main-is: Hello.hs + build-depends: base, build-tools-path + default-language: Haskell2010 + hs-source-dirs: hello diff --git a/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs new file mode 100644 index 00000000000..89a5e5a026d --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/BuildToolsPath/hello/Hello.hs @@ -0,0 +1,6 @@ +module Main where + +import A + +main :: IO () +main = putStrLn a diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs b/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs new file mode 100644 index 00000000000..b3549c2fe3d --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/executable/Main.hs @@ -0,0 +1 @@ +main = return () diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs b/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/executable/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs b/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs new file mode 100644 index 00000000000..b3549c2fe3d --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/executable/Test.hs @@ -0,0 +1 @@ +main = return () diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal b/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal new file mode 100644 index 00000000000..ed9fc2919a6 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/executable/a.cabal @@ -0,0 +1,15 @@ +name: a +version: 0.1 +cabal-version: >= 1.10 +build-type: Simple + +executable aexe + main-is: Main.hs + build-depends: base + default-language: Haskell2010 + +test-suite atest + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project b/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/executable/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh b/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh new file mode 100644 index 00000000000..a12a5c83a12 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/external_build_tools.sh @@ -0,0 +1,3 @@ +. ./common.sh +cd external_build_tools +cabal new-build client diff --git a/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project new file mode 100644 index 00000000000..b5377830e88 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/cabal.project @@ -0,0 +1 @@ +packages: client, happy diff --git a/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs new file mode 100644 index 00000000000..2573eba65c2 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/Hello.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -F -pgmF happy #-} +module Main where + +a :: String +a = "0000" + +main :: IO () +main = putStrLn a diff --git a/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal new file mode 100644 index 00000000000..23070a812fa --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/client/client.cabal @@ -0,0 +1,13 @@ +name: client +version: 0.1.0.0 +synopsis: Checks build-tools are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable hello-world + main-is: Hello.hs + build-depends: base + build-tools: happy + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs new file mode 100644 index 00000000000..09c949ab176 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/MyCustomPreprocessor.hs @@ -0,0 +1,11 @@ +module Main where + +import System.Environment +import System.IO + +main :: IO () +main = do + (_:source:target:_) <- getArgs + let f '0' = '1' + f c = c + writeFile target . map f =<< readFile source diff --git a/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal new file mode 100644 index 00000000000..0e95effb701 --- /dev/null +++ b/cabal-install/tests/IntegrationTests/new-build/external_build_tools/happy/happy.cabal @@ -0,0 +1,12 @@ +name: happy +version: 999.999.999 +synopsis: Checks build-tools on legacy package name are put in PATH +license: BSD3 +category: Testing +build-type: Simple +cabal-version: >=1.10 + +executable happy + main-is: MyCustomPreprocessor.hs + build-depends: base, directory + default-language: Haskell2010 diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 3c7d2ae11e5..edccd676969 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -118,7 +118,7 @@ testSetupScriptStyles config reportSubCase = do reportSubCase (show SetupCustomExplicitDeps) (plan1, res1) <- executePlan =<< planProject testdir1 config (pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA - pkgSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps + elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps hasDefaultSetupDeps pkg1 @?= Just False marker1 <- readFile (basedir testdir1 "marker") marker1 @?= "ok" @@ -127,7 +127,7 @@ testSetupScriptStyles config reportSubCase = do reportSubCase (show SetupCustomImplicitDeps) (plan2, res2) <- executePlan =<< planProject testdir2 config (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA - pkgSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps + elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps hasDefaultSetupDeps pkg2 @?= Just True marker2 <- readFile (basedir testdir2 "marker") marker2 @?= "ok" @@ -136,7 +136,7 @@ testSetupScriptStyles config reportSubCase = do reportSubCase (show SetupNonCustomInternalLib) (plan3, res3) <- executePlan =<< planProject testdir3 config (pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA - pkgSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib + elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib {- --TODO: the SetupNonCustomExternalLib case is hard to test since it -- requires a version of Cabal that's later than the one we're testing @@ -155,7 +155,7 @@ testSetupScriptStyles config reportSubCase = do pkgidA = PackageIdentifier (PackageName "a") (Version [0,1] []) -- The solver fills in default setup deps explicitly, but marks them as such hasDefaultSetupDeps = fmap defaultSetupDepends - . setupBuildInfo . pkgDescription + . setupBuildInfo . elabPkgDescription -- | Test the behaviour with and without @--keep-going@ -- @@ -236,13 +236,13 @@ planProject testdir cliConfig = do let targets = Map.fromList - [ (installedUnitId pkg, [BuildDefaultComponents]) - | InstallPlan.Configured pkg <- InstallPlan.toList elaboratedPlan - , pkgBuildStyle pkg == BuildInplaceOnly ] + [ (installedUnitId elab, [BuildDefaultComponents]) + | InstallPlan.Configured elab <- InstallPlan.toList elaboratedPlan + , elabBuildStyle elab == BuildInplaceOnly ] elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan (elaboratedPlan'', pkgsBuildStatus) <- - rebuildTargetsDryRun distDirLayout + rebuildTargetsDryRun verbosity distDirLayout elaboratedShared elaboratedPlan' let buildSettings = resolveBuildTimeSettings diff --git a/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal b/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal index a9dced8d3a0..f0bf220bef0 100644 --- a/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal +++ b/cabal-install/tests/IntegrationTests2/exception/configure/a.cabal @@ -1,3 +1,9 @@ name: a version: 1 build-type: Simple +-- This used to be a blank package with no components, +-- but I refactored new-build so that if a package has +-- no buildable components, we skip configuring it. +-- So put in a (failing) component so that we try to +-- configure. +executable a diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs index f4fbf0fbebc..2d06a8cdb2b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -1,10 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} +{-# LANGUAGE ConstraintKinds #-} module UnitTests.Distribution.Client.InstallPlan (tests) where import Distribution.Package import Distribution.Version import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (GenericInstallPlan) +import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Graph (IsNode(..)) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.ComponentDeps as CD @@ -146,6 +150,12 @@ instance Show TestInstallPlan where data TestPkg = TestPkg PackageId UnitId [UnitId] deriving (Eq, Show) +instance IsNode TestPkg where + type Key TestPkg = UnitId + nodeKey (TestPkg _ ipkgid _) = ipkgid + nodeNeighbors (TestPkg _ _ deps) = deps + + instance Package TestPkg where packageId (TestPkg pkgid _ _) = pkgid @@ -155,6 +165,9 @@ instance HasUnitId TestPkg where instance PackageFixedDeps TestPkg where depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps +instance PackageInstalled TestPkg where + installedDepends (TestPkg _ _ deps) = deps + instance Arbitrary TestInstallPlan where arbitrary = arbitraryTestInstallPlan @@ -191,8 +204,8 @@ 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 :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) +arbitraryInstallPlan :: (IsUnit ipkg, + IsUnit srcpkg) => (Vertex -> [Vertex] -> Gen ipkg) -> (Vertex -> [Vertex] -> Gen srcpkg) -> Float @@ -222,9 +235,7 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do ] let index = Graph.fromList (map InstallPlan.PreExisting ipkgs ++ map InstallPlan.Configured srcpkgs) - case InstallPlan.new (IndependentGoals False) index of - Right plan -> return plan - Left _ -> error "arbitraryInstallPlan: generated invalid plan" + return $ InstallPlan.new (IndependentGoals False) index -- | Generate a random directed acyclic graph, based on the algorithm presented diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 3ae64ccd098..cbe70725ad6 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -122,6 +122,12 @@ data ExampleDependency = -- | Simple dependency on a fixed version | ExFix ExamplePkgName ExamplePkgVersion + -- | Build-tools dependency + | ExBuildToolAny ExamplePkgName + + -- | Build-tools dependency on a fixed version + | ExBuildToolFix ExamplePkgName ExamplePkgVersion + -- | Dependencies indexed by a flag | ExFlag ExampleFlagName Dependencies Dependencies @@ -222,7 +228,7 @@ exDbPkgs = map (either exInstName exAvName) exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage exAvSrcPkg ex = - let (libraryDeps, exts, mlang, pcpkgs) = splitTopLevel (CD.libraryDeps (exAvDeps ex)) + let (libraryDeps, exts, mlang, pcpkgs, exes) = splitTopLevel (CD.libraryDeps (exAvDeps ex)) testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] in SourcePackage { packageInfoId = exAvPkgId ex @@ -244,7 +250,8 @@ exAvSrcPkg ex = } , C.genPackageFlags = nub $ concatMap extractFlags $ CD.libraryDeps (exAvDeps ex) ++ concatMap snd testSuites - , C.condLibrary = Just (mkCondTree (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs) + , C.condLibrary = Just (mkCondTree + (extsLib exts <> langLib mlang <> pcpkgLib pcpkgs <> buildtoolsLib exes) disableLib (Buildable libraryDeps)) , C.condSubLibraries = [] @@ -263,27 +270,36 @@ exAvSrcPkg ex = , [Extension] , Maybe Language , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config + , [(ExamplePkgName, Maybe Int)] ) splitTopLevel [] = - ([], [], Nothing, []) + ([], [], Nothing, [], []) + splitTopLevel (ExBuildToolAny p:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, Nothing):exes) + splitTopLevel (ExBuildToolFix p v:deps) = + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, exts, lang, pcpkgs, (p, Just v):exes) splitTopLevel (ExExt ext:deps) = - let (other, exts, lang, pcpkgs) = splitTopLevel deps - in (other, ext:exts, lang, pcpkgs) + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, ext:exts, lang, pcpkgs, exes) splitTopLevel (ExLang lang:deps) = case splitTopLevel deps of - (other, exts, Nothing, pcpkgs) -> (other, exts, Just lang, pcpkgs) + (other, exts, Nothing, pcpkgs, exes) -> (other, exts, Just lang, pcpkgs, exes) _ -> error "Only 1 Language dependency is supported" splitTopLevel (ExPkg pkg:deps) = - let (other, exts, lang, pcpkgs) = splitTopLevel deps - in (other, exts, lang, pkg:pcpkgs) + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (other, exts, lang, pkg:pcpkgs, exes) splitTopLevel (dep:deps) = - let (other, exts, lang, pcpkgs) = splitTopLevel deps - in (dep:other, exts, lang, pcpkgs) + let (other, exts, lang, pcpkgs, exes) = splitTopLevel deps + in (dep:other, exts, lang, pcpkgs, exes) -- Extract the total set of flags used extractFlags :: ExampleDependency -> [C.Flag] extractFlags (ExAny _) = [] extractFlags (ExFix _ _) = [] + extractFlags (ExBuildToolAny _) = [] + extractFlags (ExBuildToolFix _ _) = [] extractFlags (ExFlag f a b) = C.MkFlag { C.flagName = C.FlagName f , C.flagDescription = "" @@ -310,6 +326,9 @@ exAvSrcPkg ex = let (directDeps, flaggedDeps) = splitDeps deps in C.CondNode { C.condTreeData = x -- Necessary for language extensions + -- TODO: Arguably, build-tools dependencies should also + -- effect constraints on conditional tree. But no way to + -- distinguish between them , C.condTreeConstraints = map mkDirect directDeps , C.condTreeComponents = map (mkFlagged dontBuild) flaggedDeps } @@ -380,6 +399,12 @@ exAvSrcPkg ex = pcpkgLib :: [(ExamplePkgName, ExamplePkgVersion)] -> C.Library pcpkgLib ds = mempty { C.libBuildInfo = mempty { C.pkgconfigDepends = [mkDirect (n, (Just v)) | (n,v) <- ds] } } + buildtoolsLib :: [(ExamplePkgName, Maybe Int)] -> C.Library + buildtoolsLib ds = mempty { C.libBuildInfo = mempty { + C.buildTools = map mkDirect ds + } } + + exAvPkgId :: ExampleAvailable -> C.PackageIdentifier exAvPkgId ex = C.PackageIdentifier { pkgName = C.PackageName (exAvName ex) diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs index 3b62327c148..25f0da0ba6d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -156,6 +156,14 @@ tests = [ , 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)]) ] + -- Build-tools dependencies + , testGroup "build-tools" [ + runTest $ mkTest dbBuildTools1 "bt1" ["A"] (SolverSuccess [("A", 1), ("alex", 1)]) + , runTest $ mkTest dbBuildTools2 "bt2" ["A"] (SolverSuccess [("A", 1)]) + , runTest $ mkTest dbBuildTools3 "bt3" ["C"] (SolverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) + , runTest $ mkTest dbBuildTools4 "bt4" ["B"] (SolverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) + , runTest $ mkTest dbBuildTools5 "bt5" ["A"] (SolverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) + ] ] where soft prefs test = test { testSoftConstraints = prefs } @@ -1064,3 +1072,46 @@ dbBJ8 = [ , Right $ exAv "B" 1 [ExAny "C"] , Right $ exAv "C" 1 [] ] + +{------------------------------------------------------------------------------- + Databases for build-tools +-------------------------------------------------------------------------------} +dbBuildTools1 :: ExampleDb +dbBuildTools1 = [ + Right $ exAv "alex" 1 [], + Right $ exAv "A" 1 [ExBuildToolAny "alex"] + ] + +-- Test that build-tools on a random thing doesn't matter (only +-- the ones we recognize need to be in db) +dbBuildTools2 :: ExampleDb +dbBuildTools2 = [ + Right $ exAv "A" 1 [ExBuildToolAny "otherdude"] + ] + +-- Test that we can solve for different versions of executables +dbBuildTools3 :: ExampleDb +dbBuildTools3 = [ + Right $ exAv "alex" 1 [], + Right $ exAv "alex" 2 [], + Right $ exAv "A" 1 [ExBuildToolFix "alex" 1], + Right $ exAv "B" 1 [ExBuildToolFix "alex" 2], + Right $ exAv "C" 1 [ExAny "A", ExAny "B"] + ] + +-- Test that exe is not related to library choices +dbBuildTools4 :: ExampleDb +dbBuildTools4 = [ + Right $ exAv "alex" 1 [ExFix "A" 1], + Right $ exAv "A" 1 [], + Right $ exAv "A" 2 [], + Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2] + ] + +-- Test that build-tools on build-tools works +dbBuildTools5 :: ExampleDb +dbBuildTools5 = [ + Right $ exAv "alex" 1 [], + Right $ exAv "happy" 1 [ExBuildToolAny "alex"], + Right $ exAv "A" 1 [ExBuildToolAny "happy"] + ]