{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.Build.Installed
Description : Determine which packages are already installed.
License     : BSD-3-Clause

Determine which packages are already installed.
-}

module Stack.Build.Installed
  ( getInstalled
  , toInstallMap
  ) where

import           Data.Conduit ( ZipSink (..), getZipSink )
import qualified Data.Conduit.List as CL
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import           Stack.Build.Cache ( getInstalledExes )
import           Stack.Constants ( wiredInPackages )
import           Stack.PackageDump
                   ( conduitDumpPackage, ghcPkgDump, pruneDeps )
import           Stack.Prelude
import           Stack.SourceMap ( getPLIVersion, loadVersion )
import           Stack.Types.Compiler ( ActualCompiler )
import           Stack.Types.CompilerPaths ( getGhcPkgExe )
import           Stack.Types.DumpPackage
                   ( DumpPackage (..), SublibDump (..), sublibParentPkgId )
import           Stack.Types.EnvConfig
                    ( HasEnvConfig, HasSourceMap (..), packageDatabaseDeps
                    , packageDatabaseExtra, packageDatabaseLocal
                    )
import           Stack.Types.GhcPkgId ( GhcPkgId )
import           Stack.Types.Installed
                   ( InstallLocation (..), InstallMap, Installed (..)
                   , InstalledLibraryInfo (..), InstalledMap
                   , InstalledPackageLocation (..), PackageDatabase (..)
                   , PackageDbVariety (..), toPackageDbVariety
                   )
import           Stack.Types.SourceMap
                   ( DepPackage (..), ProjectPackage (..), SourceMap (..) )

-- | For the given t'SourceMap', yield a dictionary of package names for a

-- project's packages and dependencies, and pairs of their relevant database

-- (write-only or mutable) and package versions.

toInstallMap :: MonadIO m => SourceMap -> m InstallMap
toInstallMap :: forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap = do
  projectInstalls <-
    Map PackageName ProjectPackage
