propagate stage trough elaborateProjectPlanning

Author: andreabedini

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

@@ -41,6 +41,7 @@ import Distribution.Client.ProjectPlanning.Types
   ( Toolchain (..)
   , elabDistDirParams
   , getStage
+  , ElaboratedInstalledPackageInfo
   )
 import Distribution.Client.ScriptUtils
   ( AcceptNoTargets (..)
@@ -102,6 +103,7 @@ import Distribution.Verbosity as Verbosity
 import Distribution.Client.Errors
 import System.Directory (doesDirectoryExist, doesFileExist)
 import System.FilePath (normalise, takeDirectory, (</>))
+import Distribution.Client.ProjectPlanning.Stage (WithStage(..))
 
 haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO ()
 haddockProjectAction flags _extraArgs globalFlags = do
@@ -156,7 +158,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
           sharedConfig :: ElaboratedSharedConfig
           sharedConfig = elaboratedShared buildCtx
 
-          pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+          pkgs :: [Either ElaboratedInstalledPackageInfo ElaboratedConfiguredPackage]
           pkgs = matchingPackages elaboratedPlan
 
       -- TODO
@@ -206,7 +208,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
@@ -438,7 +440,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,7 +92,7 @@ import Distribution.Client.ProjectPlanning
   ( storePackageInstallDirs'
   )
 import Distribution.Client.ProjectPlanning.Types
-  ( ElaboratedInstallPlan
+  ( ElaboratedInstallPlan, ElaboratedPlanPackage
   )
 import Distribution.Client.RebuildMonad
   ( runRebuild
@@ -114,6 +114,7 @@ import Distribution.Client.Types
 import Distribution.Client.Types.OverwritePolicy
   ( OverwritePolicy (..)
   )
+import qualified Distribution.Compat.Graph as Graph
 import Distribution.Package
   ( Package (..)
   , PackageName
@@ -248,6 +249,7 @@ import System.FilePath
   , (<.>)
   , (</>)
   )
+import qualified Distribution.Client.ProjectPlanning.Types as Stage
 
 -- | Check or check then install an exe. The check is to see if the overwrite
 -- policy allows installation.
@@ -562,7 +564,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 Stage.Host $ targetsMap buildCtx
 
 withProject
   :: Verbosity
@@ -781,7 +783,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
@@ -826,7 +828,7 @@ partitionToKnownTargetsAndHackagePackages
   -> SourcePackageDb
   -> ElaboratedInstallPlan
   -> [TargetSelector]
-  -> IO (TargetsMap, [PackageName])
+  -> IO (TargetsMapS, [PackageName])
 partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
   let mTargets =
         resolveTargets
@@ -1002,7 +1004,7 @@ installLibraries
             ordNub $
               globalEntries
                 ++ envEntries
-                ++ entriesForLibraryComponents (targetsMap buildCtx)
+                ++ entriesForLibraryComponents (filterTargetsWithStage Stage.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@NixStyleFlags{..} 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/CmdRepl.hs

@@ -89,7 +89,6 @@ import Distribution.Compiler
 import Distribution.Package
   ( Package (..)
   , UnitId
-  , installedUnitId
   , mkPackageName
   , packageName
   )
@@ -198,7 +197,9 @@ import System.FilePath
   , splitSearchPath
   , (</>)
   )
-import Distribution.Solver.Types.Stage
+import Distribution.Solver.Types.Stage (Stage(..), Staged(..))
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.Client.ProjectPlanning.Stage (WithStage(..))
 
 replCommand :: CommandUI (NixStyleFlags ReplFlags)
 replCommand =
@@ -345,15 +346,16 @@ 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
-          targets <- validatedTargets (projectConfigShared (projectConfig ctx)) compiler elaboratedPlan targetSelectors
-
+          let stage = Build
+              Toolchain { toolchainCompiler = compiler } = getStage (pkgConfigToolchains sharedConfig) stage
+          -- 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'')
@@ -512,18 +514,19 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g
     verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
     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
       -- (as opposed to say build or haddock targets).
       targets <-
-        either (reportTargetProblems verbosity) return $
-          resolveTargets
-            (selectPackageTargets multi_repl_enabled)
-            selectComponentTarget
-            elaboratedPlan
-            Nothing
-            targetSelectors
+        resolveTargets
+          (selectPackageTargets multi_repl_enabled)
+          selectComponentTarget
+          elaboratedPlan
+          Nothing
+          targetSelectors
+        >>= either (reportTargetProblems verbosity) return
 
       -- Reject multiple targets, or at least targets in different
       -- components. It is ok to have two module/file targets in the
@@ -552,8 +555,8 @@ minMultipleHomeUnitsVersion :: Version
 minMultipleHomeUnitsVersion = mkVersion [9, 4]
 
 data OriginalComponentInfo = OriginalComponentInfo
-  { ociUnitId :: UnitId
-  , ociOriginalDeps :: [UnitId]
+  { ociUnitId :: WithStage UnitId
+  , ociOriginalDeps :: [WithStage UnitId]
   }
   deriving (Show)
 
@@ -588,17 +591,18 @@ 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]
+    deps, deps', trans, trans' :: [WithStage UnitId]
     flags :: [String]
-    deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
+    deps = Graph.nodeKey <$> InstallPlan.directDeps elaboratedPlan ociUnitId
     deps' = deps \\ ociOriginalDeps
-    trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
+
+    trans = Graph.nodeKey <$> InstallPlan.dependencyClosure elaboratedPlan deps'
     trans' = trans \\ ociOriginalDeps
     flags =
       fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $
@@ -751,7 +755,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
@@ -768,7 +772,7 @@ matchesMultipleProblem decision targetSelector targetsExesBuildable =
 
 multipleTargetsProblem
   :: MultiReplDecision
-  -> TargetsMap
+  -> TargetsMapS
   -> ReplTargetProblem
 multipleTargetsProblem decision = CustomTargetProblem . TargetProblemMultipleTargets decision
 

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

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

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

@@ -46,6 +46,7 @@ import Distribution.Verbosity
   )
 import Text.PrettyPrint
 import qualified Text.PrettyPrint as Pretty
+import Distribution.Client.ProjectPlanning.Stage (WithStage(..))
 
 -------------------------------------------------------------------------------
 -- Command
@@ -171,7 +172,7 @@ targetAction flags@NixStyleFlags{..} ts globalFlags = do
     either (reportTargetSelectorProblems verbosity) return
       =<< readTargetSelectors localPackages Nothing targetStrings
 
-  targets :: TargetsMap <-
+  targets <-
     either (reportBuildTargetProblems verbosity) return $
       resolveTargets
         selectPackageTargets
@@ -193,7 +194,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
@@ -219,7 +220,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
           ]

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

@@ -36,6 +36,7 @@ import Network.URI
 import Text.PrettyPrint hiding (render, (<>))
 import qualified Text.PrettyPrint as PP
 import Text.Regex.Posix.ByteString (WrapError)
+import Distribution.Client.ProjectPlanning.Stage (WithStage)
 
 data CabalInstallException
   = UnpackGet
@@ -94,7 +95,7 @@ data CabalInstallException
   | PlanPackages String
   | NoSupportForRunCommand
   | RunPhaseReached
-  | UnknownExecutable String UnitId
+  | UnknownExecutable String (WithStage UnitId)
   | MultipleMatchingExecutables String [String]
   | CmdRunReportTargetProblems String
   | CleanAction [String]