Revert "Merge pull request #3863 from haskell/installplan-installed-state"

This reverts commit 7b67f37b, reversing
changes made to c12290f8.

cabal-install/Distribution/Client/InstallPlan.hs

@@ -33,7 +33,7 @@ module Distribution.Client.InstallPlan (
   fromSolverInstallPlan,
   configureInstallPlan,
   remove,
-  installed,
+  preexisting,
   lookup,
   directDeps,
   revDirectDeps,
@@ -159,7 +159,6 @@ import Prelude hiding (lookup)
 data GenericPlanPackage ipkg srcpkg
    = PreExisting ipkg
    | Configured  srcpkg
-   | Installed   srcpkg
   deriving (Eq, Show, Generic)
 
 type IsUnit a = (IsNode a, Key a ~ UnitId)
@@ -173,11 +172,9 @@ instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
          => IsNode (GenericPlanPackage ipkg srcpkg) where
     type Key (GenericPlanPackage ipkg srcpkg) = UnitId
     nodeKey (PreExisting ipkg) = nodeKey ipkg
-    nodeKey (Configured  spkg) = nodeKey spkg
-    nodeKey (Installed   spkg) = nodeKey spkg
+    nodeKey (Configured spkg) = nodeKey spkg
     nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
-    nodeNeighbors (Configured  spkg) = nodeNeighbors spkg
-    nodeNeighbors (Installed   spkg) = nodeNeighbors spkg
+    nodeNeighbors (Configured spkg) = nodeNeighbors spkg
 
 instance (Binary ipkg, Binary srcpkg)
       => Binary (GenericPlanPackage ipkg srcpkg)
@@ -189,20 +186,17 @@ instance (Package ipkg, Package srcpkg) =>
          Package (GenericPlanPackage ipkg srcpkg) where
   packageId (PreExisting ipkg)     = packageId ipkg
   packageId (Configured  spkg)     = packageId spkg
-  packageId (Installed   spkg)     = packageId spkg
 
 instance (HasUnitId ipkg, HasUnitId srcpkg) =>
          HasUnitId
          (GenericPlanPackage ipkg srcpkg) where
   installedUnitId (PreExisting ipkg) = installedUnitId ipkg
   installedUnitId (Configured  spkg) = installedUnitId spkg
-  installedUnitId (Installed   spkg) = installedUnitId spkg
 
 instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
           HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
     configuredId (PreExisting ipkg) = configuredId ipkg
-    configuredId (Configured  spkg) = configuredId spkg
-    configuredId (Installed   spkg) = configuredId spkg
+    configuredId (Configured pkg) = configuredId pkg
 
 data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
     planIndex      :: !(PlanIndex ipkg srcpkg),
@@ -261,7 +255,6 @@ showInstallPlan = showPlanIndex . planIndex
 showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
 showPlanPackageTag (PreExisting _)   = "PreExisting"
 showPlanPackageTag (Configured  _)   = "Configured"
-showPlanPackageTag (Installed   _)   = "Installed"
 
 -- | Build an installation plan from a valid set of resolved packages.
 --
@@ -290,27 +283,25 @@ remove shouldRemove plan =
     newIndex = Graph.fromList $
                  filter (not . shouldRemove) (toList plan)
 
--- | Change a number of packages in the 'Configured' state to the 'Installed'
--- state.
---
--- To preserve invariants, the package must have all of its dependencies
--- already installed too (that is 'PreExisting' or 'Installed').
---
-installed :: (IsUnit ipkg, IsUnit srcpkg)
-          => (srcpkg -> Bool)
-          -> GenericInstallPlan ipkg srcpkg
-          -> GenericInstallPlan ipkg srcpkg
-installed shouldBeInstalled installPlan =
-    foldl' markInstalled installPlan
-      [ pkg
-      | Configured pkg <- reverseTopologicalOrder installPlan
-      , shouldBeInstalled pkg ]
+-- | Replace a ready package with a pre-existing one. The pre-existing one
+-- must have exactly the same dependencies as the source one was configured
+-- with.
+--
+preexisting :: (IsUnit ipkg,
+                IsUnit srcpkg)
+            => UnitId
+            -> ipkg
+            -> GenericInstallPlan ipkg srcpkg
+            -> GenericInstallPlan ipkg srcpkg
+preexisting pkgid ipkg plan = plan'
   where
-    markInstalled plan pkg =
-      assert (all isInstalled (directDeps plan (nodeKey pkg))) $
-      plan {
-        planIndex = Graph.insert (Installed pkg) (planIndex plan)
-      }
+    plan' = plan {
+      planIndex   = Graph.insert (PreExisting ipkg)
+                    -- ...but be sure to use the *old* IPID for the lookup for
+                    -- the preexisting record
+                  . Graph.deleteKey pkgid
+                  $ planIndex plan
+    }
 
 -- | Lookup a package in the plan.
 --
