diff --git a/Cabal-syntax/src/Distribution/Types/ExposedModule.hs b/Cabal-syntax/src/Distribution/Types/ExposedModule.hs index 22f8d7b9803..aa779c8cade 100644 --- a/Cabal-syntax/src/Distribution/Types/ExposedModule.hs +++ b/Cabal-syntax/src/Distribution/Types/ExposedModule.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Types.ExposedModule where import Distribution.Compat.Prelude diff --git a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs index 7d68bb251de..e136a322b02 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs @@ -29,7 +29,7 @@ tests = testGroup "Distribution.Utils.Structured" , testCase "GenericPackageDescription" $ md5Check (Proxy :: Proxy GenericPackageDescription) 0xa3e9433662ecf0c7a3c26f6d75a53ba1 , testCase "LocalBuildInfo" $ - md5Check (Proxy :: Proxy LocalBuildInfo) 0x91ffcd61bbd83525e8edba877435a031 + md5Check (Proxy :: Proxy LocalBuildInfo) 0x2d7678029074527cd6b3b03bb3f27ab7 #endif ] diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index e2a75946d37..d3da53fc563 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -46,6 +46,7 @@ import Distribution.Verbosity import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Utils.LogProgress +import Distribution.Backpack.ModuleShape import Data.Either ( lefts ) @@ -66,7 +67,7 @@ configureComponentLocalBuildInfos -> Flag String -- configIPID -> Flag ComponentId -- configCID -> PackageDescription - -> [PreExistingComponent] + -> ([PreExistingComponent], [FakePreExistingComponent]) -> FlagAssignment -- configConfigurationsFlags -> [(ModuleName, Module)] -- configInstantiateWith -> InstalledPackageIndex @@ -74,7 +75,7 @@ configureComponentLocalBuildInfos -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr - prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do + (prePkgDeps, promisedPkgDeps) flagAssignment instantiate_with installedPackageSet comp = do -- NB: In single component mode, this returns a *single* component. -- In this graph, the graph is NOT closed. graph0 <- case mkComponentsGraph enabled pkg_descr of @@ -92,6 +93,10 @@ configureComponentLocalBuildInfos ann_cname = pc_compname pkg })) | pkg <- prePkgDeps] + `Map.union` + Map.fromListWith Map.union + [ (pkg, Map.singleton (ann_cname aid) aid) + | FakePreExistingComponent pkg aid <- promisedPkgDeps] graph1 <- toConfiguredComponents use_external_internal_deps flagAssignment deterministic ipid_flag cid_flag pkg_descr @@ -102,13 +107,17 @@ configureComponentLocalBuildInfos let shape_pkg_map = Map.fromList [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) | pkg <- prePkgDeps] + `Map.union` + Map.fromList + [ (ann_id aid, (DefiniteUnitId (unsafeMkDefUnitId $ mkUnitId (unComponentId (ann_id aid) )), emptyModuleShape)) + | FakePreExistingComponent _ aid <- promisedPkgDeps] uid_lookup def_uid | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid = FullUnitId (Installed.installedComponentId pkg) (Map.fromList (Installed.instantiatedWith pkg)) | otherwise = error ("uid_lookup: " ++ prettyShow uid) where uid = unDefUnitId def_uid - graph2 <- toLinkedComponents verbosity uid_lookup + graph2 <- toLinkedComponents verbosity (not (null promisedPkgDeps)) uid_lookup (package pkg_descr) shape_pkg_map graph1 infoProgress $ @@ -129,7 +138,7 @@ configureComponentLocalBuildInfos infoProgress $ hang (text "Ready component graph:") 4 (vcat (map dispReadyComponent graph4)) - toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 + toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4 ------------------------------------------------------------------------------ -- ComponentLocalBuildInfo @@ -138,13 +147,14 @@ configureComponentLocalBuildInfos toComponentLocalBuildInfos :: Compiler -> InstalledPackageIndex -- FULL set + -> [FakePreExistingComponent] -> PackageDescription -> [PreExistingComponent] -- external package deps -> [ReadyComponent] -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) -- only relevant packages toComponentLocalBuildInfos - comp installedPackageSet pkg_descr externalPkgDeps graph = do + comp installedPackageSet promisedPkgDeps pkg_descr externalPkgDeps graph = do -- Check and make sure that every instantiated component exists. -- We have to do this now, because prior to linking/instantiating -- we don't actually know what the full set of 'UnitId's we need @@ -178,9 +188,15 @@ toComponentLocalBuildInfos -- packageDependsIndex = PackageIndex.fromList (lefts local_graph) fullIndex = Graph.fromDistinctList local_graph + case Graph.broken fullIndex of [] -> return () - broken -> + -- If there are promised dependencies, we don't know what the dependencies + -- of these are and that can easily lead to a broken graph. So assume that + -- any promised package is not broken (ie all its dependencies, transitively, + -- will be there). That's a promise. + broken | not (null promisedPkgDeps) -> return () + | otherwise -> -- TODO: ppr this dieProgress . text $ "The following packages are broken because other" diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs index 69178e048ce..47f7a195ee2 100644 --- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs @@ -49,6 +49,7 @@ import qualified Data.Map as Map import Distribution.Pretty import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$)) import qualified Text.PrettyPrint as PP +import Distribution.Compat.Stack -- | A configured component, we know exactly what its 'ComponentId' is, -- and the 'ComponentId's of the things it depends on. @@ -177,22 +178,23 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do if newPackageDepsBehaviour pkg_descr then fmap concat $ forM (targetBuildDepends bi) $ \(Dependency name _ sublibs) -> do - pkg <- case Map.lookup name lib_dep_map of + case Map.lookup name lib_dep_map of Nothing -> dieProgress $ text "Dependency on unbuildable" <+> text "package" <+> pretty name - Just p -> return p - -- Return all library components - forM (NonEmptySet.toList sublibs) $ \lib -> - let comp = CLibName lib in - case Map.lookup comp pkg of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text (showLibraryName lib) <+> - text "from" <+> pretty name - Just v -> return v + $$ text (prettyCallStack callStack) + Just pkg -> do + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib in + case Map.lookup comp pkg of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" <+> + text (showLibraryName lib) <+> + text "from" <+> pretty name + Just v -> return v else return old_style_lib_deps mkConfiguredComponent pkg_descr this_cid diff --git a/Cabal/src/Distribution/Backpack/LinkedComponent.hs b/Cabal/src/Distribution/Backpack/LinkedComponent.hs index 797fef251ac..7badd1a37d7 100644 --- a/Cabal/src/Distribution/Backpack/LinkedComponent.hs +++ b/Cabal/src/Distribution/Backpack/LinkedComponent.hs @@ -114,12 +114,13 @@ instance Package LinkedComponent where toLinkedComponent :: Verbosity + -> Bool -> FullDb -> PackageId -> LinkedComponentMap -> ConfiguredComponent -> LogProgress LinkedComponent -toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { +toLinkedComponent verbosity any_promised db this_pid pkg_map ConfiguredComponent { cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, cc_component = component, cc_exe_deps = exe_deps, @@ -276,9 +277,14 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { case filter (\x' -> unWithSource x /= unWithSource x') xs of [] -> return () _ -> Left $ ambiguousReexportMsg reex x xs - return (to, unWithSource x) + return (to, Just (unWithSource x)) _ -> - Left (brokenReexportMsg reex) + -- Can't resolve it right now.. carry on with the assumption it will be resolved + -- dynamically later by an in-memory package which hasn't been installed yet. + if any_promised + then return (to, Nothing) + -- But if nothing is promised, eagerly report an error, as we already know everything. + else Left (brokenReexportMsg reex) -- TODO: maybe check this earlier; it's syntactically obvious. let build_reexports m (k, v) @@ -289,8 +295,20 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { provs <- foldM build_reexports Map.empty $ -- TODO: doublecheck we have checked for -- src_provs duplicates already! - [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ - reexports_list + -- These are normal module exports. + [ (mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs ] + ++ + -- These are reexports, which we managed to resolve to something in an external package. + [(mn_new, om) | (mn_new, Just om) <- reexports_list ] + ++ + -- These ones.. we didn't resolve but also we might not have to resolve them because they could come from a promised unit, which we don't know + -- anything about yet. GHC will resolve these itself when it is dealing with the multi-session. These ones will not be built, registered and put + -- into a package database, we only need them to make it as far as generating GHC options where the info will be used to pass the reexported-module option + -- to GHC. + + -- We also know that in the case there are promised units that we will not be doing anything to do with backpack like unification etc.. + [ (mod_name, (OpenModule (DefiniteUnitId (unsafeMkDefUnitId (mkUnitId "fake"))) mod_name)) | (mod_name, Nothing) <- reexports_list ] + -- [(mn_new, OpenModule mn_new) | (mn_new, Nothing) <- reexports_list ] let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) @@ -337,12 +355,14 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents :: Verbosity + -> Bool -- ^ Whether there are any "promised" package dependencies which we won't + -- find already installed. -> FullDb -> PackageId -> LinkedComponentMap -> [ConfiguredComponent] -> LogProgress [LinkedComponent] -toLinkedComponents verbosity db this_pid lc_map0 comps +toLinkedComponents verbosity any_promised db this_pid lc_map0 comps = fmap snd (mapAccumM go lc_map0 comps) where go :: Map ComponentId (OpenUnitId, ModuleShape) @@ -350,7 +370,7 @@ toLinkedComponents verbosity db this_pid lc_map0 comps -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) go lc_map cc = do lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ - toLinkedComponent verbosity db this_pid lc_map cc + toLinkedComponent verbosity any_promised db this_pid lc_map cc return (extendLinkedComponentMap lc lc_map, lc) type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) diff --git a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs index 2fcfdf1cc83..23674388c54 100644 --- a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs +++ b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs @@ -1,6 +1,7 @@ -- | See module Distribution.Backpack.PreExistingComponent ( PreExistingComponent(..), + FakePreExistingComponent(..), ipiToPreExistingComponent, ) where @@ -20,6 +21,9 @@ import Distribution.Package import qualified Data.Map as Map import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Types.AnnotatedId + +data FakePreExistingComponent = FakePreExistingComponent PackageName (AnnotatedId ComponentId) -- | Stripped down version of 'LinkedComponent' for things -- we don't need to know how to build. @@ -56,6 +60,7 @@ ipiToPreExistingComponent ipi = pc_shape = shapeInstalledPackage ipi } + instance HasMungedPackageId PreExistingComponent where mungedId = pc_munged_id diff --git a/Cabal/src/Distribution/Compat/ResponseFile.hs b/Cabal/src/Distribution/Compat/ResponseFile.hs index db0a92994c8..4937da89975 100644 --- a/Cabal/src/Distribution/Compat/ResponseFile.hs +++ b/Cabal/src/Distribution/Compat/ResponseFile.hs @@ -3,7 +3,7 @@ -- Compatibility layer for GHC.ResponseFile -- Implementation from base 4.12.0 is used. -- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE -module Distribution.Compat.ResponseFile (expandResponse) where +module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where import Distribution.Compat.Prelude import Prelude () @@ -47,6 +47,20 @@ unescape args = reverse . map reverse $ go args NoneQ False [] [] | '"' == c = go cs DblQ False a as | otherwise = go cs NoneQ False (c:a) as +escapeArgs :: [String] -> String +escapeArgs = unlines . map escapeArg + +escapeArg :: String -> String +escapeArg = reverse . foldl' escape [] + +escape :: String -> Char -> String +escape cs c + | isSpace c + || '\\' == c + || '\'' == c + || '"' == c = c:'\\':cs -- n.b., our caller must reverse the result + | otherwise = c:cs + #endif expandResponse :: [String] -> IO [String] diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index ac7bd852f0d..a3cfd948fa6 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | @@ -56,7 +57,6 @@ module Distribution.Simple.Configure import Prelude () import Distribution.Compat.Prelude - import Distribution.Compiler import Distribution.Types.IncludeRenaming import Distribution.Utils.NubList @@ -132,6 +132,7 @@ import Distribution.Compat.Environment ( lookupEnv ) import qualified Data.Maybe as M import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NES +import Distribution.Types.AnnotatedId type UseExternalInternalDeps = Bool @@ -439,6 +440,8 @@ configure (pkg_descr0, pbi) cfg = do (configDependencies cfg) installedPackageSet + let promisedDepsSet = (mkPromisedDepsSet (configDependencies cfg)) + -- pkg_descr: The resolved package description, that does not contain any -- conditionals, because we have an assignment for -- every flag, either picking them ourselves using a @@ -465,6 +468,7 @@ configure (pkg_descr0, pbi) cfg = do (packageName pkg_descr0) installedPackageSet internalPackageSet + promisedDepsSet requiredDepsMap) comp compPlatform @@ -500,11 +504,12 @@ configure (pkg_descr0, pbi) cfg = do -- For one it's deterministic; for two, we need to associate -- them with renamings which would require a far more complicated -- input scheme than what we have today.) - externalPkgDeps :: [PreExistingComponent] + externalPkgDeps :: ([PreExistingComponent], [FakePreExistingComponent]) <- configureDependencies verbosity use_external_internal_deps internalPackageSet + promisedDepsSet installedPackageSet requiredDepsMap pkg_descr @@ -760,6 +765,7 @@ configure (pkg_descr0, pbi) cfg = do componentGraph = Graph.fromDistinctList buildComponents, componentNameMap = buildComponentsMap, installedPkgs = packageDependsIndex, + promisedPkgs = promisedDepsSet, pkgDescrFile = Nothing, localPkgDescr = pkg_descr', withPrograms = programDb'', @@ -843,6 +849,9 @@ configure (pkg_descr0, pbi) cfg = do where verbosity = fromFlag (configVerbosity cfg) +mkPromisedDepsSet :: [GivenComponent] -> Map (PackageName, ComponentName) ComponentId +mkPromisedDepsSet comps = Map.fromList [ ((pn, CLibName ln), cid) | GivenComponent pn ln cid IsInternal <- comps ] + mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb mkProgramDb cfg initialProgramDb = programDb where @@ -914,6 +923,7 @@ dependencySatisfiable -> PackageName -> InstalledPackageIndex -- ^ installed set -> Set LibraryName -- ^ library components + -> Map (PackageName, ComponentName) ComponentId -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required dependencies -> (Dependency -> Bool) @@ -921,7 +931,7 @@ dependencySatisfiable use_external_internal_deps exact_config allow_private_deps - pn installedPackageSet packageLibraries requiredDepsMap + pn installedPackageSet packageLibraries promised_deps requiredDepsMap (Dependency depName vr sublibs) | exact_config -- When we're given '--exact-configuration', we assume that all @@ -987,7 +997,12 @@ dependencySatisfiable -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs || pkgName (IPI.sourcePackageId ipi) == pn) maybeIPI + -- Don't check if it's visible, we promise to build it before we need it. + || promised where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + -- Promised is just the same as internal here + promised = isJust $ Map.lookup (depName, CLibName lib) promised_deps + -- | Finalize a generic package description. The workhorse is -- 'finalizePD' but there's a bit of other nattering @@ -1089,20 +1104,21 @@ configureDependencies :: Verbosity -> UseExternalInternalDeps -> Set LibraryName + -> Map (PackageName, ComponentName) ComponentId -> InstalledPackageIndex -- ^ installed packages -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps -> PackageDescription -> ComponentRequestedSpec - -> IO [PreExistingComponent] + -> IO ([PreExistingComponent], [FakePreExistingComponent]) configureDependencies verbosity use_external_internal_deps - packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do + packageLibraries promised_deps installedPackageSet requiredDepsMap pkg_descr enableSpec = do let failedDeps :: [FailedDependency] allPkgDeps :: [ResolvedDependency] (failedDeps, allPkgDeps) = partitionEithers $ concat [ fmap (\s -> (dep, s)) <$> status | dep <- enabledBuildDepends pkg_descr enableSpec , let status = selectDependency (package pkg_descr) - packageLibraries installedPackageSet + packageLibraries promised_deps installedPackageSet requiredDepsMap use_external_internal_deps dep ] internalPkgDeps = [ pkgid @@ -1113,6 +1129,9 @@ configureDependencies verbosity use_external_internal_deps externalPkgDeps = [ pec | (_, ExternalDependency pec) <- allPkgDeps ] + fakeExternalPkgDeps = [ fpec + | (_, FakeExternalDependency fpec) <- allPkgDeps ] + when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ die' verbosity $ "The field 'build-depends: " @@ -1124,7 +1143,7 @@ configureDependencies verbosity use_external_internal_deps reportFailedDependencies verbosity failedDeps reportSelectedDependencies verbosity allPkgDeps - return externalPkgDeps + return (externalPkgDeps, fakeExternalPkgDeps) -- | Select and apply coverage settings for the build based on the -- 'ConfigFlags' and 'Compiler'. @@ -1250,6 +1269,7 @@ data DependencyResolution -- internal dependency which we are getting from the package -- database. = ExternalDependency PreExistingComponent + | FakeExternalDependency FakePreExistingComponent -- | 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 @@ -1263,6 +1283,7 @@ data FailedDependency = DependencyNotExists PackageName -- | Test for a package dependency and record the version we have installed. selectDependency :: PackageId -- ^ Package id of current package -> Set LibraryName -- ^ package libraries + -> Map (PackageName, ComponentName) ComponentId -> InstalledPackageIndex -- ^ Installed packages -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ Packages for which we have been given specific deps to @@ -1271,7 +1292,7 @@ selectDependency :: PackageId -- ^ Package id of current package -- single component? -> Dependency -> [Either FailedDependency DependencyResolution] -selectDependency pkgid internalIndex installedIndex requiredDepsMap +selectDependency pkgid internalIndex promisedIndex installedIndex requiredDepsMap use_external_internal_deps (Dependency dep_pkgname vr libs) = -- If the dependency specification matches anything in the internal package @@ -1302,11 +1323,14 @@ selectDependency pkgid internalIndex installedIndex requiredDepsMap | Set.member lib internalIndex = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + | otherwise = Left $ DependencyMissingInternal dep_pkgname lib -- We have to look it up externally do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib | Just cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ FakeExternalDependency (FakePreExistingComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid )) do_external_external lib = do ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of -- If we know the exact pkg to use, then use it. @@ -1318,6 +1342,8 @@ selectDependency pkgid internalIndex installedIndex requiredDepsMap return $ ExternalDependency $ ipiToPreExistingComponent ipi do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib | Just cid <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ FakeExternalDependency (FakePreExistingComponent dep_pkgname (AnnotatedId currentCabalId (CLibName lib) cid )) do_external_internal lib = do ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of -- If we know the exact pkg to use, then use it. @@ -1340,7 +1366,8 @@ reportSelectedDependencies verbosity deps = | (dep, resolution) <- deps , let pkgid = case resolution of ExternalDependency pkg' -> packageId pkg' - InternalDependency pkgid' -> pkgid' ] + InternalDependency pkgid' -> pkgid' + FakeExternalDependency {} -> currentCompilerId ] reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () reportFailedDependencies _ [] = return () @@ -1479,21 +1506,21 @@ combinedConstraints constraints dependencies installedPackages = do allConstraints :: [PackageVersionConstraint] allConstraints = constraints ++ [ thisPackageVersionConstraint (packageId pkg) - | (_, _, _, Just pkg) <- dependenciesPkgInfo ] + | (_, _, _, Just pkg, _) <- dependenciesPkgInfo ] idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo idConstraintMap = Map.fromList -- NB: do NOT use the packageName from -- dependenciesPkgInfo! [ ((pn, cname), pkg) - | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ] + | (pn, cname, _, Just pkg, _) <- dependenciesPkgInfo ] -- The dependencies along with the installed package info, if it exists dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, - Maybe InstalledPackageInfo)] + Maybe InstalledPackageInfo, IsInternal)] dependenciesPkgInfo = - [ (pkgname, CLibName lname, cid, mpkg) - | GivenComponent pkgname lname cid <- dependencies + [ (pkgname, CLibName lname, cid, mpkg, int) + | GivenComponent pkgname lname cid int <- dependencies , let mpkg = PackageIndex.lookupComponentId installedPackages cid ] @@ -1503,7 +1530,7 @@ combinedConstraints constraints dependencies installedPackages = do -- an error. badComponentIds = [ (pkgname, cname, cid) - | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ] + | (pkgname, cname, cid, Nothing, IsExternal) <- dependenciesPkgInfo ] dispDependencies deps = hsep [ text "--dependency=" diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs index d5d9241a8ed..b8b85dbc167 100644 --- a/Cabal/src/Distribution/Simple/GHC.hs +++ b/Cabal/src/Distribution/Simple/GHC.hs @@ -117,7 +117,7 @@ import System.Directory ( doesFileExist, doesDirectoryExist , getAppUserDataDirectory, createDirectoryIfMissing , canonicalizePath, removeFile, renameFile, getDirectoryContents - , makeRelativeToCurrentDirectory ) + , makeRelativeToCurrentDirectory, getCurrentDirectory ) import System.FilePath ( (), (<.>), takeExtension , takeDirectory, replaceExtension ,isRelative ) @@ -125,6 +125,10 @@ import qualified System.Info #ifndef mingw32_HOST_OS import System.Posix (createSymbolicLink) #endif /* mingw32_HOST_OS */ +import qualified Data.ByteString.Lazy.Char8 as BS +import Distribution.Compat.ResponseFile (escapeArgs) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Compat.Binary (encode) -- ----------------------------------------------------------------------------- -- Configuring @@ -518,7 +522,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do when (forceStatic || withStaticLib lbi) whenGHCiLib = when (withGHCiLib lbi) forRepl = maybe False (const True) mReplFlags - whenReplLib = when forRepl + whenReplLib = forM_ mReplFlags replFlags = fromMaybe mempty mReplFlags comp = compiler lbi ghcVersion = compilerVersion comp @@ -630,10 +634,12 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do } `mappend` linkerOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, + ghcOptMode = isInteractive, ghcOptOptimisation = toFlag GhcNoOptimisation } + isInteractive = toFlag GhcModeInteractive + vanillaSharedOpts = vanillaOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, ghcOptDynHiSuffix = toFlag "dyn_hi", @@ -813,9 +819,9 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do -- TODO: problem here is we need the .c files built first, so we can load them -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. - whenReplLib $ do + whenReplLib $ \rflags -> do when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - runGhcProg replOpts + runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts libBi clbi (pkgName (PD.package pkg_descr)) -- link: when has_code . unless forRepl $ do @@ -920,7 +926,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do -> insts _ -> [], ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , + Internal.mkGhcOptPackages mempty clbi , ghcOptLinkLibs = extraLibs libBi, ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, @@ -954,7 +960,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do -> insts _ -> [], ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , + Internal.mkGhcOptPackages mempty clbi , ghcOptLinkLibs = extraLibs libBi, ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs } @@ -993,6 +999,45 @@ startInterpreter verbosity progdb comp platform packageDBs = do (ghcProg, _) <- requireProgram verbosity ghcProgram progdb runGHC verbosity ghcProg comp platform replOpts + +runReplOrWriteFlags + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> ReplOptions + -> GhcOptions + -> BuildInfo + -> ComponentLocalBuildInfo + -> PackageName + -> IO () +runReplOrWriteFlags verbosity ghcProg comp platform rflags replOpts bi clbi pkg_name = + case replOptionsFlagOutput rflags of + NoFlag -> runGHC verbosity ghcProg comp platform replOpts + Flag out_dir -> do + src_dir <- getCurrentDirectory + let uid = componentUnitId clbi + this_unit = prettyShow uid + reexported_modules = [mn | LibComponentLocalBuildInfo {} <- [clbi], IPI.ExposedModule mn (Just {}) <- componentExposedModules clbi] + hidden_modules = otherModules bi + extra_opts = concat $ + [ ["-this-package-name", prettyShow pkg_name] + , ["-working-dir" , src_dir] + ] ++ + [ ["-reexported-module", prettyShow m] | m <- reexported_modules + ] ++ + [ ["-hidden-module", prettyShow m] | m <- hidden_modules + ] + -- Create "paths" subdirectory if it doesn't exist. This is where we write + -- information about how the PATH was augmented. + createDirectoryIfMissing False (out_dir "paths") + -- Write out the PATH information into `paths` subdirectory. + writeFileAtomic (out_dir "paths" this_unit) (encode ghcProg) + -- Write out options for this component into a file ready for loading into + -- the multi-repl + writeFileAtomic (out_dir this_unit) $ BS.pack $ escapeArgs + $ (extra_opts ++) $ renderGhcOptions comp platform (replOpts { ghcOptMode = NoFlag }) + -- ----------------------------------------------------------------------------- -- Building an executable or foreign library @@ -1552,8 +1597,8 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do -- with ghci, but .c files can depend on .h files generated by ghc by ffi -- exports. case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts + GReplExe _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) + GReplFLib _ _ -> runReplOrWriteFlags verbosity ghcProg comp platform replFlags replOpts bnfo clbi (pkgName (PD.package pkg_descr)) GBuildExe _ -> do let linkOpts = commonOpts `mappend` linkerOpts diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 507831f3cab..330803a157b 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs @@ -77,12 +77,14 @@ import Distribution.Utils.Path import Language.Haskell.Extension import qualified Data.Map as Map +import qualified Data.Set as Set import qualified Data.ByteString.Lazy.Char8 as BS import System.Directory ( getDirectoryContents, getTemporaryDirectory ) import System.Environment ( getEnv ) import System.FilePath ( (), (<.>), takeExtension , takeDirectory, takeFileName) import System.IO ( hClose, hPutStrLn ) +import Distribution.Types.ComponentId (ComponentId) targetPlatform :: [(String, String)] -> Maybe Platform targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo @@ -292,7 +294,7 @@ componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = ++ [buildDir lbi dir | dir <- includeDirs bi], ghcOptHideAllPackages= toFlag True, ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, ghcOptCcOptions = (case withOptimization lbi of NoOptimisation -> [] _ -> ["-O2"]) ++ @@ -331,7 +333,7 @@ componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = ++ [buildDir lbi dir | dir <- includeDirs bi], ghcOptHideAllPackages= toFlag True, ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, ghcOptCxxOptions = (case withOptimization lbi of NoOptimisation -> [] _ -> ["-O2"]) ++ @@ -370,7 +372,7 @@ componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = ++ [buildDir lbi dir | dir <- includeDirs bi], ghcOptHideAllPackages= toFlag True, ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, ghcOptAsmOptions = (case withOptimization lbi of NoOptimisation -> [] _ -> ["-O2"]) ++ @@ -405,7 +407,7 @@ componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename = ++ [buildDir lbi dir | dir <- includeDirs bi], ghcOptHideAllPackages= toFlag True, ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, ghcOptObjDir = toFlag odir } @@ -422,7 +424,16 @@ componentGhcOptions verbosity implInfo lbi bi clbi odir = ghcOptThisUnitId = case clbi of LibComponentLocalBuildInfo { componentCompatPackageKey = pk } -> toFlag pk - _ -> mempty, + ExeComponentLocalBuildInfo { componentUnitId = uid } + -> toFlag (unUnitId uid) + TestComponentLocalBuildInfo { componentUnitId = uid } + -> toFlag (unUnitId uid) + BenchComponentLocalBuildInfo { componentUnitId = uid } + -> toFlag (unUnitId uid) + FLibComponentLocalBuildInfo { componentUnitId = uid } + -> toFlag (unUnitId uid) + + , ghcOptThisComponentId = case clbi of LibComponentLocalBuildInfo { componentComponentId = cid , componentInstantiatedWith = insts } -> @@ -438,7 +449,7 @@ componentGhcOptions verbosity implInfo lbi bi clbi odir = ghcOptHideAllPackages = toFlag True, ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi, ghcOptSplitSections = toFlag (splitSections lbi), ghcOptSplitObjs = toFlag (splitObjs lbi), ghcOptSourcePathClear = toFlag True, @@ -507,7 +518,7 @@ componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = [autogenComponentModulesDir lbi clbi cppHeaderName], ghcOptHideAllPackages= toFlag True, ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, + ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi, ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), ghcOptDebugInfo = toFlag (withDebugInfo lbi), ghcOptExtra = cmmOptions bi, @@ -560,9 +571,18 @@ getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs return [ pref ModuleName.toFilePath x <.> wanted_obj_ext | x <- allLibModules lib clbi ] -mkGhcOptPackages :: ComponentLocalBuildInfo +-- | Create the require packaged arguments, but filtering out package arguments which +-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files, +-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that +-- in 99% of cases we will include the right `-package` so that the C file finds the right headers. +mkGhcOptPackages :: Map (PackageName, ComponentName) ComponentId + -> ComponentLocalBuildInfo -> [(OpenUnitId, ModuleRenaming)] -mkGhcOptPackages = componentIncludes +mkGhcOptPackages promised_pkgs clbi = [ i | i@(uid, _) <- componentIncludes clbi + , abstractUnitId uid `Set.notMember` promised_cids ] + where + -- Promised deps are going to be simple UnitIds + promised_cids = Set.fromList (map newSimpleUnitId (Map.elems promised_pkgs)) substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo substTopDir topDir ipo diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs index c8721746a6a..b1951a5fae0 100644 --- a/Cabal/src/Distribution/Simple/GHCJS.hs +++ b/Cabal/src/Distribution/Simple/GHCJS.hs @@ -663,7 +663,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do -> insts _ -> [], ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , + Internal.mkGhcOptPackages mempty clbi , ghcOptLinkLibs = extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, @@ -695,7 +695,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do -> insts _ -> [], ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , + Internal.mkGhcOptPackages mempty clbi , ghcOptLinkLibs = extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi } diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs index 36f6aa22f15..fd698bd2fa1 100644 --- a/Cabal/src/Distribution/Simple/Setup.hs +++ b/Cabal/src/Distribution/Simple/Setup.hs @@ -260,7 +260,7 @@ data ConfigFlags = ConfigFlags { configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for -- dependencies. configDependencies :: [GivenComponent], - -- ^The packages depended on. + -- ^The packages depended on and whether they need to already exist or not. configInstantiateWith :: [(ModuleName, Module)], -- ^ The requested Backpack instantiation. If empty, either this -- package does not use Backpack, or we just want to typecheck @@ -685,10 +685,11 @@ 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[:COMPONENT_NAME]=CID" + (reqArg "[+]NAME[:COMPONENT_NAME]=CID" (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map (\(GivenComponent pn cn cid) -> - prettyShow pn + (map (\(GivenComponent pn cn cid int) -> + (case int of { IsInternal -> "+"; IsExternal -> ""}) + ++ prettyShow pn ++ case cn of LMainLibName -> "" LSubLibName n -> ":" ++ prettyShow n ++ "=" ++ prettyShow cid))) @@ -782,6 +783,7 @@ showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] parsecGivenComponent :: ParsecParser GivenComponent parsecGivenComponent = do + is_internal <- P.optional (P.char '+') pn <- parsec ln <- P.option LMainLibName $ do _ <- P.char ':' @@ -791,7 +793,7 @@ parsecGivenComponent = do else LSubLibName ucn _ <- P.char '=' cid <- parsec - return $ GivenComponent pn ln cid + return $ GivenComponent pn ln cid (case is_internal of Just {} -> IsInternal; _ -> IsExternal) installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions = @@ -1961,7 +1963,8 @@ instance Semigroup BuildFlags where data ReplOptions = ReplOptions { replOptionsFlags :: [String], - replOptionsNoLoad :: Flag Bool + replOptionsNoLoad :: Flag Bool, + replOptionsFlagOutput :: Flag FilePath } deriving (Show, Generic, Typeable) @@ -1970,7 +1973,7 @@ instance Structured ReplOptions instance Monoid ReplOptions where - mempty = ReplOptions mempty (Flag False) + mempty = ReplOptions mempty (Flag False) NoFlag mappend = (<>) instance Semigroup ReplOptions where @@ -2084,6 +2087,10 @@ replOptions _ = "Use the option(s) for the repl" replOptionsFlags (\p flags -> flags { replOptionsFlags = p }) (reqArg "FLAG" (succeedReadE words) id) + , option [] ["repl-multi-file"] + "Write repl options to this file rather than starting repl" + replOptionsFlagOutput (\p flags -> flags { replOptionsFlagOutput = p }) + (reqArg "FILEPATH" (succeedReadE Flag) flagToList) ] -- ------------------------------------------------------------ diff --git a/Cabal/src/Distribution/Types/AnnotatedId.hs b/Cabal/src/Distribution/Types/AnnotatedId.hs index 49a3c0f4039..6719e414814 100644 --- a/Cabal/src/Distribution/Types/AnnotatedId.hs +++ b/Cabal/src/Distribution/Types/AnnotatedId.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} module Distribution.Types.AnnotatedId ( AnnotatedId(..) ) where @@ -19,7 +20,7 @@ data AnnotatedId id = AnnotatedId { ann_cname :: ComponentName, ann_id :: id } - deriving (Show) + deriving (Show, Functor) instance Eq id => Eq (AnnotatedId id) where x == y = ann_id x == ann_id y @@ -29,6 +30,3 @@ instance Ord id => Ord (AnnotatedId id) where instance Package (AnnotatedId id) where packageId = ann_pid - -instance Functor AnnotatedId where - fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) diff --git a/Cabal/src/Distribution/Types/ComponentInclude.hs b/Cabal/src/Distribution/Types/ComponentInclude.hs index f60f696808f..97d49625529 100644 --- a/Cabal/src/Distribution/Types/ComponentInclude.hs +++ b/Cabal/src/Distribution/Types/ComponentInclude.hs @@ -19,7 +19,7 @@ data ComponentInclude id rn = ComponentInclude { -- | Did this come from an entry in @mixins@, or -- was implicitly generated by @build-depends@? ci_implicit :: Bool - } + } deriving Show ci_id :: ComponentInclude id rn -> id ci_id = ann_id . ci_ann_id diff --git a/Cabal/src/Distribution/Types/GivenComponent.hs b/Cabal/src/Distribution/Types/GivenComponent.hs index 3908ec07cc9..9e68e2f2c24 100644 --- a/Cabal/src/Distribution/Types/GivenComponent.hs +++ b/Cabal/src/Distribution/Types/GivenComponent.hs @@ -1,7 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE InstanceSigs #-} module Distribution.Types.GivenComponent ( - GivenComponent(..) + GivenComponent(..), + IsInternal(..) ) where import Distribution.Compat.Prelude @@ -21,8 +25,17 @@ data GivenComponent = { givenComponentPackage :: PackageName , givenComponentName :: LibraryName -- --dependency is for libraries -- only, not for any component - , givenComponentId :: ComponentId } + , givenComponentId :: ComponentId + , givenComponentInternal :: IsInternal } deriving (Generic, Read, Show, Eq, Typeable) +data IsInternal = + IsInternal + | IsExternal + deriving (Read, Eq, Show, Ord, Generic) + instance Binary GivenComponent instance Structured GivenComponent + +instance Binary IsInternal where +instance Structured IsInternal where diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs index bc9f6bc45d3..3d3bd36a08a 100644 --- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs +++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs @@ -109,6 +109,9 @@ data LocalBuildInfo = LocalBuildInfo { componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], -- ^ A map from component name to all matching -- components. These coincide with 'componentGraph' + promisedPkgs :: Map (PackageName, ComponentName) ComponentId, + -- ^ The packages we were promised, but aren't already installed. + -- MP: Perhaps this just needs to be a Set UnitId at this stage. installedPkgs :: InstalledPackageIndex, -- ^ All the info about the installed packages that the -- current package depends on (directly or indirectly). diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs index 7726c3eba1c..8926521673b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ComponentDeps.hs @@ -24,6 +24,7 @@ module Distribution.Solver.Types.ComponentDeps ( , insert , zip , filterDeps + , mapDeps , fromLibraryDeps , fromSetupDeps , fromInstalled @@ -149,6 +150,10 @@ zip (ComponentDeps d1) (ComponentDeps d2) = filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps +-- | Keep only selected components (and their associated deps info). +mapDeps :: (Component -> a -> b) -> ComponentDeps a -> ComponentDeps b +mapDeps p = ComponentDeps . Map.mapWithKey p . unComponentDeps + -- | ComponentDeps containing library dependencies only fromLibraryDeps :: a -> ComponentDeps a fromLibraryDeps = singleton ComponentLib diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 747d353276b..240b36d7852 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -158,6 +158,7 @@ library Distribution.Client.ProjectPlanning.Types Distribution.Client.RebuildMonad Distribution.Client.Reconfigure + Distribution.Client.ReplFlags Distribution.Client.Run Distribution.Client.Sandbox Distribution.Client.Sandbox.PackageEnvironment diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 27674300849..5813eb6b461 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -158,7 +158,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -> ElaboratedConfiguredPackage -> [FilePath] elaboratedPackage distDirLayout elaboratedSharedConfig selectedComponent elab = case elabPkgOrComp elab of - ElabPackage pkg -> + ElabPackage pkg -> --TODO: MP [ bin | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg) (pkgExeDependencies pkg) @@ -185,12 +185,12 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- here and in PlanOutput, -- use binDirectoryFor? bin_file' s = - if elabBuildStyle elab == BuildInplaceOnly + if isInplaceBuildStyle (elabBuildStyle elab) then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat flib_file' s = - if elabBuildStyle elab == BuildInplaceOnly + if isInplaceBuildStyle (elabBuildStyle elab) then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index be129b042f4..73d5122b286 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | cabal-install CLI command: repl -- @@ -10,11 +11,13 @@ module Distribution.Client.CmdRepl ( -- * The @repl@ CLI and action replCommand, replAction, + ReplFlags(..), -- * Internals exposed for testing matchesMultipleProblem, selectPackageTargets, - selectComponentTarget + selectComponentTarget, + MultiReplDecision (..), ) where import Prelude () @@ -42,7 +45,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.ProjectPlanning.Types - ( elabOrderExeDependencies ) + ( elabOrderExeDependencies, showElaboratedInstallPlan ) import Distribution.Client.ScriptUtils ( AcceptNoTargets(..), withContextAndSelectors, TargetContext(..) , updateContextAndWriteProjectFile, updateContextAndWriteProjectFile' @@ -53,21 +56,16 @@ import qualified Distribution.Client.Setup as Client import Distribution.Client.Types ( PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup - ( fromFlagOrDefault, ReplOptions(..), replOptions - , Flag(..), toFlag, falseArg ) + ( ReplOptions(..) ) import Distribution.Simple.Command - ( CommandUI(..), liftOptionL, usageAlternatives, option - , ShowOrParseArgs, OptionField, reqArg ) + ( CommandUI(..), usageAlternatives + ) import Distribution.Compiler ( CompilerFlavor(GHC) ) import Distribution.Simple.Compiler ( Compiler, compilerCompatVersion ) import Distribution.Package ( Package(..), packageName, UnitId, installedUnitId ) -import Distribution.Parsec - ( parsecCommaList ) -import Distribution.ReadE - ( ReadE, parsecToReadE ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Types.BuildInfo @@ -89,7 +87,7 @@ import Distribution.Utils.Generic import Distribution.Verbosity ( normal, lessVerbose ) import Distribution.Simple.Utils - ( wrapText, die', debugNoWrap ) + ( wrapText, die', debugNoWrap, withTempDirectoryEx, TempFileOptions (..) ) import Language.Haskell.Extension ( Language(..) ) @@ -98,40 +96,22 @@ import Data.List import qualified Data.Map as Map import qualified Data.Set as Set import System.Directory - ( doesFileExist, getCurrentDirectory ) + ( doesFileExist, getCurrentDirectory, listDirectory, makeAbsolute ) import System.FilePath - ( () ) - -data EnvFlags = EnvFlags - { envPackages :: [Dependency] - , envIncludeTransitive :: Flag Bool - } - -defaultEnvFlags :: EnvFlags -defaultEnvFlags = EnvFlags - { envPackages = [] - , envIncludeTransitive = toFlag True - } - -envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] -envOptions _ = - [ option ['b'] ["build-depends"] - "Include additional packages in the environment presented to GHCi." - envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) - (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) - , option [] ["no-transitive-deps"] - "Don't automatically include transitive dependencies of requested packages." - envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) - falseArg - ] - where - dependenciesReadE :: ReadE [Dependency] - dependenciesReadE = - parsecToReadE - ("couldn't parse dependencies: " ++) - (parsecCommaList parsec) - -replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags)) + ( (), splitSearchPath, searchPathSeparator ) +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db +import Control.Monad +import Distribution.Compat.Binary +import qualified Data.ByteString.Lazy as BS +import Distribution.Simple.Program.Types +import Distribution.Client.ReplFlags +import Distribution.Simple.Flag +import Distribution.Client.ProjectConfig + + +replCommand :: CommandUI (NixStyleFlags ReplFlags) replCommand = Client.installCommand { commandName = "v2-repl", commandSynopsis = "Open an interactive session for the given component.", @@ -168,12 +148,29 @@ replCommand = Client.installCommand { ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " ++ "to the default component (or no component if there is no project present)\n", - commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags), - commandOptions = nixStyleOptions $ \showOrParseArgs -> - map (liftOptionL _1) (replOptions showOrParseArgs) ++ - map (liftOptionL _2) (envOptions showOrParseArgs) + commandDefaultFlags = defaultNixStyleFlags defaultReplFlags, + commandOptions = nixStyleOptions topReplOptions + } +data MultiReplDecision = MultiReplDecision + { compilerVersion:: Maybe Version + , enabledByFlag :: Bool + } deriving (Eq, Show) + +useMultiRepl :: MultiReplDecision -> Bool +useMultiRepl MultiReplDecision{compilerVersion, enabledByFlag} + = compilerVersion >= Just minMultipleHomeUnitsVersion && enabledByFlag + +multiReplDecision :: ProjectConfigShared -> Compiler -> ReplFlags -> MultiReplDecision +multiReplDecision ctx compiler flags = + MultiReplDecision + -- Check if the compiler is new enough, need at least 9.4 to start a multi session + (compilerCompatVersion GHC compiler) + -- Then check the user actually asked for it, either via the project file, the global config or + -- a repl specific option. + (fromFlagOrDefault False (projectConfigMultiRepl ctx <> replUseMulti flags)) + -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- repl target and then executes the plan. @@ -185,8 +182,8 @@ replCommand = Client.installCommand { -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -replAction :: NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO () -replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags +replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO () +replAction flags@NixStyleFlags { extraFlags = r@ReplFlags{..} , ..} targetStrings globalFlags = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do when (buildSettingOnlyDeps (buildSettings ctx)) $ die' verbosity $ "The repl command does not support '--only-dependencies'. " @@ -194,6 +191,7 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt ++ "use 'repl'." let projectRoot = distProjectRootDirectory $ distDirLayout ctx + distDir = distDirectory $ distDirLayout ctx baseCtx <- case targetCtx of ProjectContext -> return ctx @@ -222,22 +220,22 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt updateContextAndWriteProjectFile ctx scriptPath scriptExecutable - (originalComponent, baseCtx') <- if null (envPackages envFlags) + (originalComponent, baseCtx') <- if null (envPackages replEnvFlags) then return (Nothing, baseCtx) else -- Unfortunately, the best way to do this is to let the normal solver -- help us resolve the targets, but that isn't ideal for performance, -- especially in the no-project case. - withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do + withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets elaboratedPlan targetSelectors + targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors let (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId oci = OriginalComponentInfo unitId originalDeps pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId - baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx + baseCtx' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx return (Just oci, baseCtx') @@ -249,26 +247,26 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt -- In addition, to avoid a *third* trip through the solver, we are -- replicating the second half of 'runProjectPreBuildPhase' by hand -- here. - (buildCtx, compiler, replOpts') <- withInstallPlan verbosity baseCtx' $ + (buildCtx, compiler, replOpts', targets) <- withInstallPlan verbosity baseCtx' $ \elaboratedPlan elaboratedShared' -> do let ProjectBaseContext{..} = baseCtx' -- Recalculate with updated project. - targets <- validatedTargets elaboratedPlan targetSelectors + targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets TargetActionRepl targets elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) + includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' elaboratedPlan' let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages pkgsBuildStatus elaboratedPlan' - debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') + debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'') let buildCtx = ProjectBuildContext @@ -281,30 +279,75 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared' - replFlags = case originalComponent of + repl_flags = case originalComponent of Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci Nothing -> [] - return (buildCtx, compiler, replOpts & lReplOptionsFlags %~ (++ replFlags)) +-- traceShowM ("**************", replFlags) + return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) + +-- traceShowM ("replOpts **************", replOpts, targetCtx) + if (Set.size (distinctTargetComponents targets) > 1) + -- TODO: make keeping temp files configurable + then withTempDirectoryEx verbosity (TempFileOptions True) distDir "multi-out-" $ \dir' -> do + -- traceShowM ("^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^", dir', distDir) + dir <- makeAbsolute dir' + replOpts'' <- case targetCtx of + ProjectContext -> return $ replOpts' { replOptionsFlagOutput = Flag dir} + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx' buildCtx' +-- traceShowM ("replOpts **************", replOpts'', targetCtx) + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' + runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes + unit_files <- listDirectory dir + let all_unit_opts = [["-unit", "@" ++ dir unit] | unit <- unit_files, unit /= "paths"] + path_files <- listDirectory (dir "paths") + ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files + let all_paths = concatMap programOverrideEnv ghcProgs +-- print (all (== (head all_paths)) all_paths) + let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) + -- HACK: Just combine together all env overrides, placing the most common things last + + (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + let ghcProg' = ghcProg { programOverrideEnv = [("PATH", Just sp)]} + runProgramInvocation verbosity $ programInvocation ghcProg' $ concat $ + ["--interactive" + , "-j", show (buildSettingNumJobs (buildSettings ctx)) + ] + :all_unit_opts + pure () + else do + replOpts'' <- case targetCtx of + ProjectContext -> return replOpts' + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx' buildCtx' +-- traceShowM ("replOpts **************", replOpts'', targetCtx) + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' + runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes + where - replOpts'' <- case targetCtx of - ProjectContext -> return replOpts' - _ -> usingGhciScript compiler projectRoot replOpts' + combine_search_paths paths = + foldl' go Map.empty paths + where + go m ("PATH", Just s) = foldl' (\m' f-> Map.insertWith (+) f 1 m') m (splitSearchPath s) + go m _ = m - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx' buildCtx' - buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' - runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes - where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - validatedTargets elaboratedPlan targetSelectors = do + validatedTargets ctx compiler elaboratedPlan targetSelectors = do + let multi_repl_enabled = multiReplDecision ctx compiler r -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). targets <- either (reportTargetProblems verbosity) return $ resolveTargets - selectPackageTargets + (selectPackageTargets multi_repl_enabled) selectComponentTarget elaboratedPlan Nothing @@ -313,12 +356,16 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt -- Reject multiple targets, or at least targets in different -- components. It is ok to have two module/file targets in the -- same component, but not two that live in different components. - when (Set.size (distinctTargetComponents targets) > 1) $ + when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $ reportTargetProblems verbosity - [multipleTargetsProblem targets] + [multipleTargetsProblem multi_repl_enabled targets] return targets +-- | First version of GHC which supports multile home packages +minMultipleHomeUnitsVersion :: Version +minMultipleHomeUnitsVersion = mkVersion [9, 4] + data OriginalComponentInfo = OriginalComponentInfo { ociUnitId :: UnitId , ociOriginalDeps :: [UnitId] @@ -378,6 +425,7 @@ usingGhciScript compiler projectRoot replOpts return $ replOpts & lReplOptionsFlags %~ (("-ghci-script" ++ ghciScriptPath) :) | otherwise = return replOpts + -- | First version of GHC where GHCi supported the flag we need. -- https://downloads.haskell.org/~ghc/7.6.1/docs/html/users_guide/release-7-6-1.html minGhciScriptVersion :: Version @@ -398,9 +446,42 @@ minGhciScriptVersion = mkVersion [7, 6] -- Fail if there are no buildable lib\/exe components, or if there are -- multiple libs or exes. -- -selectPackageTargets :: TargetSelector +selectPackageTargets :: MultiReplDecision + -> TargetSelector -> [AvailableTarget k] -> Either ReplTargetProblem [k] -selectPackageTargets targetSelector targets +selectPackageTargets multiple_targets_allowed + -- If explicit enabled, then select the targets like we would for multi-repl but + -- might still fail later because of compiler version. + = if enabledByFlag multiple_targets_allowed + then selectPackageTargetsMulti + else selectPackageTargetsSingle multiple_targets_allowed + +selectPackageTargetsMulti :: TargetSelector + -> [AvailableTarget k] -> Either ReplTargetProblem [k] +selectPackageTargetsMulti targetSelector targets + | not (null targetsBuildable) + = Right targetsBuildable + -- If there are no targets at all then we report that + | otherwise + = Left (TargetProblemNoTargets targetSelector) + where + (targetsBuildable, + _) = selectBuildableTargetsWith' + (isRequested targetSelector) targets + + -- When there's a target filter like "pkg:tests" then we do select tests, + -- but if it's just a target like "pkg" then we don't build tests unless + -- they are requested by default (i.e. by using --enable-tests) + isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False + isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False + isRequested _ _ = True + +-- | Target selection behaviour which only select a single target. +-- This is used when the compiler version doesn't support multi-repl or the user +-- didn't request it. +selectPackageTargetsSingle :: MultiReplDecision -> TargetSelector + -> [AvailableTarget k] -> Either ReplTargetProblem [k] +selectPackageTargetsSingle decision targetSelector targets -- If there is exactly one buildable library then we select that | [target] <- targetsLibsBuildable @@ -408,7 +489,7 @@ selectPackageTargets targetSelector targets -- but fail if there are multiple buildable libraries. | not (null targetsLibsBuildable) - = Left (matchesMultipleProblem targetSelector targetsLibsBuildable') + = Left (matchesMultipleProblem decision targetSelector targetsLibsBuildable') -- If there is exactly one buildable executable then we select that | [target] <- targetsExesBuildable @@ -416,7 +497,7 @@ selectPackageTargets targetSelector targets -- but fail if there are multiple buildable executables. | not (null targetsExesBuildable) - = Left (matchesMultipleProblem targetSelector targetsExesBuildable') + = Left (matchesMultipleProblem decision targetSelector targetsExesBuildable') -- If there is exactly one other target then we select that | [target] <- targetsBuildable @@ -424,7 +505,7 @@ selectPackageTargets targetSelector targets -- but fail if there are multiple such targets | not (null targetsBuildable) - = Left (matchesMultipleProblem targetSelector targetsBuildable') + = Left (matchesMultipleProblem decision targetSelector targetsBuildable') -- If there are targets but none are buildable then we report those | not (null targets) @@ -466,10 +547,10 @@ selectComponentTarget = selectComponentTargetBasic data ReplProblem - = TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] + = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()] -- | Multiple 'TargetSelector's match multiple targets - | TargetProblemMultipleTargets TargetsMap + | TargetProblemMultipleTargets MultiReplDecision TargetsMap deriving (Eq, Show) -- | The various error conditions that can occur when matching a @@ -478,16 +559,18 @@ data ReplProblem type ReplTargetProblem = TargetProblem ReplProblem matchesMultipleProblem - :: TargetSelector + :: MultiReplDecision + -> TargetSelector -> [AvailableTarget ()] -> ReplTargetProblem -matchesMultipleProblem targetSelector targetsExesBuildable = - CustomTargetProblem $ TargetProblemMatchesMultiple targetSelector targetsExesBuildable +matchesMultipleProblem decision targetSelector targetsExesBuildable = + CustomTargetProblem $ TargetProblemMatchesMultiple decision targetSelector targetsExesBuildable multipleTargetsProblem - :: TargetsMap + :: MultiReplDecision + -> TargetsMap -> ReplTargetProblem -multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets +multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a reportTargetProblems verbosity = @@ -497,7 +580,7 @@ renderReplTargetProblem :: TargetProblem ReplProblem -> String renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem renderReplProblem :: ReplProblem -> String -renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = +renderReplProblem (TargetProblemMatchesMultiple decision targetSelector targets) = "Cannot open a repl for multiple components at once. The target '" ++ showTargetSelector targetSelector ++ "' refers to " ++ renderTargetSelector targetSelector ++ " which " @@ -512,24 +595,49 @@ renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) = ] | (ckind, ts) <- sortGroupOn availableTargetComponentKind targets ] - ++ ".\n\n" ++ explanationSingleComponentLimitation + ++ ".\n\n" ++ explainMultiReplDecision decision where availableTargetComponentKind = componentKind . availableTargetComponentName -renderReplProblem (TargetProblemMultipleTargets selectorMap) = +renderReplProblem (TargetProblemMultipleTargets multi_decision selectorMap) = "Cannot open a repl for multiple components at once. The targets " ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'" | ts <- uniqueTargetSelectors selectorMap ] ++ " refer to different components." - ++ ".\n\n" ++ explanationSingleComponentLimitation - -explanationSingleComponentLimitation :: String -explanationSingleComponentLimitation = - "The reason for this limitation is that current versions of ghci do not " + ++ ".\n\n" ++ explainMultiReplDecision multi_decision + +explainMultiReplDecision :: MultiReplDecision -> [Char] +explainMultiReplDecision MultiReplDecision{compilerVersion, enabledByFlag} = + case (compilerVersion >= Just minMultipleHomeUnitsVersion, enabledByFlag) of + -- Compiler not new enough, and not requested anyway. + (False, False) -> explanationSingleComponentLimitation compilerVersion + -- Compiler too old, but was requested + (False, True) -> "Multiple component session requested but compiler version is too old.\n" ++ explanationSingleComponentLimitation compilerVersion + -- Compiler new enough, but not requested + (True, False) -> explanationNeedToEnableFlag + _ -> error "explainMultiReplDecision" + +explanationNeedToEnableFlag :: String +explanationNeedToEnableFlag = + "Your compiler supports a multiple component repl but support is not enabled.\n" ++ + "The experimental multi repl can be enabled by\n" ++ + " * Globally: Setting multi-repl: True in your .cabal/config\n" ++ + " * Project Wide: Setting multi-repl: True in your cabal.project file\n" ++ + " * Per Invocation: By passsing --enable-multi-repl when starting the repl" + + +explanationSingleComponentLimitation :: Maybe Version -> String +explanationSingleComponentLimitation version = + "The reason for this limitation is that your version " ++ versionString ++ "of ghci does not " ++ "support loading multiple components as source. Load just one component " - ++ "and when you make changes to a dependent component then quit and reload." + ++ "and when you make changes to a dependent component then quit and reload.\n" + ++ prettyShow minMultipleHomeUnitsVersion ++ " is needed to support multiple component sessions." + where + versionString = case version of + Nothing -> "" + Just ver -> "(" ++ prettyShow ver ++ ") " -- Lenses lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 023d6a6fdbc..013c43a7354 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -144,6 +144,7 @@ import Distribution.Compat.Environment ( getEnvironment ) import qualified Data.Map as M import qualified Data.ByteString as BS +import Distribution.Client.ReplFlags -- -- * Configuration saved in the config file @@ -164,6 +165,7 @@ data SavedConfig = SavedConfig , savedTestFlags :: TestFlags , savedBenchmarkFlags :: BenchmarkFlags , savedProjectFlags :: ProjectFlags + , savedReplMulti :: Flag Bool } deriving Generic instance Monoid SavedConfig where @@ -185,7 +187,8 @@ instance Semigroup SavedConfig where savedHaddockFlags = combinedSavedHaddockFlags, savedTestFlags = combinedSavedTestFlags, savedBenchmarkFlags = combinedSavedBenchmarkFlags, - savedProjectFlags = combinedSavedProjectFlags + savedProjectFlags = combinedSavedProjectFlags, + savedReplMulti = combinedSavedReplMulti } where -- This is ugly, but necessary. If we're mappending two config files, we @@ -524,6 +527,8 @@ instance Semigroup SavedConfig where combine = combine' savedBenchmarkFlags lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + combinedSavedReplMulti = combine' savedReplMulti id + combinedSavedProjectFlags = ProjectFlags { flagProjectFileName = combine flagProjectFileName , flagIgnoreProject = combine flagIgnoreProject @@ -1056,6 +1061,10 @@ configFieldDescriptions src = -- share the options or make then distinct. In any case -- they should probably be per-server. + ++ toSavedConfig liftReplFlag + [multiReplOption] + [] [] + ++ [ viewAsFieldDescr $ optionDistPref (configDistPref . savedConfigureFlags) @@ -1070,6 +1079,7 @@ configFieldDescriptions src = ParseArgs ] + where toSavedConfig lift options exclusions replacements = [ lift (fromMaybe field replacement) @@ -1167,6 +1177,10 @@ liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig liftReportFlag = liftField savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) +liftReplFlag :: FieldDescr (Flag Bool) -> FieldDescr SavedConfig +liftReplFlag = liftField + savedReplMulti (\flags conf -> conf { savedReplMulti = flags }) + parseConfig :: ConstraintSource -> SavedConfig -> BS.ByteString diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 554785ff847..9347791a857 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -51,6 +51,7 @@ import Distribution.Solver.Types.PackageIndex import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Solver.Types.SourcePackage +import Distribution.Types.GivenComponent import Distribution.Simple.Compiler ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack ) @@ -65,8 +66,6 @@ import Distribution.Simple.PackageIndex as PackageIndex ( InstalledPackageIndex, lookupPackageName ) import Distribution.Package ( Package(..), packageName, PackageId ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint(..), thisPackageVersionConstraint ) import qualified Distribution.PackageDescription as PkgDesc @@ -407,7 +406,7 @@ configurePackage verbosity platform comp scriptOptions configFlags configConstraints = [ thisPackageVersionConstraint srcid | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname uid + configDependencies = [ GivenComponent (packageName srcid) cname uid IsExternal | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index a53c7ded1aa..f4f22e69032 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -128,8 +128,6 @@ import Distribution.Package ( PackageIdentifier(..), PackageId, packageName, packageVersion , Package(..), HasMungedPackageId(..), HasUnitId(..) , UnitId ) -import Distribution.Types.GivenComponent - ( GivenComponent(..) ) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint(..), thisPackageVersionConstraint ) import Distribution.Types.MungedPackageId @@ -157,6 +155,8 @@ import Distribution.Simple.BuildPaths ( exeExtension ) import qualified Data.ByteString as BS +import Distribution.Types.GivenComponent + --TODO: -- * assign flags to packages individually -- * complain about flags that do not apply to any package given as target @@ -1189,7 +1189,7 @@ installReadyPackage platform cinfo configFlags PackageDescription.LMainLibName)) _ipid <- CD.nonSetupDeps deps ], - configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid + configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid IsExternal | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid <- CD.nonSetupDeps deps ], -- Use '--exact-configuration' if supported. diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs index 9b8fa6cba0c..f943e41d241 100644 --- a/cabal-install/src/Distribution/Client/InstallPlan.hs +++ b/cabal-install/src/Distribution/Client/InstallPlan.hs @@ -59,7 +59,10 @@ module Distribution.Client.InstallPlan ( -- * Display showPlanGraph, + ShowPlanNode(..), showInstallPlan, + showInstallPlan_gen, + showPlanPackageTag, -- * Graph-like operations dependencyClosure, @@ -278,21 +281,31 @@ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, indepGoals <- get return $! mkInstallPlan "(instance Binary)" graph indepGoals -showPlanGraph :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) - => Graph (GenericPlanPackage ipkg srcpkg) -> String + +data ShowPlanNode = ShowPlanNode { showPlanHerald :: Doc + , showPlanNeighbours :: [Doc] + } + +showPlanGraph :: [ShowPlanNode] -> String showPlanGraph graph = renderStyle defaultStyle $ - vcat (map dispPlanPackage (Foldable.toList graph)) - where dispPlanPackage p = - hang (hsep [ text (showPlanPackageTag p) - , pretty (packageId p) - , parens (pretty (nodeKey p))]) 2 - (vcat (map pretty (nodeNeighbors p))) - -showInstallPlan :: (Package ipkg, Package srcpkg, - IsUnit ipkg, IsUnit srcpkg) + vcat (map dispPlanPackage graph) + where dispPlanPackage (ShowPlanNode herald neighbours) = + hang herald 2 (vcat neighbours) + +-- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information +showInstallPlan_gen :: forall ipkg srcpkg . + (GenericPlanPackage ipkg srcpkg -> ShowPlanNode) -> GenericInstallPlan ipkg srcpkg -> String +showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . planGraph + +showInstallPlan :: forall ipkg srcpkg . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> String -showInstallPlan = showPlanGraph . planGraph +showInstallPlan = showInstallPlan_gen toShow + where + toShow :: GenericPlanPackage ipkg srcpkg -> ShowPlanNode + toShow p = ShowPlanNode (hsep [ text (showPlanPackageTag p) + , pretty (packageId p) + , parens (pretty (nodeKey p))]) + (map pretty (nodeNeighbors p)) showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String showPlanPackageTag (PreExisting _) = "PreExisting" diff --git a/cabal-install/src/Distribution/Client/ParseUtils.hs b/cabal-install/src/Distribution/Client/ParseUtils.hs index 0b8e45c5641..4694ee7e03d 100644 --- a/cabal-install/src/Distribution/Client/ParseUtils.hs +++ b/cabal-install/src/Distribution/Client/ParseUtils.hs @@ -239,7 +239,7 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = Just (FieldDescr _ _ set) -> set line value a Nothing -> do warning $ "Unrecognized field '" ++ name - ++ "' on line " ++ show line + ++ "' on line " ++ show line ++ show (Map.keys fieldMap) return a setField a (Section line name param fields) = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index fca3bef09e8..fcb0614e90a 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -223,7 +223,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = dryRunTarballPkg pkg depsBuildStatus tarball = case elabBuildStyle pkg of BuildAndInstall -> return (BuildStatusUnpack tarball) - BuildInplaceOnly -> do + BuildInplaceOnly {} -> do -- TODO: [nice to have] use a proper file monitor rather -- than this dir exists test exists <- doesDirectoryExist srcdir @@ -392,7 +392,7 @@ packageFileMonitorKeyValues elab = elabBuildTargets = [], elabTestTargets = [], elabBenchTargets = [], - elabReplTarget = Nothing, + elabReplTarget = [], elabHaddockTargets = [], elabBuildHaddocks = False, @@ -609,11 +609,14 @@ rebuildTargets verbosity (BuildFailure Nothing . DependentFailed . packageId) installPlan $ \pkg -> --TODO: review exception handling - handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do let uid = installedUnitId pkg - pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus +-- traceShowM ("### build plan") +-- traceM $ showInstallPlan installPlan +-- traceShowM ("### pkg", pkg) rebuildTarget verbosity distDirLayout @@ -720,7 +723,7 @@ rebuildTarget verbosity case elabBuildStyle pkg of BuildAndInstall -> buildAndInstall - BuildInplaceOnly -> buildInplace buildStatus + BuildInplaceOnly {} -> buildInplace buildStatus where buildStatus = BuildStatusConfigure MonitorFirstRun @@ -730,7 +733,7 @@ rebuildTarget verbosity -- rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult rebuildPhase buildStatus srcdir = - assert (elabBuildStyle pkg == BuildInplaceOnly) $ + assert (isInplaceBuildStyle $ elabBuildStyle pkg) buildInplace buildStatus srcdir builddir where @@ -864,7 +867,7 @@ withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..} -- In this case we make sure the tarball has been unpacked to the -- appropriate location under the shared dist dir, and then build it -- inplace there - BuildInplaceOnly -> do + BuildInplaceOnly {} -> do let srcrootdir = distUnpackedSrcRootDirectory srcdir = distUnpackedSrcDirectory pkgid builddir = distBuildDirectory dparams @@ -1204,7 +1207,7 @@ hasValidHaddockTargets ElaboratedConfiguredPackage{..} where components :: [ComponentTarget] components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets - ++ maybeToList elabReplTarget ++ elabHaddockTargets + ++ elabReplTarget ++ elabHaddockTargets componentHasHaddocks :: ComponentTarget -> Bool componentHasHaddocks (ComponentTarget name _) = @@ -1338,9 +1341,10 @@ buildInplaceUnpackedPackage verbosity -- Repl phase -- - whenRepl $ + whenRepl $ do + --traceM ("repl: **** " ++ show (elabReplTarget pkg, replFlags undefined, replArgs undefined)) annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs + setupInteractive replCommand replFlags replArgs -- Haddock phase whenHaddock $ @@ -1400,8 +1404,8 @@ buildInplaceUnpackedPackage verbosity | otherwise = action whenRepl action - | isNothing (elabReplTarget pkg) = return () - | otherwise = action + | null (elabReplTarget pkg) = return () + | otherwise = action whenHaddock action | hasValidHaddockTargets pkg = action diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 7ed747fa98e..d2d659e179d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -119,6 +119,7 @@ import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) import Distribution.Client.HttpUtils import System.FilePath ((), isPathSeparator, makeValid, isAbsolute, takeDirectory) import System.Directory (createDirectoryIfMissing) +import Distribution.Client.ReplFlags ( multiReplOption ) @@ -293,7 +294,8 @@ data LegacySharedConfig = LegacySharedConfig { legacyConfigureExFlags :: ConfigExFlags, legacyInstallFlags :: InstallFlags, legacyClientInstallFlags:: ClientInstallFlags, - legacyProjectFlags :: ProjectFlags + legacyProjectFlags :: ProjectFlags, + legacyMultiRepl :: Flag Bool } deriving (Show, Generic) instance Monoid LegacySharedConfig where @@ -327,7 +329,7 @@ commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlag haddockFlags testFlags benchmarkFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags - configExFlags installFlags projectFlags, + configExFlags installFlags projectFlags NoFlag, projectConfigLocalPackages = localConfig, projectConfigAllPackages = allConfig } @@ -389,7 +391,8 @@ convertLegacyGlobalConfig savedHaddockFlags = haddockFlags, savedTestFlags = testFlags, savedBenchmarkFlags = benchmarkFlags, - savedProjectFlags = projectFlags + savedProjectFlags = projectFlags, + savedReplMulti = replMulti } = mempty { projectConfigBuildOnly = configBuildOnly, @@ -412,7 +415,7 @@ convertLegacyGlobalConfig haddockFlags' testFlags' benchmarkFlags' configShared = convertLegacyAllPackageFlags globalFlags configFlags - configExFlags' installFlags' projectFlags' + configExFlags' installFlags' projectFlags' replMulti configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags' clientInstallFlags' @@ -432,7 +435,7 @@ convertLegacyProjectConfig legacyPackagesNamed, legacySharedConfig = LegacySharedConfig globalFlags configShFlags configExFlags installSharedFlags - clientInstallFlags projectFlags, + clientInstallFlags projectFlags multiRepl, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags haddockFlags testFlags benchmarkFlags, @@ -460,7 +463,7 @@ convertLegacyProjectConfig testFlags benchmarkFlags configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) - configExFlags installSharedFlags projectFlags + configExFlags installSharedFlags projectFlags multiRepl configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags installSharedFlags clientInstallFlags @@ -483,8 +486,9 @@ convertLegacyAllPackageFlags -> ConfigExFlags -> InstallFlags -> ProjectFlags + -> Flag Bool -> ProjectConfigShared -convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags = +convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags projectConfigMultiRepl = ProjectConfigShared{..} where GlobalFlags { @@ -724,6 +728,7 @@ convertToLegacySharedConfig , legacyInstallFlags = installFlags , legacyClientInstallFlags = projectConfigClientInstallFlags , legacyProjectFlags = projectFlags + , legacyMultiRepl = projectConfigMultiRepl } where globalFlags = GlobalFlags { @@ -1211,6 +1216,8 @@ legacySharedConfigFieldDescrs constraintSrc = concat . commandOptionsToFields $ projectFlagsOptions ParseArgs + , [ liftField legacyMultiRepl (\flags conf -> conf { legacyMultiRepl = flags }) (commandOptionToField multiReplOption) ] + ] diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index be3aae9bd5c..b8c35dd8c0d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -204,7 +204,9 @@ data ProjectConfigShared projectConfigIndependentGoals :: Flag IndependentGoals, projectConfigPreferOldest :: Flag PreferOldest, - projectConfigProgPathExtra :: NubList FilePath + projectConfigProgPathExtra :: NubList FilePath, + + projectConfigMultiRepl :: Flag Bool -- More things that only make sense for manual mode, not --local mode -- too much control! diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index da67b8a3ef4..0282f58456a 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -904,6 +904,9 @@ printPlan verbosity , if verbosity >= deafening then prettyShow (installedUnitId elab) else prettyShow (packageId elab) + , case elabBuildStyle elab of + BuildInplaceOnly InMemory -> "(MEM)" + _ -> "" , case elabPkgOrComp elab of ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg)) ElabComponent comp -> @@ -1049,7 +1052,7 @@ writeBuildReports settings buildContext plan buildOutcomes = do TestsNotTried -> BuildReports.NotTried TestsOk -> BuildReports.Ok - in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map packageId $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? + in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? fromPlanPackage _ _ = Nothing buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index fde7ea8b97a..16c42dad431 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -152,7 +152,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = [ "pkg-src-sha256" J..= J.String (showHashValue hash) | Just hash <- [elabPkgSourceHash elab] ] ++ (case elabBuildStyle elab of - BuildInplaceOnly -> + BuildInplaceOnly {} -> ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation] BuildAndInstall -> -- TODO: install dirs? @@ -162,7 +162,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = ElabPackage pkg -> let components = J.object $ [ comp2str c J..= (J.object $ - [ "depends" J..= map (jdisplay . confInstId) ldeps + [ "depends" J..= map (jdisplay . confInstId) (map fst ldeps) , "exe-depends" J..= map (jdisplay . confInstId) edeps ] ++ bin_file c) @@ -172,7 +172,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = (pkgExeDependencies pkg) ] in ["components" J..= components] ElabComponent comp -> - ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab) + ["depends" J..= map (jdisplay . confInstId) (map fst $ elabLibDependencies elab) ,"exe-depends" J..= map jdisplay (elabExeDependencies elab) ,"component-name" J..= J.String (comp2str (compSolverName comp)) ] ++ @@ -256,7 +256,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = bin_file' s = ["bin-file" J..= J.String bin] where - bin = if elabBuildStyle elab == BuildInplaceOnly + bin = if isInplaceBuildStyle (elabBuildStyle elab) then dist_dir "build" prettyShow s prettyShow s <.> exeExtension plat else InstallDirs.bindir (elabInstallDirs elab) prettyShow s <.> exeExtension plat @@ -264,7 +264,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = flib_file' s = ["bin-file" J..= J.String bin] where - bin = if elabBuildStyle elab == BuildInplaceOnly + bin = if isInplaceBuildStyle (elabBuildStyle elab) then dist_dir "build" prettyShow s ("lib" ++ prettyShow s) <.> dllExtension plat else InstallDirs.bindir (elabInstallDirs elab) ("lib" ++ prettyShow s) <.> dllExtension plat @@ -274,7 +274,8 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = style2str :: Bool -> BuildStyle -> String style2str _ BuildAndInstall = "global" style2str True _ = "local" - style2str False BuildInplaceOnly = "inplace" + style2str False (BuildInplaceOnly OnDisk) = "inplace" + style2str False (BuildInplaceOnly InMemory) = "memory" jdisplay :: Pretty a => a -> J.Value jdisplay = J.String . prettyShow @@ -601,7 +602,7 @@ postBuildProjectStatus plan previousPackagesUpToDate ] elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId] - elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies + elabLibDeps = map (newSimpleUnitId . confInstId) . map fst . elabLibDependencies -- Was a build was attempted for this package? -- If it doesn't have both a build status and outcome then the answer is no. @@ -640,8 +641,8 @@ postBuildProjectStatus plan previousPackagesUpToDate case pkg of InstallPlan.PreExisting _ -> False InstallPlan.Installed _ -> False - InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg - == BuildInplaceOnly + InstallPlan.Configured srcpkg -> isInplaceBuildStyle (elabBuildStyle srcpkg) + packagesAlreadyInStore :: Set UnitId packagesAlreadyInStore = selectPlanPackageIdSet $ \pkg -> @@ -947,7 +948,7 @@ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan = inplacePackages = [ srcpkg | srcpkg <- sourcePackages - , elabBuildStyle srcpkg == BuildInplaceOnly ] + , isInplaceBuildStyle (elabBuildStyle srcpkg) ] sourcePackages :: [ElaboratedConfiguredPackage] sourcePackages = diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index 4ec141037b7..79b0f7587b1 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -124,8 +124,9 @@ import Distribution.Types.ComponentName import Distribution.Types.DumpBuildInfo ( DumpBuildInfo (..) ) import Distribution.Types.LibraryName -import Distribution.Types.GivenComponent - (GivenComponent(..)) +import Distribution.Types.GivenComponent + ( GivenComponent(GivenComponent), + IsInternal(IsExternal, IsInternal) ) import Distribution.Types.PackageVersionConstraint import Distribution.Types.PkgconfigDependency import Distribution.Types.UnqualComponentName @@ -177,6 +178,7 @@ import Control.Exception (assert) import Data.List (groupBy, deleteBy) import qualified Data.List.NonEmpty as NE import System.FilePath +import GHC.Stack ------------------------------------------------------------------------------ -- * Elaborated install plan @@ -245,7 +247,7 @@ sanityCheckElaboratedConfiguredPackage sharedConfig -- 'installedPackageId' we assigned is consistent with -- the 'hashedInstalledPackageId' we would compute from -- the elaborated configured package - . assert (elabBuildStyle == BuildInplaceOnly || + . assert ((isInplaceBuildStyle elabBuildStyle) || elabComponentId == hashedInstalledPackageId (packageHashInputs sharedConfig elab)) @@ -256,7 +258,7 @@ sanityCheckElaboratedConfiguredPackage sharedConfig -- 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 (elabBuildStyle == BuildInplaceOnly || + . assert (isInplaceBuildStyle elabBuildStyle || optStanzaSetNull elabStanzasAvailable) sanityCheckElaboratedComponent @@ -268,7 +270,7 @@ sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..} ElaboratedComponent{..} = -- Should not be building bench or test if not inplace. - assert (elabBuildStyle == BuildInplaceOnly || + assert (isInplaceBuildStyle elabBuildStyle || case compComponentName of Nothing -> True Just (CLibName _) -> True @@ -709,7 +711,7 @@ rebuildInstallPlan verbosity installDirs elaboratedShared elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) + liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan instantiatedPlan) return (instantiatedPlan, elaboratedShared) where withRepoCtx = projectConfigWithSolverRepoContext verbosity @@ -751,7 +753,7 @@ rebuildInstallPlan verbosity let improvedPlan = improveInstallPlanWithInstalledPackages storePkgIdSet elaboratedPlan - liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan) + liftIO $ debugNoWrap verbosity (showElaboratedInstallPlan improvedPlan) -- TODO: [nice to have] having checked which packages from the store -- we're using, it may be sensible to sanity check those packages -- by loading up the compiler package db and checking everything @@ -1529,7 +1531,8 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB compComponentName = Nothing dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0 compLibDependencies - = map configuredId dep_pkgs + -- MP: No idea what this function does + = map (\cid -> (configuredId cid, False)) dep_pkgs compLinkedLibDependencies = notImpl "compLinkedLibDependencies" compOrderLibDependencies = notImpl "compOrderLibDependencies" -- Not supported: @@ -1564,11 +1567,13 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB (Map.unionWith Map.union external_exe_cc_map cc_map) comp - + let do_ cid = + let cid' = (annotatedIdToConfiguredId . ci_ann_id $ cid) + in (cid', False) -- filled in later) -- 2. Read out the dependencies from the ConfiguredComponent cc0 let compLibDependencies = -- Nub because includes can show up multiple times - ordNub (map (annotatedIdToConfiguredId . ci_ann_id) + ordNub (map (\cid -> do_ cid ) (cc_includes cc0)) compExeDependencies = map annotatedIdToConfiguredId @@ -1587,7 +1592,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB elabPkgOrComp = ElabComponent $ elab_comp } cid = case elabBuildStyle elab0 of - BuildInplaceOnly -> + BuildInplaceOnly {} -> mkComponentId $ prettyShow pkgid ++ "-inplace" ++ (case Cabal.componentNameString cname of @@ -1606,7 +1611,9 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of Just full -> full Nothing -> error ("lookup_uid: " ++ prettyShow def_uid) - lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0) + -- MP: Think False here is correct? It dictates whether we have any promised + -- packages on the go or not. + lc <- toLinkedComponent verbosity False lookup_uid (elabPkgSourceId elab0) (Map.union external_lc_map lc_map) cc infoProgress $ dispLinkedComponent lc -- NB: elab is setup to be the correct form for an @@ -1787,7 +1794,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB filterExt' = filter (isExt . fst) pkgLibDependencies - = buildComponentDeps (filterExt . compLibDependencies) + = buildComponentDeps (filterExt' . compLibDependencies) pkgExeDependencies = buildComponentDeps (filterExt . compExeDependencies) pkgExeDependencyPaths @@ -1883,7 +1890,7 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB elabBuildTargets = [] elabTestTargets = [] elabBenchTargets = [] - elabReplTarget = Nothing + elabReplTarget = [] elabHaddockTargets = [] elabBuildHaddocks = @@ -1892,8 +1899,12 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB elabPkgSourceLocation = srcloc elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes elabLocalToProject = isLocalToProject pkg + -- MP: HERE, this is an overapproximation currently (all local packages are intenral) but we need + -- to check the requested targets. + -- This is overwritten later in CmdRepl + --elabIsInternalPackage = IsExternal elabBuildStyle = if shouldBuildInplaceOnly pkg - then BuildInplaceOnly else BuildAndInstall + then BuildInplaceOnly OnDisk else BuildAndInstall elabPackageDbs = projectConfigPackageDBs sharedPackageConfig elabBuildPackageDBStack = buildAndRegisterDbs elabRegisterPackageDBStack = buildAndRegisterDbs @@ -2244,7 +2255,7 @@ binDirectories layout config package = case elabBuildStyle package of -- to put any executables in it, that will just clog up the PATH _ | noExecutables -> [] BuildAndInstall -> [installedBinDirectory package] - BuildInplaceOnly -> map (root) $ case elabPkgOrComp package of + BuildInplaceOnly {} -> map (root) $ case elabPkgOrComp package of ElabComponent comp -> case compSolverName comp of CD.ComponentExe n -> [prettyShow n] _ -> [] @@ -2469,9 +2480,9 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = | otherwise = error ("indefiniteComponent: " ++ prettyShow cid) fixupBuildStyle BuildAndInstall elab = elab - fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab - fixupBuildStyle BuildInplaceOnly elab = elab { - elabBuildStyle = BuildInplaceOnly, + fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly {} }) = elab + fixupBuildStyle t@(BuildInplaceOnly {}) elab = elab { + elabBuildStyle = t, elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab, elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab, elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab @@ -2757,7 +2768,7 @@ nubComponentTargets = pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool pkgHasEphemeralBuildTargets elab = - isJust (elabReplTarget elab) + (not . null) (elabReplTarget elab) || (not . null) (elabTestTargets elab) || (not . null) (elabBenchTargets elab) || (not . null) (elabHaddockTargets elab) @@ -2861,13 +2872,12 @@ setRootTargets targetAction perPkgTargetsMap = (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } - (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt - , elabBuildHaddocks = False } + (Just tgts, TargetActionRepl) -> elab { elabReplTarget = tgts + , elabBuildHaddocks = False + , elabBuildStyle = BuildInplaceOnly InMemory } (Just tgts, TargetActionHaddock) -> foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts , elabBuildHaddocks = True }) tgts - (Just _, TargetActionRepl) -> - error "pruneInstallPlanToTargets: multiple repl targets" setElabHaddockTargets tgt elab | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } @@ -2877,6 +2887,9 @@ setRootTargets targetAction perPkgTargetsMap = | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } | otherwise = elab +minVersionReplFlagFile :: Version +minVersionReplFlagFile = mkVersion [3,9] + -- | Assuming we have previously set the root build targets (i.e. the user -- targets but not rev deps yet), the first pruning pass does two things: -- @@ -2888,10 +2901,67 @@ setRootTargets targetAction perPkgTargetsMap = -- pruneInstallPlanPass1 :: [ElaboratedPlanPackage] -> [ElaboratedPlanPackage] -pruneInstallPlanPass1 pkgs = - map (mapConfiguredPackage fromPrunedPackage) - (fromMaybe [] $ Graph.closure graph roots) +pruneInstallPlanPass1 pkgs = final_final_graph where + -- Make a closed graph by calculating the closure from the roots + closed_graph = Graph.fromDistinctList (map (mapConfiguredPackage fromPrunedPackage) (fromMaybe [] $ Graph.closure graph roots)) + + -- Anything which is inplace and left after pruning could be a repl target, then just need to check the + -- reverse closure after calculating roots to capture dependencies which are on the path between roots. + -- In order to start a multi-repl session with all the desired targets we need to load all these components into + -- the repl at once to satisfy the closure property. + all_desired_repl_targets = [cp | InstallPlan.Configured cp <- fromMaybe [] $ Graph.revClosure closed_graph roots] + + add_repl_target :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + add_repl_target ecp | ecp `elem` all_desired_repl_targets = ecp { elabReplTarget = maybeToList (ComponentTarget <$> (elabComponentName ecp) <*> pure WholeComponent) + , elabBuildStyle = BuildInplaceOnly InMemory } + | otherwise = ecp + + -- Add the repl target information to the ElaboratedPlanPackages + graph_with_repl_targets + = map (mapConfiguredPackage add_repl_target) (Graph.toList closed_graph) + + -- But check that all the InMemory targets have a new enough version of Cabal, + -- otherwise we will confuse Setup.hs by passing new arguments which it doesn't understand + -- later down the line. We try to remove just these edges, if it doesn't break the overall structure + -- then we just report to the user that their target will not be loaded for this reason. + + (bad -- Nodes which we wanted to build InMemory but lack new enough version of Cabal + , _good -- Nodes we want to build in memory. + ) = partitionEithers (map go graph_with_repl_targets) + where + go :: ElaboratedPlanPackage -> Either UnitId ElaboratedPlanPackage + go (InstallPlan.Configured cp) + | BuildInplaceOnly InMemory <- elabBuildStyle cp + , elabSetupScriptCliVersion cp < minVersionReplFlagFile = Left (elabUnitId cp) + go (InstallPlan.Configured c) = Right (InstallPlan.Configured c) + go c = Right c + + -- Now take the upwards closure from the bad nodes, and find the other `BuildInplaceOnly InMemory` packages that clobbers, + -- disables those and issue a warning to the user. Because we aren't going to be able to load those into memory as well + -- because the thing it depends on is not going to be in memory. + + disabled_repl_targets = + [ c | InstallPlan.Configured c <- fromMaybe [] $ Graph.revClosure (Graph.fromDistinctList graph_with_repl_targets) bad + , BuildInplaceOnly InMemory <- [elabBuildStyle c] ] + + remove_repl_target :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + remove_repl_target ecp | ecp `elem` disabled_repl_targets = ecp { elabReplTarget = [] + , elabBuildStyle = BuildInplaceOnly OnDisk } + | otherwise = ecp + + final_graph_with_repl_targets = {- traceShow (map elabUnitId disabled_repl_targets) $ -} map (mapConfiguredPackage remove_repl_target) graph_with_repl_targets + + -- Now find what the new roots are after we have disabled things which we can't build (and the things above that) + new_roots = {- traceShowId -} (mapMaybe find_root (map (mapConfiguredPackage prune) final_graph_with_repl_targets)) + + -- Then take the final closure from these new roots to remove these things + -- TODO: Can probably just remove them directly in remove_repl_target. + final_final_graph = fromMaybe [] $ Graph.closure (Graph.fromDistinctList final_graph_with_repl_targets) new_roots + + + + pkgs' = map (mapConfiguredPackage prune) pkgs graph = Graph.fromDistinctList pkgs' roots = mapMaybe find_root pkgs' @@ -2907,7 +2977,7 @@ pruneInstallPlanPass1 pkgs = , null (elabBuildTargets elab) , null (elabTestTargets elab) , null (elabBenchTargets elab) - , isNothing (elabReplTarget elab) + , null (elabReplTarget elab) , null (elabHaddockTargets elab) ] then Just (installedUnitId elab) @@ -3005,7 +3075,7 @@ pruneInstallPlanPass1 pkgs = | ComponentTarget cname _ <- elabBuildTargets pkg ++ elabTestTargets pkg ++ elabBenchTargets pkg - ++ maybeToList (elabReplTarget pkg) + ++ elabReplTarget pkg ++ elabHaddockTargets pkg , stanza <- maybeToList $ componentOptionalStanza $ @@ -3077,6 +3147,7 @@ pruneInstallPlanPass2 pkgs = map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs where setStanzasDepsAndTargets elab = + elab { elabBuildTargets = ordNub $ elabBuildTargets elab @@ -3090,18 +3161,25 @@ pruneInstallPlanPass2 pkgs = keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas keepNeeded _ _ = True + in ElabPackage $ pkg { pkgStanzasEnabled = stanzas, - pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg), + pkgLibDependencies = CD.mapDeps (\_ -> map addInternal) $ CD.filterDeps keepNeeded (pkgLibDependencies pkg), pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg), pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg) } - r@(ElabComponent _) -> r + (ElabComponent comp) -> + ElabComponent $ comp { compLibDependencies = map addInternal (compLibDependencies comp) } } where + addInternal (cid, _) = (cid, (cid `Set.member` inMemoryTargets)) + libTargetsRequiredForRevDeps = - [ ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent + [ c | installedUnitId elab `Set.member` hasReverseLibDeps + , let c = ComponentTarget (CLibName Cabal.defaultLibName) WholeComponent + -- Don't enable building for anything which s + , elabBuildStyle elab /= BuildInplaceOnly InMemory ] exeTargetsRequiredForRevDeps = -- TODO: allow requesting executable with different name @@ -3117,6 +3195,13 @@ pruneInstallPlanPass2 pkgs = availablePkgs :: Set UnitId availablePkgs = Set.fromList (map installedUnitId pkgs) + inMemoryTargets :: Set ConfiguredId + inMemoryTargets = do + Set.fromList [ configuredId pkg + | InstallPlan.Configured pkg <- pkgs + , BuildInplaceOnly InMemory <- [elabBuildStyle pkg] ] + + hasReverseLibDeps :: Set UnitId hasReverseLibDeps = Set.fromList [ depid @@ -3417,7 +3502,7 @@ setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..}) usePackageDB = elabSetupPackageDBStack, usePackageIndex = Nothing, useDependencies = [ (uid, srcid) - | ConfiguredId srcid (Just (CLibName LMainLibName)) uid + | (ConfiguredId srcid (Just (CLibName LMainLibName)) uid, _) <- elabSetupDependencies elab ], useDependenciesExclusive = True, useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps, @@ -3493,7 +3578,7 @@ computeInstallDirs :: StoreDirLayout -> ElaboratedConfiguredPackage -> InstallDirs.InstallDirs FilePath computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab - | elabBuildStyle elab == BuildInplaceOnly + | isInplaceBuildStyle (elabBuildStyle elab) -- use the ordinary default install dirs = (InstallDirs.absoluteInstallDirs (elabPkgSourceId elab) @@ -3617,11 +3702,13 @@ setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) -- 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) + -- MP: This is the important place configDependencies = [ GivenComponent (packageName srcid) ln cid - | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab + (if is_internal then IsInternal else IsExternal) + | (ConfiguredId srcid mb_cn cid, is_internal) <- elabLibDependencies elab , let ln = case mb_cn of Just (CLibName lname) -> lname Just _ -> error "non-library dependency" @@ -3631,7 +3718,7 @@ setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..}) case elabPkgOrComp of ElabPackage _ -> [ thisPackageVersionConstraint srcid - | ConfiguredId srcid _ _uid <- elabLibDependencies elab ] + | (ConfiguredId srcid _ _uid, _) <- elabLibDependencies elab ] ElabComponent _ -> [] @@ -3749,8 +3836,8 @@ setupHsReplFlags _ sharedConfig verbosity builddir = setupHsReplArgs :: ElaboratedConfiguredPackage -> [String] setupHsReplArgs elab = - maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab) - --TODO: should be able to give multiple modules in one component + map (\t -> showComponentTarget (packageId elab) t) (elabReplTarget elab) + --TODO: should be able to give multiple modules in one component wz1000 setupHsCopyFlags :: ElaboratedConfiguredPackage @@ -3781,8 +3868,8 @@ setupHsRegisterFlags ElaboratedConfiguredPackage{..} _ regGenScript = mempty, -- never use regGenPkgConf = toFlag (Just pkgConfFile), regInPlace = case elabBuildStyle of - BuildInplaceOnly -> toFlag True - _ -> toFlag False, + BuildInplaceOnly {} -> toFlag True + BuildAndInstall -> toFlag False, regPrintId = mempty, -- never use regDistPref = toFlag builddir, regArgs = [], @@ -3885,7 +3972,7 @@ setupHsTestFlags _ _ verbosity builddir = -- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but -- not replace installed packages with ghc-pkg. -packageHashInputs :: ElaboratedSharedConfig +packageHashInputs :: HasCallStack => ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> PackageHashInputs packageHashInputs @@ -3906,11 +3993,11 @@ packageHashInputs ElabPackage (ElaboratedPackage{..}) -> Set.fromList $ [ confInstId dep - | dep <- CD.select relevantDeps pkgLibDependencies ] ++ + | (dep, _) <- CD.select relevantDeps pkgLibDependencies ] ++ [ confInstId dep | dep <- CD.select relevantDeps pkgExeDependencies ] ElabComponent comp -> - Set.fromList (map confInstId (compLibDependencies comp + Set.fromList (map confInstId ((map fst $ compLibDependencies comp) ++ compExeDependencies comp)), pkgHashOtherConfig = packageHashConfigInputs pkgshared elab } @@ -4023,7 +4110,7 @@ binDirectoryFor -> FilePath binDirectoryFor layout config package exe = case elabBuildStyle package of BuildAndInstall -> installedBinDirectory package - BuildInplaceOnly -> inplaceBinRoot layout config package exe + BuildInplaceOnly {} -> inplaceBinRoot layout config package exe -- package has been built and installed. installedBinDirectory :: ElaboratedConfiguredPackage -> FilePath diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index bda338897e4..3fd12888e71 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} @@ -14,6 +16,7 @@ module Distribution.Client.ProjectPlanning.Types ( ElaboratedInstallPlan, normaliseConfiguredPackage, ElaboratedConfiguredPackage(..), + showElaboratedInstallPlan, elabDistDirParams, elabExeDependencyPaths, @@ -39,6 +42,8 @@ module Distribution.Client.ProjectPlanning.Types ( ElaboratedSharedConfig(..), ElaboratedReadyPackage, BuildStyle(..), + MemoryOrDisk(..), + isInplaceBuildStyle, CabalFileText, -- * Build targets @@ -109,6 +114,7 @@ import qualified Data.Map as Map import qualified Data.ByteString.Lazy as LBS import qualified Data.Monoid as Mon import System.FilePath (()) +import Text.PrettyPrint hiding ((<>)) -- | The combination of an elaborated install plan plus a @@ -136,6 +142,30 @@ elabPlanPackageName verbosity (Configured elab) elabPlanPackageName verbosity (Installed elab) = elabConfiguredName verbosity elab +showElaboratedInstallPlan :: ElaboratedInstallPlan -> String +showElaboratedInstallPlan = InstallPlan.showInstallPlan_gen showNode + where + showNode pkg = InstallPlan.ShowPlanNode { InstallPlan.showPlanHerald = herald + , InstallPlan.showPlanNeighbours = deps } + where + herald = (hsep [ text (InstallPlan.showPlanPackageTag pkg) + , InstallPlan.foldPlanPackage (const mempty) in_mem pkg + , pretty (packageId pkg) + , parens (pretty (nodeKey pkg))]) + + in_mem elab = case elabBuildStyle elab of + BuildInplaceOnly InMemory -> parens (text "In Memory") + _ -> mempty + + deps = InstallPlan.foldPlanPackage installed_deps local_deps pkg + + installed_deps = map pretty . nodeNeighbors + + local_deps cfg = [ (if internal then text "+" else mempty) <> pretty (confInstId uid) | (uid, internal) <- elabLibDependencies cfg ] + + + + --TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things -- like a server + client with ghc + ghcjs @@ -202,6 +232,8 @@ data ElaboratedConfiguredPackage -- in) elabLocalToProject :: Bool, + -- elabIsInternalPackage :: IsInternal, + -- | 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, @@ -326,7 +358,7 @@ data ElaboratedConfiguredPackage elabBuildTargets :: [ComponentTarget], elabTestTargets :: [ComponentTarget], elabBenchTargets :: [ComponentTarget], - elabReplTarget :: Maybe ComponentTarget, + elabReplTarget :: [ComponentTarget], elabHaddockTargets :: [ComponentTarget], elabBuildHaddocks :: Bool, @@ -441,7 +473,7 @@ dataDirEnvVarForPackage :: DistDirLayout dataDirEnvVarForPackage distDirLayout pkg = case elabBuildStyle pkg of BuildAndInstall -> Nothing - BuildInplaceOnly -> Just + BuildInplaceOnly {} -> Just ( pkgPathEnvVar (elabPkgDescription pkg) "datadir" , Just $ srcPath (elabPkgSourceLocation pkg) dataDir (elabPkgDescription pkg)) @@ -540,13 +572,13 @@ elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId] elabOrderLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> map (newSimpleUnitId . confInstId) $ - ordNub $ CD.flatDeps (pkgLibDependencies pkg) + ordNub $ CD.flatDeps (map fst <$> pkgLibDependencies pkg) ElabComponent comp -> compOrderLibDependencies comp -- | The library dependencies (i.e., the libraries we depend on, NOT -- the dependencies of the library), NOT including setup dependencies. -- These are passed to the @Setup@ script via @--dependency@. -elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabLibDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] elabLibDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg)) @@ -580,7 +612,7 @@ elabExeDependencyPaths elab = -- | The setup dependencies (the library dependencies of the setup executable; -- note that it is not legal for setup scripts to have executable -- dependencies at the moment.) -elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId] +elabSetupDependencies :: ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)] elabSetupDependencies elab = case elabPkgOrComp elab of ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg) @@ -624,7 +656,7 @@ elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab = go =<< InstallPlan.directDeps plan (nodeKey root_elab) where go = InstallPlan.foldPlanPackage (const []) $ \elab -> do - guard (elabBuildStyle elab == BuildInplaceOnly) + guard (isInplaceBuildStyle (elabBuildStyle elab)) return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build" -- | Some extra metadata associated with an @@ -643,7 +675,7 @@ data ElaboratedComponent compComponentName :: Maybe ComponentName, -- | The *external* library dependencies of this component. We -- pass this to the configure script. - compLibDependencies :: [ConfiguredId], + compLibDependencies :: [(ConfiguredId, Bool)], -- | In a component prior to instantiation, this list specifies -- the 'OpenUnitId's which, after instantiation, are the -- actual dependencies of this package. Note that this does @@ -691,7 +723,7 @@ data ElaboratedPackage -- | The exact dependencies (on other plan packages) -- - pkgLibDependencies :: ComponentDeps [ConfiguredId], + pkgLibDependencies :: ComponentDeps [(ConfiguredId, Bool)], -- | Components which depend (transitively) on an internally -- defined library. These are used by 'elabRequiresRegistration', @@ -726,9 +758,9 @@ instance Structured ElaboratedPackage -- | See 'elabOrderDependencies'. This gives the unflattened version, -- which can be useful in some circumstances. -pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId] +pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [(UnitId)] pkgOrderDependencies pkg = - fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend` + fmap (map (newSimpleUnitId . confInstId)) (map fst <$> pkgLibDependencies pkg) `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg) -- | This is used in the install plan to indicate how the package will be @@ -750,18 +782,39 @@ data BuildStyle = -- Typically 'BuildAndInstall' packages will only depend on other -- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones. -- - | BuildInplaceOnly + | BuildInplaceOnly MemoryOrDisk + -- | Built in-memory only using GHC multi-repl, they are not built or installed + -- anywhere on disk. BuildInMemory packages can't be depended on by BuildAndInstall nor BuildInplaceOnly packages + -- (because they don't exist on disk) but can depend on other BuildStyles. + + -- At the moment BuildInMemory is only used by the 'repl' command. +-- | BuildInMemory deriving (Eq, Show, Generic) -instance Binary BuildStyle -instance Structured BuildStyle +data MemoryOrDisk = InMemory | OnDisk deriving (Eq, Show, Generic) + +isInplaceBuildStyle :: BuildStyle -> Bool +isInplaceBuildStyle (BuildInplaceOnly {}) = True +isInplaceBuildStyle BuildAndInstall = False + +instance Binary MemoryOrDisk +instance Structured MemoryOrDisk + +instance Semigroup MemoryOrDisk where + InMemory <> x = x + OnDisk <> _ = OnDisk instance Semigroup BuildStyle where - BuildInplaceOnly <> _ = BuildInplaceOnly - _ <> BuildInplaceOnly = BuildInplaceOnly - _ <> _ = BuildAndInstall + (BuildInplaceOnly a) <> (BuildInplaceOnly b) = BuildInplaceOnly (a <> b) + (BuildInplaceOnly a) <> _ = BuildInplaceOnly a + BuildAndInstall <> _ = BuildAndInstall + instance Monoid BuildStyle where - mempty = BuildAndInstall - mappend = (<>) + mempty = BuildAndInstall + mappend = (<>) + + +instance Binary BuildStyle +instance Structured BuildStyle type CabalFileText = LBS.ByteString diff --git a/cabal-install/src/Distribution/Client/ReplFlags.hs b/cabal-install/src/Distribution/Client/ReplFlags.hs new file mode 100644 index 00000000000..6bfa45c9cbf --- /dev/null +++ b/cabal-install/src/Distribution/Client/ReplFlags.hs @@ -0,0 +1,89 @@ +module Distribution.Client.ReplFlags (EnvFlags(..), ReplFlags(..), topReplOptions, multiReplOption, defaultReplFlags) where + +import Prelude () +import Distribution.Client.Compat.Prelude + + +import Distribution.Client.Setup + ( liftOptions ) +import Distribution.Simple.Setup + ( ReplOptions(..), replOptions + , Flag(..), toFlag, falseArg, boolOpt ) +import Distribution.Simple.Command + ( option + , ShowOrParseArgs, OptionField, reqArg, liftOption ) +import Distribution.Parsec + ( parsecCommaList ) +import Distribution.ReadE + ( ReadE, parsecToReadE ) +import Distribution.Types.Dependency + ( Dependency(..) ) + +data EnvFlags = EnvFlags + { envPackages :: [Dependency] + , envIncludeTransitive :: Flag Bool + } + +instance Semigroup EnvFlags where + (EnvFlags a1 a2) <> (EnvFlags b1 b2) = EnvFlags (a1 <> b1) (a2 <> b2) + +instance Monoid EnvFlags where + mempty = defaultEnvFlags + +defaultEnvFlags :: EnvFlags +defaultEnvFlags = EnvFlags + { envPackages = [] + , envIncludeTransitive = toFlag True + } + +data ReplFlags = ReplFlags { + configureReplOptions :: ReplOptions + , replEnvFlags :: EnvFlags + , replUseMulti :: Flag Bool + } + +instance Semigroup ReplFlags where + (ReplFlags a1 a2 a3) <> (ReplFlags b1 b2 b3) = ReplFlags (a1 <> b1) (a2 <> b2) (a3 <> b3) + +instance Monoid ReplFlags where + mempty = defaultReplFlags + +defaultReplFlags :: ReplFlags +defaultReplFlags = ReplFlags { configureReplOptions = mempty + , replEnvFlags = defaultEnvFlags + , replUseMulti = NoFlag } + +topReplOptions :: ShowOrParseArgs -> [OptionField ReplFlags] +topReplOptions showOrParseArgs = + liftOptions configureReplOptions set1 (replOptions showOrParseArgs) ++ + liftOptions replEnvFlags set2 (envOptions showOrParseArgs) ++ + [liftOption replUseMulti set3 multiReplOption] + where + set1 a x = x { configureReplOptions = a } + set2 a x = x { replEnvFlags = a } + set3 a x = x { replUseMulti = a } + +multiReplOption :: OptionField (Flag Bool) +multiReplOption = + option [] ["multi-repl"] + "multi-component repl sessions" + id (\v _ -> v) + (boolOpt [] []) + +envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] +envOptions _ = + [ option ['b'] ["build-depends"] + "Include additional packages in the environment presented to GHCi." + envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) + (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String])) + , option [] ["no-transitive-deps"] + "Don't automatically include transitive dependencies of requested packages." + envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) + falseArg + ] + where + dependenciesReadE :: ReadE [Dependency] + dependenciesReadE = + parsecToReadE + ("couldn't parse dependencies: " ++) + (parsecCommaList parsec) diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 6db91d9cf98..a961db2d63c 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -509,13 +509,13 @@ filterConfigureFlags flags cabalLibVersion -- (public sublibraries), so we convert it to the legacy -- --dependency=pkg_or_internal_component=cid configDependencies = - let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = + let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid int) = Just $ GivenComponent (unqualComponentNameToPackageName cn) LMainLibName - cid - convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) = - Just $ GivenComponent pn LMainLibName cid + cid int + convertToLegacyInternalDep (GivenComponent pn LMainLibName cid int) = + Just $ GivenComponent pn LMainLibName cid int in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'. , configAllowDependingOnPrivateLibs = NoFlag diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 6b81643fe0b..a8590841dc1 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -760,9 +760,9 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "multiple-libs" assertProjectTargetProblems "targets/multiple-libs" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget - [ ( flip CmdRepl.matchesMultipleProblem + [ ( flip (CmdRepl.matchesMultipleProblem (CmdRepl.MultiReplDecision Nothing False)) [ AvailableTarget "p-0.1" (CLibName LMainLibName) (TargetBuildable () TargetRequestedByDefault) True , AvailableTarget "q-0.1" (CLibName LMainLibName) @@ -774,9 +774,9 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "multiple-exes" assertProjectTargetProblems "targets/multiple-exes" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget - [ ( flip CmdRepl.matchesMultipleProblem + [ ( flip (CmdRepl.matchesMultipleProblem (CmdRepl.MultiReplDecision Nothing False)) [ AvailableTarget "p-0.1" (CExeName "p2") (TargetBuildable () TargetRequestedByDefault) True , AvailableTarget "p-0.1" (CExeName "p1") @@ -788,9 +788,9 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "multiple-tests" assertProjectTargetProblems "targets/multiple-tests" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget - [ ( flip CmdRepl.matchesMultipleProblem + [ ( flip (CmdRepl.matchesMultipleProblem (CmdRepl.MultiReplDecision Nothing False)) [ AvailableTarget "p-0.1" (CTestName "p2") (TargetBuildable () TargetNotRequestedByDefault) True , AvailableTarget "p-0.1" (CTestName "p1") @@ -803,7 +803,7 @@ testTargetProblemsRepl config reportSubCase = do do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config assertProjectDistinctTargets elaboratedPlan - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ mkTargetComponent "p-0.1" (CExeName "p1") , mkTargetComponent "p-0.1" (CExeName "p2") @@ -815,7 +815,7 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "libs-disabled" assertProjectTargetProblems "targets/libs-disabled" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ ( flip TargetProblemNoneEnabled [ AvailableTarget "p-0.1" (CLibName LMainLibName) TargetNotBuildable True ] @@ -825,7 +825,7 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "exes-disabled" assertProjectTargetProblems "targets/exes-disabled" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ ( flip TargetProblemNoneEnabled [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True @@ -836,7 +836,7 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "test-only" assertProjectTargetProblems "targets/test-only" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ ( flip TargetProblemNoneEnabled [ AvailableTarget "p-0.1" (CTestName "pexe") @@ -848,7 +848,7 @@ testTargetProblemsRepl config reportSubCase = do reportSubCase "empty-pkg" assertProjectTargetProblems "targets/empty-pkg" config - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ ( TargetProblemNoTargets, mkTargetPackage "p-0.1" ) ] @@ -858,7 +858,7 @@ testTargetProblemsRepl config reportSubCase = do -- by default we only get the lib assertProjectDistinctTargets elaboratedPlan - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] [ ("p-0.1-inplace", (CLibName LMainLibName)) ] @@ -866,13 +866,13 @@ testTargetProblemsRepl config reportSubCase = do -- components even though we did not explicitly enable tests/benchmarks assertProjectDistinctTargets elaboratedPlan - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ] [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] assertProjectDistinctTargets elaboratedPlan - CmdRepl.selectPackageTargets + (CmdRepl.selectPackageTargets (CmdRepl.MultiReplDecision Nothing False)) CmdRepl.selectComponentTarget [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 94f4190880e..218cddce080 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -483,6 +483,7 @@ instance Arbitrary ProjectConfigShared where projectConfigIndependentGoals <- arbitrary projectConfigPreferOldest <- arbitrary projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken + projectConfigMultiRepl <- arbitrary return ProjectConfigShared {..} where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] @@ -525,6 +526,7 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigIndependentGoals <*> shrinker projectConfigPreferOldest <*> shrinker projectConfigProgPathExtra + <*> shrinker projectConfigMultiRepl where preShrink_Constraints = map fst postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))