propagate stage trough elaborateProjectPlanning

available targets are only host

Author: andreabedini

cabal-install/src/Distribution/Client/CmdGenBounds.hs

@@ -42,6 +42,7 @@ import Distribution.Client.TargetProblem
 import Distribution.Simple.Command
 import Distribution.Types.Component
 import Distribution.Verbosity
+import qualified Distribution.Compat.Graph as Graph
 
 -- | The data type for gen-bounds command flags
 data GenBoundsFlags = GenBoundsFlags {}
@@ -130,16 +131,16 @@ genBoundsAction flags targetStrings globalFlags =
       pkgVersionMap :: Map.Map ComponentId PackageIdentifier
       pkgVersionMap = Map.fromList (map (InstallPlan.foldPlanPackage externalVersion localVersion) (InstallPlan.toList elaboratedPlan'))
 
-      externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier)
-      externalVersion pkg = (installedComponentId pkg, packageId pkg)
+      externalVersion :: WithStage InstalledPackageInfo -> (ComponentId, PackageIdentifier)
+      externalVersion (WithStage _stage pkg) = (installedComponentId pkg, packageId pkg)
 
       localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier)
       localVersion pkg = (elabComponentId pkg, packageId pkg)
 
     let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult]
         genBoundsActionForPkg pkg =
           -- Step 5: Match up the user specified targets with the local packages.
-          case Map.lookup (installedUnitId pkg) targets of
+          case Map.lookup (Graph.nodeKey pkg) targets of
             Nothing -> []
             Just tgts ->
               map (\(tgt, _) -> getBoundsForComponent tgt pkg pkgVersionMap) tgts
@@ -188,7 +189,8 @@ getBoundsForComponent tgt pkg pkgVersionMap =
       let componentDeps = elabLibDependencies pkg
           -- Match these up to package names, this is a list of Package name to versions.
           -- Now just match that up with what the user wrote in the build-depends section.
-          depsWithVersions = mapMaybe (\cid -> Map.lookup (confInstId $ fst cid) pkgVersionMap) componentDeps
+          -- FIXME: I am not quite sure how this is supposed to work
+          depsWithVersions = mapMaybe (\(WithStage _stage cid, _) -> Map.lookup (confInstId cid) pkgVersionMap) componentDeps
           isNeeded = hasElem needBounds . packageName
        in boundsResult (Just (filter isNeeded depsWithVersions))
   where

cabal-install/src/Distribution/Client/CmdHaddockProject.hs

@@ -35,11 +35,11 @@ import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning
   ( ElaboratedConfiguredPackage (..)
   , ElaboratedInstallPlan
+  , ElaboratedInstalledPackageInfo
   , ElaboratedSharedConfig (..)
   , TargetAction (..)
-  )
-import Distribution.Client.ProjectPlanning.Types
-  ( Toolchain (..)
+  , Toolchain (..)
+  , WithStage(..)
   , elabDistDirParams
   , getStage
   )
@@ -159,7 +159,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
           sharedConfig :: ElaboratedSharedConfig
           sharedConfig = elaboratedShared buildCtx
 
-          pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+          pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage]
           pkgs = matchingPackages elaboratedPlan
 
       -- TODO
@@ -209,7 +209,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
 
       packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
         case pkg of
-          Left package | localStyle -> do
+          Left (WithStage _ package) | localStyle -> do
             let packageName = unPackageName (pkgName $ sourcePackageId package)
                 destDir = outputDir </> packageName
             fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
@@ -441,7 +441,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
 
     matchingPackages
       :: ElaboratedInstallPlan
-      -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+      -> [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage]
     matchingPackages =
       fmap (foldPlanPackage Left Right)
         . InstallPlan.toList

cabal-install/src/Distribution/Client/CmdInstall.hs

