{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Stack.Build.Installed
( InstalledMap
, Installed (..)
, GetInstalledOpts (..)
, getInstalled
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Catch (MonadCatch, MonadMask)
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, asks)
import Control.Monad.Trans.Resource
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Function
import qualified Data.HashSet as HashSet
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import qualified Data.Map.Strict as Map
import Data.Maybe
import Network.HTTP.Client.Conduit (HasHttpManager)
import Path
import Prelude hiding (FilePath, writeFile)
import Stack.Build.Cache
import Stack.Types.Build
import Stack.Constants
import Stack.GhcPkg
import Stack.PackageDump
import Stack.Types
import Stack.Types.Internal
type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,HasEnvConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,MonadMask m,HasLogLevel env)
data LoadHelper = LoadHelper
{ lhId :: !GhcPkgId
, lhDeps :: ![GhcPkgId]
, lhPair :: !(PackageName, (Version, InstallLocation, Installed))
}
deriving Show
type InstalledMap = Map PackageName (Version, InstallLocation, Installed)
data GetInstalledOpts = GetInstalledOpts
{ getInstalledProfiling :: !Bool
, getInstalledHaddock :: !Bool
}
getInstalled :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Map PackageName pii
-> m ( InstalledMap
, [DumpPackage () ()]
, Map GhcPkgId PackageIdentifier
)
getInstalled menv opts sourceMap = do
snapDBPath <- packageDatabaseDeps
localDBPath <- packageDatabaseLocal
bconfig <- asks getBuildConfig
mcache <-
if getInstalledProfiling opts || getInstalledHaddock opts
then liftM Just $ loadInstalledCache $ configInstalledCache bconfig
else return Nothing
let loadDatabase' = loadDatabase menv opts mcache sourceMap
(installedLibs0, globalInstalled) <- loadDatabase' Nothing []
(installedLibs1, _snapInstalled) <-
loadDatabase' (Just (Snap, snapDBPath)) installedLibs0
(installedLibs2, localInstalled) <-
loadDatabase' (Just (Local, localDBPath)) installedLibs1
let installedLibs = M.fromList $ map lhPair installedLibs2
case mcache of
Nothing -> return ()
Just pcache -> saveInstalledCache (configInstalledCache bconfig) pcache
let exesToSM loc = Map.unions . map (exeToSM loc)
exeToSM loc (PackageIdentifier name version) =
case Map.lookup name sourceMap of
Nothing -> m
Just pii
| version /= piiVersion pii || loc /= piiLocation pii -> Map.empty
| otherwise -> m
where
m = Map.singleton name (version, loc, Executable $ PackageIdentifier name version)
exesSnap <- getInstalledExes Snap
exesLocal <- getInstalledExes Local
let installedMap = Map.unions
[ exesToSM Local exesLocal
, exesToSM Snap exesSnap
, installedLibs
]
return ( installedMap
, globalInstalled
, Map.fromList $ map (dpGhcPkgId &&& dpPackageIdent) localInstalled
)
loadDatabase :: (M env m, PackageInstallInfo pii)
=> EnvOverride
-> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName pii
-> Maybe (InstallLocation, Path Abs Dir)
-> [LoadHelper]
-> m ([LoadHelper], [DumpPackage () ()])
loadDatabase menv opts mcache sourceMap mdb lhs0 = do
wc <- getWhichCompiler
(lhs1, dps) <- ghcPkgDump menv wc (fmap snd mdb)
$ conduitDumpPackage =$ sink
let lhs = pruneDeps
id
lhId
lhDeps
const
(lhs0 ++ lhs1)
return (map (\lh -> lh { lhDeps = [] }) $ Map.elems lhs, dps)
where
conduitProfilingCache =
case mcache of
Just cache | getInstalledProfiling opts -> addProfiling cache
_ -> CL.map (\dp -> dp { dpProfiling = False })
conduitHaddockCache =
case mcache of
Just cache | getInstalledHaddock opts -> addHaddock cache
_ -> CL.map (\dp -> dp { dpHaddock = False })
sinkDP = conduitProfilingCache
=$ conduitHaddockCache
=$ CL.mapMaybe (isAllowed opts mcache sourceMap (fmap fst mdb))
=$ CL.consume
sink = getZipSink $ (,)
<$> ZipSink sinkDP
<*> ZipSink CL.consume
isAllowed :: PackageInstallInfo pii
=> GetInstalledOpts
-> Maybe InstalledCache
-> Map PackageName pii
-> Maybe InstallLocation
-> DumpPackage Bool Bool
-> Maybe LoadHelper
isAllowed opts mcache sourceMap mloc dp
| getInstalledProfiling opts && isJust mcache && not (dpProfiling dp) = Nothing
| getInstalledHaddock opts && isJust mcache && not (dpHaddock dp) = Nothing
| toInclude = Just LoadHelper
{ lhId = gid
, lhDeps =
if name `HashSet.member` wiredInPackages
then []
else dpDepends dp
, lhPair = (name, (version, fromMaybe Snap mloc, Library ident gid))
}
| otherwise = Nothing
where
toInclude =
case Map.lookup name sourceMap of
Nothing ->
case mloc of
Nothing -> True
Just _ -> False
Just pii ->
version == piiVersion pii
&& checkLocation (piiLocation pii)
checkLocation Snap = mloc /= Just Local
checkLocation Local = mloc == Just Local
gid = dpGhcPkgId dp
ident@(PackageIdentifier name version) = dpPackageIdent dp