-> (ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for SourceMap
sourceMap.project ((ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap)
-> (ProjectPackage -> m (InstallLocation, Version)) -> m InstallMap
forall a b. (a -> b) -> a -> b
$ \ProjectPackage
pp -> do
      version <- CommonPackage -> m Version
forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion ProjectPackage
pp.projectCommon
      pure (Local, version)
  depInstalls <-
    for sourceMap.deps $ \DepPackage
dp ->
      case DepPackage
dp.location of
        PLImmutable PackageLocationImmutable
pli -> (InstallLocation, Version) -> m (InstallLocation, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstallLocation
Snap, PackageLocationImmutable -> Version
getPLIVersion PackageLocationImmutable
pli)
        PLMutable ResolvedPath Dir
_ -> do
          version <- CommonPackage -> m Version
forall (m :: * -> *). MonadIO m => CommonPackage -> m Version
loadVersion DepPackage
dp.depCommon
          pure (Local, version)
  pure $ projectInstalls <> depInstalls

-- | Returns the new InstalledMap and all of the locally registered packages.

getInstalled ::
     HasEnvConfig env
  => InstallMap -- ^ does not contain any installed information

  -> RIO env
       ( InstalledMap
       , [DumpPackage] -- globally installed

       , [DumpPackage] -- snapshot installed

       , [DumpPackage] -- locally installed

       )
getInstalled :: forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled {-opts-} InstallMap
installMap = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Finding out which packages are already installed"
  snapDBPath <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
  localDBPath <- packageDatabaseLocal
  extraDBPaths <- packageDatabaseExtra

  let loadDatabase' = InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
forall env.
HasEnvConfig env =>
InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase {-opts mcache-} InstallMap
installMap

  (installedLibs0, globalDumpPkgs) <- loadDatabase' GlobalPkgDb []
  (installedLibs1, _extraInstalled) <-
    foldM (\([LoadHelper], [DumpPackage])
lhs' Path Abs Dir
pkgdb ->
      PackageDatabase
-> [LoadHelper] -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase' (InstalledPackageLocation -> Path Abs Dir -> PackageDatabase
UserPkgDb InstalledPackageLocation
ExtraPkgDb Path Abs Dir
pkgdb) (([LoadHelper], [DumpPackage]) -> [LoadHelper]
forall a b. (a, b) -> a
fst ([LoadHelper], [DumpPackage])
lhs')
      ) (installedLibs0, globalDumpPkgs) extraDBPaths
  (installedLibs2, snapshotDumpPkgs) <-
    loadDatabase' (UserPkgDb (InstalledTo Snap) snapDBPath) installedLibs1
  (installedLibs3, localDumpPkgs) <-
    loadDatabase' (UserPkgDb (InstalledTo Local) localDBPath) installedLibs2
  let installedLibs =
        (LoadHelper -> InstalledMap -> InstalledMap)
-> InstalledMap -> [LoadHelper] -> InstalledMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' LoadHelper -> InstalledMap -> InstalledMap
gatherAndTransformSubLoadHelper InstalledMap
forall a. Monoid a => a
mempty [LoadHelper]
installedLibs3

  -- Add in the executables that are installed, making sure to only trust a

  -- listed installation under the right circumstances (see below)

  let exesToSM InstallLocation
loc = [InstalledMap] -> InstalledMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([InstalledMap] -> InstalledMap)
-> ([PackageIdentifier] -> [InstalledMap])
-> [PackageIdentifier]
-> InstalledMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageIdentifier -> InstalledMap)
-> [PackageIdentifier] -> [InstalledMap]
forall a b. (a -> b) -> [a] -> [b]
map (InstallLocation -> PackageIdentifier -> InstalledMap
exeToSM InstallLocation
loc)
      exeToSM InstallLocation
loc (PackageIdentifier PackageName
name Version
version) =
        case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
          -- Doesn't conflict with anything, so that's OK

          Maybe (InstallLocation, Version)
Nothing -> InstalledMap
m
          Just (InstallLocation
iLoc, Version
iVersion)
            -- Not the version we want, ignore it

            | Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
iVersion Bool -> Bool -> Bool
|| InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
loc InstallLocation
iLoc -> InstalledMap
forall k a. Map k a
Map.empty
            | Bool
otherwise -> InstalledMap
m
       where
        m :: InstalledMap
m = PackageName -> (InstallLocation, Installed) -> InstalledMap
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (InstallLocation
loc, PackageIdentifier -> Installed
Executable (PackageIdentifier -> Installed) -> PackageIdentifier -> Installed
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version)
        mismatchingLoc :: InstallLocation -> InstallLocation -> Bool
mismatchingLoc InstallLocation
installed InstallLocation
target
          | InstallLocation
target InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
installed = Bool
False
          | InstallLocation
installed InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local = Bool
False -- snapshot dependency could end up

                                       -- in a local install as being mutable

          | Bool
otherwise = Bool
True
  exesSnap <- getInstalledExes Snap
  exesLocal <- getInstalledExes Local
  let installedMap = [InstalledMap] -> InstalledMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions
        [ InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
Local [PackageIdentifier]
exesLocal
        , InstallLocation -> [PackageIdentifier] -> InstalledMap
exesToSM InstallLocation
Snap [PackageIdentifier]
exesSnap
        , InstalledMap
installedLibs
        ]

  pure ( installedMap
       , globalDumpPkgs
       , snapshotDumpPkgs
       , localDumpPkgs
       )

-- | Outputs both the modified InstalledMap and the Set of all installed

-- packages in this database

--

-- The goal is to ascertain that the dependencies for a package are present,

-- that it has profiling if necessary, and that it matches the version and

-- location needed by the SourceMap.

loadDatabase ::
     forall env. HasEnvConfig env
  => InstallMap
     -- ^ to determine which installed things we should include

  -> PackageDatabase
     -- ^ package database.

  -> [LoadHelper]
     -- ^ from parent databases

  -> RIO env ([LoadHelper], [DumpPackage])
loadDatabase :: forall env.
HasEnvConfig env =>
InstallMap
-> PackageDatabase
-> [LoadHelper]
-> RIO env ([LoadHelper], [DumpPackage])
loadDatabase InstallMap
installMap PackageDatabase
db [LoadHelper]
lhs0 = do
  sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SourceMap env SourceMap
forall env. HasSourceMap env => Lens' env SourceMap
Lens' env SourceMap
sourceMapL
  let compiler = SourceMap
sourceMap.compiler
  pkgexe <- getGhcPkgExe
  (lhs1', dps) <- ghcPkgDump pkgexe pkgDb $ conduitDumpPackage .| sink compiler
  lhs1 <- mapMaybeM processLoadResult lhs1'
  let lhs = (GhcPkgId -> GhcPkgId)
-> (LoadHelper -> GhcPkgId)
-> (LoadHelper -> [GhcPkgId])
-> (LoadHelper -> LoadHelper -> LoadHelper)
-> [LoadHelper]
-> Map GhcPkgId LoadHelper
forall name id item.
(Ord name, Ord id) =>
(id -> name)
-> (item -> id)
-> (item -> [id])
-> (item -> item -> item)
-> [item]
-> Map name item
pruneDeps GhcPkgId -> GhcPkgId
forall a. a -> a
id (.ghcPkgId) (.depsGhcPkgId) LoadHelper -> LoadHelper -> LoadHelper
forall a b. a -> b -> a
const ([LoadHelper]
lhs0 [LoadHelper] -> [LoadHelper] -> [LoadHelper]
forall a. [a] -> [a] -> [a]
++ [LoadHelper]
lhs1)
  pure (map (\LoadHelper
lh -> LoadHelper
lh { depsGhcPkgId = [] }) $ Map.elems lhs, dps)
 where
  pkgDb :: [Path Abs Dir]
pkgDb = case PackageDatabase
db of
    PackageDatabase
GlobalPkgDb -> []
    UserPkgDb InstalledPackageLocation
_ Path Abs Dir
fp -> [Path Abs Dir
fp]

  sinkDP :: ActualCompiler
-> ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
sinkDP ActualCompiler
compiler =
       (DumpPackage -> (Allowed, LoadHelper))
-> ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map (InstallMap -> PackageDbVariety -> DumpPackage -> Allowed
isAllowed InstallMap
installMap PackageDbVariety
db' (DumpPackage -> Allowed)
-> (DumpPackage -> LoadHelper)
-> DumpPackage
-> (Allowed, LoadHelper)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ActualCompiler -> PackageDbVariety -> DumpPackage -> LoadHelper
toLoadHelper ActualCompiler
compiler PackageDbVariety
db')
    ConduitT DumpPackage (Allowed, LoadHelper) (RIO env) ()
-> ConduitT
     (Allowed, LoadHelper) Void (RIO env) [(Allowed, LoadHelper)]
-> ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT
  (Allowed, LoadHelper) Void (RIO env) [(Allowed, LoadHelper)]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume
   where
    db' :: PackageDbVariety
db' = PackageDatabase -> PackageDbVariety
toPackageDbVariety PackageDatabase
db
  sink :: ActualCompiler
-> ConduitT
     DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
sink ActualCompiler
compiler =   ZipSink
  DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
     DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall i (m :: * -> *) r. ZipSink i m r -> ConduitT i Void m r
getZipSink (ZipSink
   DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
 -> ConduitT
      DumpPackage
      Void
      (RIO env)
      ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink
     DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
-> ConduitT
     DumpPackage Void (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall a b. (a -> b) -> a -> b
$ (,)
       ([(Allowed, LoadHelper)]
 -> [DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
-> ZipSink
     DumpPackage
     (RIO env)
     ([DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
-> ZipSink DumpPackage (RIO env) [(Allowed, LoadHelper)]
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink (ActualCompiler
-> ConduitT DumpPackage Void (RIO env) [(Allowed, LoadHelper)]
sinkDP ActualCompiler
compiler)
       ZipSink
  DumpPackage
  (RIO env)
  ([DumpPackage] -> ([(Allowed, LoadHelper)], [DumpPackage]))
-> ZipSink DumpPackage (RIO env) [DumpPackage]
-> ZipSink
     DumpPackage (RIO env) ([(Allowed, LoadHelper)], [DumpPackage])
forall a b.
ZipSink DumpPackage (RIO env) (a -> b)
-> ZipSink DumpPackage (RIO env) a
-> ZipSink DumpPackage (RIO env) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ConduitT DumpPackage Void (RIO env) [DumpPackage]
-> ZipSink DumpPackage (RIO env) [DumpPackage]
forall i (m :: * -> *) r. ConduitT i Void m r -> ZipSink i m r
ZipSink ConduitT DumpPackage Void (RIO env) [DumpPackage]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume

  processLoadResult :: (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
  processLoadResult :: (Allowed, LoadHelper) -> RIO env (Maybe LoadHelper)
processLoadResult (Allowed
Allowed, LoadHelper
lh) = Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadHelper -> Maybe LoadHelper
forall a. a -> Maybe a
Just LoadHelper
lh)
  processLoadResult (Allowed
reason, LoadHelper
lh) = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         Utf8Builder
"Ignoring package "
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> PackageName -> Utf8Builder
forall a. IsString a => PackageName -> a
fromPackageName ((PackageName, (InstallLocation, Installed)) -> PackageName
forall a b. (a, b) -> a
fst LoadHelper
lh.pair)
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> case PackageDatabase
db of
           PackageDatabase
GlobalPkgDb -> Utf8Builder
forall a. Monoid a => a
mempty
           UserPkgDb InstalledPackageLocation
loc Path Abs Dir
fp -> Utf8Builder
", from " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (InstalledPackageLocation, Path Abs Dir) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (InstalledPackageLocation
loc, Path Abs Dir
fp) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
","
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" due to"
      Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> case Allowed
reason of
           Allowed
UnknownPkg -> Utf8Builder
" it being unknown to the snapshot or extra-deps."
           WrongLocation PackageDbVariety
db' InstallLocation
loc ->
             Utf8Builder
" wrong location: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> (PackageDbVariety, InstallLocation) -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (PackageDbVariety
db', InstallLocation
loc)
           WrongVersion Version
actual Version
wanted ->
                Utf8Builder
" wanting version "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
wanted)
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" instead of "
            Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> String -> Utf8Builder
forall a. IsString a => String -> a
fromString (Version -> String
versionString Version
actual)
    Maybe LoadHelper -> RIO env (Maybe LoadHelper)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LoadHelper
forall a. Maybe a
Nothing

-- | Type representing results of 'isAllowed'.

data Allowed
  = Allowed
    -- ^ The installed package can be included in the set of relevant installed

    -- packages.

  | UnknownPkg
    -- ^ The installed package cannot be included in the set of relevant

    -- installed packages because the package is unknown.

  | WrongLocation PackageDbVariety InstallLocation
    -- ^ The installed package cannot be included in the set of relevant

    -- installed packages because the package is in the wrong package database.

  | WrongVersion Version Version
    -- ^ The installed package cannot be included in the set of relevant

    -- installed packages because the package has the wrong version.

  deriving (Allowed -> Allowed -> Bool
(Allowed -> Allowed -> Bool)
-> (Allowed -> Allowed -> Bool) -> Eq Allowed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Allowed -> Allowed -> Bool
== :: Allowed -> Allowed -> Bool
$c/= :: Allowed -> Allowed -> Bool
/= :: Allowed -> Allowed -> Bool
Eq, Int -> Allowed -> ShowS
[Allowed] -> ShowS
Allowed -> String
(Int -> Allowed -> ShowS)
-> (Allowed -> String) -> ([Allowed] -> ShowS) -> Show Allowed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Allowed -> ShowS
showsPrec :: Int -> Allowed -> ShowS
$cshow :: Allowed -> String
show :: Allowed -> String
$cshowList :: [Allowed] -> ShowS
showList :: [Allowed] -> ShowS
Show)

-- | Check if an installed package can be included in the set of relevant

-- installed packages or not, based on the package selections made by the user.

-- This does not perform any dirtiness or flag change checks.

isAllowed ::
     InstallMap
  -> PackageDbVariety
     -- ^ The package database providing the installed package.

  -> DumpPackage
     -- ^ The installed package to check.

  -> Allowed
isAllowed :: InstallMap -> PackageDbVariety -> DumpPackage -> Allowed
isAllowed InstallMap
installMap PackageDbVariety
pkgDb DumpPackage
dp = case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name InstallMap
installMap of
  Maybe (InstallLocation, Version)
Nothing ->
    -- If the sourceMap has nothing to say about this package,

    -- check if it represents a sub-library first

    -- See: https://github.com/commercialhaskell/stack/issues/3899

    case DumpPackage -> Maybe PackageIdentifier
sublibParentPkgId DumpPackage
dp of
      Just (PackageIdentifier PackageName
parentLibName Version
version') ->
        case PackageName -> InstallMap -> Maybe (InstallLocation, Version)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
parentLibName InstallMap
installMap of
          Maybe (InstallLocation, Version)
Nothing -> Allowed
checkNotFound
          Just (InstallLocation, Version)
instInfo
            | Version
version' Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
version -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
instInfo
            | Bool
otherwise -> Allowed
checkNotFound -- different versions

      Maybe PackageIdentifier
Nothing -> Allowed
checkNotFound
  Just (InstallLocation, Version)
pii -> (InstallLocation, Version) -> Allowed
checkFound (InstallLocation, Version)
pii
 where
  PackageIdentifier PackageName
name Version
version = DumpPackage
dp.packageIdent
  -- Ensure that the installed location matches where the sourceMap says it

  -- should be installed.

  checkLocation :: InstallLocation -> Bool
checkLocation InstallLocation
Snap =
     -- snapshot deps could become mutable after getting any mutable dependency.

    Bool
True
  checkLocation InstallLocation
Local = case PackageDbVariety
pkgDb of
    PackageDbVariety
GlobalDb -> Bool
False
    -- 'locally' installed snapshot packages can come from 'extra' package

    -- databases.

    PackageDbVariety
ExtraDb -> Bool
True
    PackageDbVariety
WriteOnlyDb -> Bool
False
    PackageDbVariety
MutableDb -> Bool
True
  -- Check if an installed package is allowed if it is found in the sourceMap.

  checkFound :: (InstallLocation, Version) -> Allowed
checkFound (InstallLocation
installLoc, Version
installVer)
    | Bool -> Bool
not (InstallLocation -> Bool
checkLocation InstallLocation
installLoc) = PackageDbVariety -> InstallLocation -> Allowed
WrongLocation PackageDbVariety
pkgDb InstallLocation
installLoc
    | Version
version Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
installVer = Version -> Version -> Allowed
WrongVersion Version
version Version
installVer
    | Bool
otherwise = Allowed
Allowed
  -- Check if an installed package is allowed if it is not found in the

  -- sourceMap.

  checkNotFound :: Allowed
checkNotFound = case PackageDbVariety
pkgDb of
    -- The sourceMap has nothing to say about this global package, so we can use

    -- it.

    PackageDbVariety
GlobalDb -> Allowed
Allowed
    PackageDbVariety
ExtraDb -> Allowed
Allowed
    -- For non-global packages, don't include unknown packages.

    -- See: https://github.com/commercialhaskell/stack/issues/292

    PackageDbVariety
WriteOnlyDb -> Allowed
UnknownPkg
    PackageDbVariety
MutableDb -> Allowed
UnknownPkg

-- | Type representing certain information about an installed package.

data LoadHelper = LoadHelper
  { LoadHelper -> GhcPkgId
ghcPkgId :: !GhcPkgId
    -- ^ The package's id.

  , LoadHelper -> Maybe SublibDump
subLibDump :: !(Maybe SublibDump)
  , LoadHelper -> [GhcPkgId]
depsGhcPkgId :: ![GhcPkgId]
    -- ^ Unless the package's name is that of a 'wired-in' package, a list of

    -- the ids of the installed packages that are the package's dependencies.

  , LoadHelper -> (PackageName, (InstallLocation, Installed))
pair :: !(PackageName, (InstallLocation, Installed))
    -- ^ A pair of (a) the package's name and (b) a pair of the relevant

    -- database (write-only or mutable) and information about the library

    -- installed.

  }
  deriving Int -> LoadHelper -> ShowS
[LoadHelper] -> ShowS
LoadHelper -> String
(Int -> LoadHelper -> ShowS)
-> (LoadHelper -> String)
-> ([LoadHelper] -> ShowS)
-> Show LoadHelper
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LoadHelper -> ShowS
showsPrec :: Int -> LoadHelper -> ShowS
$cshow :: LoadHelper -> String
show :: LoadHelper -> String
$cshowList :: [LoadHelper] -> ShowS
showList :: [LoadHelper] -> ShowS
Show

toLoadHelper :: ActualCompiler -> PackageDbVariety -> DumpPackage -> LoadHelper
toLoadHelper :: ActualCompiler -> PackageDbVariety -> DumpPackage -> LoadHelper
toLoadHelper ActualCompiler
compiler PackageDbVariety
pkgDb DumpPackage
dp = LoadHelper
  { GhcPkgId
ghcPkgId :: GhcPkgId
ghcPkgId :: GhcPkgId
ghcPkgId
  , [GhcPkgId]
depsGhcPkgId :: [GhcPkgId]
depsGhcPkgId :: [GhcPkgId]
depsGhcPkgId
  , subLibDump :: Maybe SublibDump
subLibDump = DumpPackage
dp.sublib
  , (PackageName, (InstallLocation, Installed))
pair :: (PackageName, (InstallLocation, Installed))
pair :: (PackageName, (InstallLocation, Installed))
pair
  }
 where
  ghcPkgId :: GhcPkgId
ghcPkgId = DumpPackage
dp.ghcPkgId
  ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
_) = DumpPackage
dp.packageIdent
  depsGhcPkgId :: [GhcPkgId]
depsGhcPkgId =
    -- We always want to consider the wired in packages as having all of their

    -- dependencies installed, since we have no ability to reinstall them. This

    -- is especially important for using different minor versions of GHC, where

    -- the dependencies of wired-in packages may change slightly and therefore

    -- not match the snapshot.

    if PackageName
name PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` ActualCompiler -> Set PackageName
wiredInPackages ActualCompiler
compiler
      then []
      else DumpPackage
dp.depends
  installedLibInfo :: InstalledLibraryInfo
installedLibInfo = GhcPkgId
-> Maybe (Either License License)
-> Map StackUnqualCompName GhcPkgId
-> InstalledLibraryInfo
InstalledLibraryInfo GhcPkgId
ghcPkgId (License -> Either License License
forall a b. b -> Either a b
Right (License -> Either License License)
-> Maybe License -> Maybe (Either License License)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DumpPackage
dp.license) Map StackUnqualCompName GhcPkgId
forall a. Monoid a => a
mempty

  toInstallLocation :: PackageDbVariety -> InstallLocation
  toInstallLocation :: PackageDbVariety -> InstallLocation
toInstallLocation PackageDbVariety
GlobalDb = InstallLocation
Snap
  toInstallLocation PackageDbVariety
ExtraDb = InstallLocation
Snap
  toInstallLocation PackageDbVariety
WriteOnlyDb = InstallLocation
Snap
  toInstallLocation PackageDbVariety
MutableDb = InstallLocation
Local

  pair :: (PackageName, (InstallLocation, Installed))
pair = (PackageName
name, (PackageDbVariety -> InstallLocation
toInstallLocation PackageDbVariety
pkgDb, PackageIdentifier -> InstalledLibraryInfo -> Installed
Library PackageIdentifier
ident InstalledLibraryInfo
installedLibInfo))

-- | This is where sublibraries and main libraries are assembled into a single

-- entity Installed package, where all ghcPkgId live.

gatherAndTransformSubLoadHelper ::
     LoadHelper
  -> Map PackageName (InstallLocation, Installed)
  -> Map PackageName (InstallLocation, Installed)
gatherAndTransformSubLoadHelper :: LoadHelper -> InstalledMap -> InstalledMap
gatherAndTransformSubLoadHelper LoadHelper
lh =
  ((InstallLocation, Installed)
 -> (InstallLocation, Installed) -> (InstallLocation, Installed))
-> PackageName
-> (InstallLocation, Installed)
-> InstalledMap
-> InstalledMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (InstallLocation, Installed)
-> (InstallLocation, Installed) -> (InstallLocation, Installed)
onPreviousLoadHelper PackageName
key (InstallLocation, Installed)
value
 where
  -- Here we assume that both have the same location which already was a prior

  -- assumption in Stack.

  onPreviousLoadHelper :: (InstallLocation, Installed)
-> (InstallLocation, Installed) -> (InstallLocation, Installed)
onPreviousLoadHelper
      (InstallLocation
pLoc, Library PackageIdentifier
pn InstalledLibraryInfo
incomingLibInfo)
      (InstallLocation
_, Library PackageIdentifier
_ InstalledLibraryInfo
existingLibInfo)
    = ( InstallLocation
pLoc
      , PackageIdentifier -> InstalledLibraryInfo -> Installed
Library PackageIdentifier
pn InstalledLibraryInfo
existingLibInfo
          { subLib = Map.union
              incomingLibInfo.subLib
              existingLibInfo.subLib
          , ghcPkgId = if isJust lh.subLibDump
                      then existingLibInfo.ghcPkgId
                      else incomingLibInfo.ghcPkgId
          }
      )
  onPreviousLoadHelper (InstallLocation, Installed)
newVal (InstallLocation, Installed)
_oldVal = (InstallLocation, Installed)
newVal
  (PackageName
key, (InstallLocation, Installed)
value) = case LoadHelper
lh.subLibDump of
    Maybe SublibDump
Nothing -> (PackageName
rawPackageName, (InstallLocation, Installed)
rawValue)
    Just SublibDump
sd -> (SublibDump
sd.packageName, SublibDump -> Installed -> Installed
updateAsSublib SublibDump
sd (Installed -> Installed)
-> (InstallLocation, Installed) -> (InstallLocation, Installed)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (InstallLocation, Installed)
rawValue)
  (PackageName
rawPackageName, (InstallLocation, Installed)
rawValue) = LoadHelper
lh.pair
  updateAsSublib :: SublibDump -> Installed -> Installed
updateAsSublib
      SublibDump
sd
      (Library (PackageIdentifier PackageName
_sublibMungedPackageName Version
version) InstalledLibraryInfo
libInfo)
    = PackageIdentifier -> InstalledLibraryInfo -> Installed
Library
        (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
key Version
version)
        InstalledLibraryInfo
libInfo { subLib = Map.singleton sd.libraryName libInfo.ghcPkgId }
  updateAsSublib SublibDump
_ Installed
v = Installed
v