@@ -92,9 +92,9 @@ import Distribution.Client.ProjectConfig.Types
 import Distribution.Client.ProjectFlags (ProjectFlags (..))
 import Distribution.Client.ProjectPlanning
   ( storePackageInstallDirs'
-  )
-import Distribution.Client.ProjectPlanning.Types
-  ( ElaboratedInstallPlan
+  , ElaboratedInstallPlan
+  , ElaboratedPlanPackage
+  , Stage (..)
   )
 import Distribution.Client.RebuildMonad
   ( runRebuild
@@ -115,6 +115,7 @@ import Distribution.Client.Types
 import Distribution.Client.Types.OverwritePolicy
   ( OverwritePolicy (..)
   )
+import qualified Distribution.Compat.Graph as Graph
 import Distribution.Package
   ( Package (..)
   , PackageName
@@ -565,7 +566,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
     traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do
       let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags
       actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg
-      traverse_ actionOnExe . Map.toList $ targetsMap buildCtx
+      traverse_ actionOnExe . Map.toList $ filterTargetsWithStage Host $ targetsMap buildCtx
 
 withProject
   :: Verbosity
@@ -784,7 +785,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector
 
       localPkgs = sdistize <$> localPackages baseCtx
 
-      gatherTargets :: UnitId -> TargetSelector
+      gatherTargets :: Graph.Key ElaboratedPlanPackage -> TargetSelector
       gatherTargets targetId = TargetPackageNamed pkgName targetFilter
         where
           targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
@@ -829,7 +830,7 @@ partitionToKnownTargetsAndHackagePackages
   -> SourcePackageDb
   -> ElaboratedInstallPlan
   -> [TargetSelector]
-  -> IO (TargetsMap, [PackageName])
+  -> IO (TargetsMapS, [PackageName])
 partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
   let mTargets =
         resolveTargetsFromSolver
@@ -1005,7 +1006,7 @@ installLibraries
             ordNub $
               globalEntries
                 ++ envEntries
-                ++ entriesForLibraryComponents (targetsMap buildCtx)
+                ++ entriesForLibraryComponents (filterTargetsWithStage Host $ targetsMap buildCtx)
           contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
         createDirectoryIfMissing True (takeDirectory envFile)
         writeFileAtomic envFile (BS.pack contents')

cabal-install/src/Distribution/Client/CmdListBin.hs

@@ -224,7 +224,7 @@ listbinAction flags args globalFlags = do
 -- Target Problem: the very similar to CmdRun
 -------------------------------------------------------------------------------
 
-singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
+singleComponentOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName)
 singleComponentOrElse action targetsMap =
   case Set.toList . distinctTargetComponents $ targetsMap of
     [(unitId, CExeName component)] -> return (unitId, component)
@@ -316,7 +316,7 @@ data ListBinProblem
   | -- | A single 'TargetSelector' matches multiple targets
     TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
   | -- | Multiple 'TargetSelector's match multiple targets
-    TargetProblemMultipleTargets TargetsMap
+    TargetProblemMultipleTargets TargetsMapS
   | -- | The 'TargetSelector' refers to a component that is not an executable
     TargetProblemComponentNotRightKind PackageId ComponentName
   | -- | Asking to run an individual file or module is not supported
@@ -333,7 +333,7 @@ matchesMultipleProblem selector targets =
   CustomTargetProblem $
     TargetProblemMatchesMultiple selector targets
 
-multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem
+multipleTargetsProblem :: TargetsMapS -> TargetProblem ListBinProblem
 multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
 
 componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem

cabal-install/src/Distribution/Client/CmdPath.hs

@@ -42,7 +42,6 @@ import Distribution.Client.ProjectConfig.Types
   )
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning
-import Distribution.Client.ProjectPlanning.Types (Toolchain (..))
 import Distribution.Client.RebuildMonad (runRebuild)
 import Distribution.Client.ScriptUtils
 import Distribution.Client.Setup
@@ -55,7 +54,6 @@ import qualified Distribution.Client.Utils.Json as Json
 import Distribution.Client.Version
   ( cabalInstallVersion
   )
-import Distribution.Solver.Types.Stage
 import Distribution.ReadE
   ( ReadE (ReadE)
   )

cabal-install/src/Distribution/Client/CmdRepl.hs

@@ -55,6 +55,9 @@ import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectPlanning
   ( ElaboratedInstallPlan
   , ElaboratedSharedConfig (..)
+  , WithStage
+  , Stage (..)
+  , getStage
   )
 import Distribution.Client.ProjectPlanning.Types
   ( Toolchain (..)
@@ -92,7 +95,6 @@ import Distribution.Compiler
 import Distribution.Package
   ( Package (..)
   , UnitId
-  , installedUnitId
   , mkPackageName
   , packageName
   )
@@ -181,6 +183,7 @@ import Distribution.Client.ReplFlags
   , topReplOptions
   )
 import Distribution.Compat.Binary (decode)
+import qualified Distribution.Compat.Graph as Graph
 import Distribution.Simple.Flag (flagToMaybe, fromFlagOrDefault, pattern Flag)
 import Distribution.Simple.Program.Builtin (ghcProgram)
 import Distribution.Simple.Program.Db (requireProgram)
@@ -196,7 +199,6 @@ import System.FilePath
   , splitSearchPath
   , (</>)
   )