@@ -518,18 +509,17 @@ ready plan =
     !processing =
       Processing
         (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])
-        (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])
+        (Set.fromList [ nodeKey pkg | PreExisting pkg <- toList plan ])
         Set.empty
     readyPackages =
       [ ReadyPackage pkg
       | Configured pkg <- toList plan
-      , all isInstalled (directDeps plan (nodeKey pkg))
+      , all isPreExisting (directDeps plan (nodeKey pkg))
       ]
 
-isInstalled :: GenericPlanPackage a b -> Bool
-isInstalled (PreExisting {}) = True
-isInstalled (Installed   {}) = True
-isInstalled _                = False
+    isPreExisting (PreExisting {}) = True
+    isPreExisting _                = False
+
 
 -- | Given a package in the processing state, mark the package as completed
 -- and return any packages that are newly in the processing state (ie ready to
@@ -602,7 +592,6 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
  && and [ case Graph.lookup pkgid (planIndex plan) of
             Just (Configured  _) -> True
             Just (PreExisting _) -> False
-            Just (Installed   _) -> False
             Nothing              -> False 
         | pkgid <- Set.toList processingSet ++ Set.toList failedSet ]
   where

cabal-install/Distribution/Client/ProjectBuilding.hs

@@ -146,10 +146,6 @@ data BuildStatus =
      --   need building.
      BuildStatusPreExisting
 
-     -- | The package is in the 'InstallPlan.Installed' state, so does not
-     --   need building.
-   | BuildStatusInstalled
-
      -- | The package has not been downloaded yet, so it will have to be
      --   downloaded, unpacked and built.
    | BuildStatusDownload
@@ -170,7 +166,6 @@ data BuildStatus =
 
 buildStatusToString :: BuildStatus -> String
 buildStatusToString BuildStatusPreExisting      = "BuildStatusPreExisting"
-buildStatusToString BuildStatusInstalled        = "BuildStatusInstalled"
 buildStatusToString BuildStatusDownload         = "BuildStatusDownload"
 buildStatusToString (BuildStatusUnpack fp)      = "BuildStatusUnpack " ++ show fp
 buildStatusToString (BuildStatusRebuild fp _)   = "BuildStatusRebuild " ++ show fp
@@ -234,7 +229,6 @@ data BuildReason =
 --
 buildStatusRequiresBuild :: BuildStatus -> Bool
 buildStatusRequiresBuild BuildStatusPreExisting = False
-buildStatusRequiresBuild BuildStatusInstalled   = False
 buildStatusRequiresBuild BuildStatusUpToDate {} = False
 buildStatusRequiresBuild _                      = True
 
@@ -257,7 +251,7 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
     -- For 'BuildStatusUpToDate' packages, improve the plan by marking them as
     -- 'InstallPlan.Installed'.
     let installPlan' = improveInstallPlanWithUpToDatePackages
-                         pkgsBuildStatus installPlan
+                         installPlan pkgsBuildStatus
     debugNoWrap verbosity $ InstallPlan.showInstallPlan installPlan'
 
     return (installPlan', pkgsBuildStatus)
@@ -268,9 +262,6 @@ rebuildTargetsDryRun verbosity distDirLayout@DistDirLayout{..} shared = \install
     dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
       return BuildStatusPreExisting
 
-    dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
-      return BuildStatusInstalled
-
     dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
       mloc <- checkFetched (elabPkgSourceLocation pkg)
       case mloc of
@@ -365,18 +356,29 @@ foldMInstallPlanDepOrder plan0 visit =
       let results' = Map.insert (nodeKey pkg) result results
       go results' pkgs
 
-improveInstallPlanWithUpToDatePackages :: BuildStatusMap
+improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan
+                                       -> BuildStatusMap
                                        -> ElaboratedInstallPlan
-                                       -> ElaboratedInstallPlan
-improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
-    InstallPlan.installed canPackageBeImproved
+improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
+    replaceWithPrePreExisting installPlan
+      [ (installedUnitId pkg, mipkg)
+      | InstallPlan.Configured pkg
+          <- InstallPlan.reverseTopologicalOrder installPlan
+      , let uid = installedUnitId pkg
+            Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus
+      , BuildStatusUpToDate (BuildResult { buildResultLibInfo = mipkg })
+          <- [pkgBuildStatus]
+      ]
   where
-    canPackageBeImproved pkg =
-      case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
-        Just BuildStatusUpToDate {} -> True
-        Just _                      -> False
-        Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
-                        ++ display (packageId pkg) ++ " not in status map"
+    replaceWithPrePreExisting =
+      foldl' (\plan (uid, mipkg) ->
+                -- TODO: A grievous hack.  Better to have a special type
+                -- of entry representing pre-existing executables.
+                let stub_ipkg = Installed.emptyInstalledPackageInfo {
+                                    Installed.installedUnitId = uid
+                                }
+                    ipkg = fromMaybe stub_ipkg mipkg
+                in InstallPlan.preexisting uid ipkg plan)
 
 
 -----------------------------
@@ -743,7 +745,6 @@ rebuildTarget verbosity
 
       -- TODO: perhaps re-nest the types to make these impossible
       BuildStatusPreExisting {} -> unexpectedState
-      BuildStatusInstalled   {} -> unexpectedState
       BuildStatusUpToDate    {} -> unexpectedState
   where
     unexpectedState = error "rebuildTarget: unexpected package status"

cabal-install/Distribution/Client/ProjectOrchestration.hs

@@ -532,8 +532,7 @@ printPlan verbosity
             partialConfigureFlags
 
     showBuildStatus status = case status of
-      BuildStatusPreExisting -> "existing package"
-      BuildStatusInstalled   -> "already installed"
+      BuildStatusPreExisting -> "already installed"
       BuildStatusDownload {} -> "requires download & build"
       BuildStatusUnpack   {} -> "requires build"
       BuildStatusRebuild _ rebuild -> case rebuild of

cabal-install/Distribution/Client/ProjectPlanOutput.hs

@@ -2,6 +2,8 @@
              DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
              ScopedTypeVariables #-}
 
+-- | An experimental new UI for cabal for working with multiple packages
+-----------------------------------------------------------------------------
 module Distribution.Client.ProjectPlanOutput (
     writePlanExternalRepresentation,
   ) where
@@ -17,7 +19,6 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
 import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
 
 import           Distribution.Package
-import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
 import qualified Distribution.PackageDescription as PD
 import           Distribution.Text
 import           Distribution.Simple.Utils
@@ -28,10 +29,6 @@ import qualified Data.ByteString.Builder as BB
 import           System.FilePath
 
 
------------------------------------------------------------------------------
--- Writing plan.json files
---
-
 -- | Write out a representation of the elaborated install plan.
 --
 -- This is for the benefit of debugging and external tools like editors.
@@ -56,37 +53,27 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
     --      the parts of the elaboratedInstallPlan
     J.object [ "cabal-version"     J..= jdisplay Our.version
              , "cabal-lib-version" J..= jdisplay cabalVersion
-             , "install-plan"      J..= installPlanToJ elaboratedInstallPlan
+             , "install-plan"      J..= jsonIPlan
              ]
   where
-    installPlanToJ :: ElaboratedInstallPlan -> [J.Value]
-    installPlanToJ = map planPackageToJ . InstallPlan.toList
-
-    planPackageToJ :: ElaboratedPlanPackage -> J.Value
-    planPackageToJ pkg =
-      case pkg of
-        InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi
-        InstallPlan.Configured elab -> elaboratedPackageToJ False elab
-        InstallPlan.Installed  elab -> elaboratedPackageToJ True  elab
-
-    installedPackageInfoToJ :: InstalledPackageInfo -> J.Value
-    installedPackageInfoToJ ipi =
-      -- Pre-existing packages lack configuration information such as their flag
-      -- settings or non-lib components. We only get pre-existing packages for
-      -- the global/core packages however, so this isn't generally a problem.
-      -- So these packages are never local to the project.
+    jsonIPlan = map toJ (InstallPlan.toList elaboratedInstallPlan)
+
+    -- ipi :: InstalledPackageInfo
+    toJ (InstallPlan.PreExisting ipi) =
+      -- installed packages currently lack configuration information
+      -- such as their flag settings or non-lib components.
       --
+      -- TODO: how to find out whether package is "local"?
       J.object
         [ "type"       J..= J.String "pre-existing"
         , "id"         J..= jdisplay (installedUnitId ipi)
         , "depends" J..= map jdisplay (installedDepends ipi)
         ]
 
-    elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value
-    elaboratedPackageToJ isInstalled elab =
+    -- pkg :: ElaboratedPackage
+    toJ (InstallPlan.Configured elab) =
       J.object $
-        [ "type"       J..= J.String (if isInstalled then "installed"
-                                                     else "configured")
+        [ "type"       J..= J.String "configured"
         , "id"         J..= (jdisplay . installedUnitId) elab
         , "flags"      J..= J.object [ fn J..= v
                                      | (PD.FlagName fn,v) <-

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -87,10 +87,12 @@ import           Distribution.Solver.Types.SourcePackage
 import           Distribution.Package hiding
   (InstalledPackageId, installedPackageId)
 import           Distribution.System
+import qualified Distribution.InstalledPackageInfo as Installed
 import qualified Distribution.PackageDescription as Cabal
 import qualified Distribution.PackageDescription as PD
 import qualified Distribution.PackageDescription.Configuration as PD
 import           Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
 import           Distribution.Simple.Compiler hiding (Flag)
 import qualified Distribution.Simple.GHC   as GHC   --TODO: [code cleanup] eliminate
 import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate
@@ -605,23 +607,22 @@ rebuildInstallPlan verbosity
 
         liftIO $ debug verbosity "Improving the install plan..."
         recreateDirectory verbosity True storeDirectory
-        liftIO $ createPackageDBIfMissing verbosity
-                                          compiler progdb
-                                          storePackageDb
-        storePkgIdSet <- getInstalledStorePackages storeDirectory
-        let improvedPlan = improveInstallPlanWithInstalledPackages
-                             storePkgIdSet
+        storePkgIndex <- getPackageDBContents verbosity
+                                              compiler progdb platform
+                                              storePackageDb
+        storeExeIndex <- getExecutableDBContents storeDirectory
+        let improvedPlan = improveInstallPlanWithPreExistingPackages
+                             storePkgIndex
+                             storeExeIndex
                              elaboratedPlan
         liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan 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
-        -- matches up as expected, e.g. no dangling deps, files deleted.
         return improvedPlan
+
       where
         storeDirectory  = cabalStoreDirectory (compilerId compiler)
         storePackageDb  = cabalStorePackageDB (compilerId compiler)
         ElaboratedSharedConfig {
+          pkgConfigPlatform      = platform,
           pkgConfigCompiler      = compiler,
           pkgConfigCompilerProgs = progdb
         } = elaboratedShared
@@ -658,8 +659,6 @@ getInstalledPackages verbosity compiler progdb platform packagedbs = do
                verbosity compiler
                packagedbs progdb
 
-{-
---TODO: [nice to have] use this but for sanity / consistency checking
 getPackageDBContents :: Verbosity
                      -> Compiler -> ProgramDb -> Platform
                      -> PackageDB
@@ -673,21 +672,20 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
       createPackageDBIfMissing verbosity compiler progdb packagedb
       Cabal.getPackageDBContents verbosity compiler
                                  packagedb progdb
--}
 
--- | Return the 'UnitId's of all packages\/components already installed in the
--- store.
---
-getInstalledStorePackages :: FilePath -- ^ store directory
-                          -> Rebuild (Set UnitId)
-getInstalledStorePackages storeDirectory = do
-    paths <- getDirectoryContentsMonitored storeDirectory
-    return $ Set.fromList [ SimpleUnitId (ComponentId path)
-                          | path <- paths, valid path ]
+-- | Return the list of all already installed executables
+getExecutableDBContents
+    :: FilePath -- store directory
+    -> Rebuild (Set ComponentId)
+getExecutableDBContents storeDirectory = do
+    monitorFiles [monitorFileGlob (FilePathGlob (FilePathRoot storeDirectory) (GlobFile [WildCard]))]
+    paths <- liftIO $ getDirectoryContents storeDirectory
+    return (Set.fromList (map ComponentId (filter valid paths)))
   where
-    valid ('.':_)      = False
+    valid "." = False
+    valid ".." = False
     valid "package.db" = False
-    valid _            = True
+    valid _ = True
 
 getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
                   -> Rebuild SourcePackageDb
@@ -733,11 +731,6 @@ getPkgConfigDb verbosity progdb = do
     liftIO $ readPkgConfigDb verbosity progdb
 
 
-getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
-getDirectoryContentsMonitored dir = do
-    monitorFiles [monitorDirectory dir]
-    liftIO $ getDirectoryContents dir
-
 recreateDirectory :: Verbosity -> Bool -> FilePath -> Rebuild ()
 recreateDirectory verbosity createParents dir = do
     liftIO $ createDirectoryIfMissingVerbose verbosity createParents dir
@@ -1242,7 +1235,6 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB
                 case elabPkgOrComp elab of
                     ElabPackage _ -> True
                     ElabComponent comp -> compSolverName comp == CD.ComponentLib
-            is_lib (InstallPlan.Installed _) = unexpectedState
 
     elaborateExeSolverId :: (SolverId -> [ElaboratedPlanPackage])
                       -> SolverId -> [ConfiguredId]
@@ -1255,7 +1247,6 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB
                         case compSolverName comp of
                             CD.ComponentExe _ -> True
                             _ -> False
-            is_exe (InstallPlan.Installed _) = unexpectedState
 
     elaborateExePath :: (SolverId -> [ElaboratedPlanPackage])
                      -> SolverId -> [FilePath]
@@ -1278,9 +1269,6 @@ elaborateInstallPlan platform compiler compilerprogdb pkgConfigDB
                                     Just (Just n) -> n
                                     _ -> ""
               else InstallDirs.bindir (elabInstallDirs elab)]
-        get_exe_path (InstallPlan.Installed _) = unexpectedState
-
-    unexpectedState = error "elaborateInstallPlan: unexpected Installed state"
 
     elaborateSolverToPackage :: (SolverId -> [ElaboratedPlanPackage])
                              -> SolverPackage UnresolvedPkgLoc
@@ -2006,8 +1994,6 @@ mapConfiguredPackage :: (srcpkg -> srcpkg')
                      -> InstallPlan.GenericPlanPackage ipkg srcpkg'
 mapConfiguredPackage f (InstallPlan.Configured pkg) =
   InstallPlan.Configured (f pkg)
-mapConfiguredPackage f (InstallPlan.Installed pkg) =
-  InstallPlan.Installed (f pkg)
 mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =
   InstallPlan.PreExisting pkg
 
@@ -2717,17 +2703,20 @@ packageHashConfigInputs
 
 
 -- | Given the 'InstalledPackageIndex' for a nix-style package store, and an
--- 'ElaboratedInstallPlan', replace configured source packages by installed
--- packages from the store whenever they exist.
+-- 'ElaboratedInstallPlan', replace configured source packages by pre-existing
+-- installed packages whenever they exist.
 --
-improveInstallPlanWithInstalledPackages :: Set UnitId
-                                        -> ElaboratedInstallPlan
-                                        -> ElaboratedInstallPlan
-improveInstallPlanWithInstalledPackages installedPkgIdSet =
-    InstallPlan.installed canPackageBeImproved
+improveInstallPlanWithPreExistingPackages :: InstalledPackageIndex
+                                          -> Set ComponentId
+                                          -> ElaboratedInstallPlan
+                                          -> ElaboratedInstallPlan
+improveInstallPlanWithPreExistingPackages installedPkgIndex installedExes installPlan =
+    replaceWithPreExisting installPlan
+      [ ipkg
+      | InstallPlan.Configured pkg
+          <- InstallPlan.reverseTopologicalOrder installPlan
+      , ipkg <- maybeToList (canPackageBeImproved pkg) ]
   where
-    canPackageBeImproved pkg =
-      installedUnitId pkg `Set.member` installedPkgIdSet
     --TODO: sanity checks:
     -- * the installed package must have the expected deps etc
     -- * the installed package must not be broken, valid dep closure
@@ -2735,3 +2724,18 @@ improveInstallPlanWithInstalledPackages installedPkgIdSet =
     --TODO: decide what to do if we encounter broken installed packages,
     -- since overwriting is never safe.
 
+    canPackageBeImproved pkg =
+      case PackageIndex.lookupUnitId
+            installedPkgIndex (installedUnitId pkg) of
+        Just x -> Just x
+        Nothing | SimpleUnitId cid <- installedUnitId pkg
+                , cid `Set.member` installedExes
+                -- Same hack as replacewithPrePreExisting
+                -> Just (Installed.emptyInstalledPackageInfo {
+                            Installed.installedUnitId = installedUnitId pkg
+                        })
+                | otherwise -> Nothing
+
+    replaceWithPreExisting =
+      foldl' (\plan ipkg -> InstallPlan.preexisting
+                              (installedUnitId ipkg) ipkg plan)