-import Distribution.Solver.Types.Stage
 
 replCommand :: CommandUI (NixStyleFlags ReplFlags)
 replCommand =
@@ -362,15 +364,14 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
         -- especially in the no-project case.
         withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do
           -- targets should be non-empty map, but there's no NonEmptyMap yet.
-          -- TODO: This only makes sense for the build stage
           let Toolchain { toolchainCompiler = compiler } = getStage (pkgConfigToolchains sharedConfig) Build
+          -- FIXME there is total confusion here about who is filtering for the stage
           targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors
-
           let
-            (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
-            originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId
-            oci = OriginalComponentInfo unitId originalDeps
-            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId
+            (key, _uid) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets
+            originalDeps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan key
+            oci = OriginalComponentInfo key originalDeps
+            pkgId = fromMaybe (error $ "cannot find " ++ prettyShow key) $ packageId <$> InstallPlan.lookup elaboratedPlan key
             baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx'
 
           return (Just oci, baseCtx'')
@@ -524,6 +525,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
     verbosity = cfgVerbosity normal flags
     tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags
 
+    -- FIXME: the compiler depends on the stage!!
     validatedTargets ctx compiler elaboratedPlan targetSelectors = do
       let multi_repl_enabled = multiReplDecision ctx compiler r
       -- Interpret the targets on the command line as repl targets
@@ -563,8 +565,8 @@ minMultipleHomeUnitsVersion :: Version
 minMultipleHomeUnitsVersion = mkVersion [9, 4]
 
 data OriginalComponentInfo = OriginalComponentInfo
-  { ociUnitId :: UnitId
-  , ociOriginalDeps :: [UnitId]
+  { ociUnitId :: WithStage UnitId
+  , ociOriginalDeps :: [WithStage UnitId]
   }
   deriving (Show)
 
@@ -599,18 +601,25 @@ addDepsToProjectTarget deps pkgId ctx =
 generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String]
 generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags
   where
-    exeDeps :: [UnitId]
+    exeDeps :: [WithStage UnitId]
     exeDeps =
       foldMap
         (InstallPlan.foldPlanPackage (const []) elabOrderExeDependencies)
         (InstallPlan.dependencyClosure elaboratedPlan [ociUnitId])
 
-    deps, deps', trans, trans' :: [UnitId]
-    flags :: [String]
-    deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
+    deps :: [WithStage UnitId]
+    deps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan ociUnitId
+    
+    deps' :: [WithStage UnitId]
     deps' = deps \\ ociOriginalDeps
-    trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
+
+    trans :: [WithStage UnitId]
+    trans = Graph.nodeKey <$> InstallPlan.dependencyClosure elaboratedPlan deps'
+
+    trans' :: [WithStage UnitId]
     trans' = trans \\ ociOriginalDeps
+
+    flags :: [String]
     flags =
       fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $
         if includeTransitive then trans' else deps'
@@ -762,7 +771,7 @@ selectComponentTarget = selectComponentTargetBasic
 data ReplProblem
   = TargetProblemMatchesMultiple MultiReplDecision TargetSelector [AvailableTarget ()]
   | -- | Multiple 'TargetSelector's match multiple targets
-    TargetProblemMultipleTargets MultiReplDecision TargetsMap
+    TargetProblemMultipleTargets MultiReplDecision TargetsMapS
   deriving (Eq, Show)
 
 -- | The various error conditions that can occur when matching a
@@ -779,7 +788,7 @@ matchesMultipleProblem decision targetSelector targetsExesBuildable =
 
 multipleTargetsProblem
   :: MultiReplDecision
-  -> TargetsMap
+  -> TargetsMapS
   -> ReplTargetProblem
 multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision
 

cabal-install/src/Distribution/Client/CmdRun.hs

@@ -55,6 +55,7 @@ import qualified Distribution.Client.ProjectOrchestration as Orchestration (targ
 import Distribution.Client.ProjectPlanning
   ( ElaboratedConfiguredPackage (..)
   , ElaboratedInstallPlan
+  , WithStage (..)
   , binDirectoryFor
   )
 import Distribution.Client.ProjectPlanning.Types
@@ -384,7 +385,7 @@ handleShebang :: FilePath -> [String] -> IO ()
 handleShebang script args =
   runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags
 
-singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
+singleExeOrElse :: IO (WithStage UnitId, UnqualComponentName) -> TargetsMapS -> IO (WithStage UnitId, UnqualComponentName)
 singleExeOrElse action targetsMap =
   case Set.toList . distinctTargetComponents $ targetsMap of
     [(unitId, CExeName component)] -> return (unitId, component)
@@ -396,16 +397,16 @@ singleExeOrElse action targetsMap =
 -- 'ElaboratedConfiguredPackage's that match the specified
 -- 'UnitId'.
 matchingPackagesByUnitId
-  :: UnitId
+  :: WithStage UnitId
   -> ElaboratedInstallPlan
   -> [ElaboratedConfiguredPackage]
-matchingPackagesByUnitId uid =
+matchingPackagesByUnitId (WithStage s uid) =
   catMaybes
     . fmap
       ( foldPlanPackage
           (const Nothing)
           ( \x ->
-              if elabUnitId x == uid
+              if elabUnitId x == uid && elabStage x == s
                 then Just x
                 else Nothing
           )
@@ -494,7 +495,7 @@ data RunProblem
   | -- | A single 'TargetSelector' matches multiple targets
     TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
   | -- | Multiple 'TargetSelector's match multiple targets
-    TargetProblemMultipleTargets TargetsMap
+    TargetProblemMultipleTargets TargetsMapS
   | -- | The 'TargetSelector' refers to a component that is not an executable
     TargetProblemComponentNotExe PackageId ComponentName
   | -- | Asking to run an individual file or module is not supported
@@ -511,7 +512,7 @@ matchesMultipleProblem selector targets =
   CustomTargetProblem $
     TargetProblemMatchesMultiple selector targets
 
-multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem
+multipleTargetsProblem :: TargetsMapS -> TargetProblem RunProblem
 multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
 
 componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem

cabal-install/src/Distribution/Client/CmdTarget.hs

@@ -170,7 +170,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do
     either (reportTargetSelectorProblems verbosity) return
       =<< readTargetSelectors localPackages Nothing targetStrings
 
-  targets :: TargetsMap <-
+  targets <-
     either (reportBuildTargetProblems verbosity) return $
       resolveTargetsFromSolver
         selectPackageTargets
@@ -192,7 +192,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do
 reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
 reportBuildTargetProblems verbosity = reportTargetProblems verbosity "target"
 
-printTargetForms :: Verbosity -> [String] -> TargetsMap -> ElaboratedInstallPlan -> IO ()
+printTargetForms :: Verbosity -> [String] -> TargetsMapS -> ElaboratedInstallPlan -> IO ()
 printTargetForms verbosity targetStrings targets elaboratedPlan =
   noticeDoc verbosity $
     vcat
@@ -218,7 +218,7 @@ printTargetForms verbosity targetStrings targets elaboratedPlan =
       sort $
         catMaybes
           [ targetForm ct <$> pkg
-          | (u :: UnitId, xs) <- Map.toAscList targets
+          | (WithStage _ u, xs) <- Map.toAscList targets
           , let pkg = safeHead $ filter ((== u) . elabUnitId) localPkgs
           , (ct :: ComponentTarget, _) <- xs
           ]