{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
module BuildEnv.Build
(
computePlan
, fetchPlan
, buildPlan
, CabalFilesContents(..)
, cabalFileContentsFromPackages
, cabalProjectContentsFromPackages
) where
import Control.Exception
( IOException, catch )
import Control.Monad
( when )
import Control.Monad.Fix
( MonadFix(mfix) )
import Data.Char
( isSpace )
import Data.Foldable
( for_, toList )
import Data.IORef
( newIORef )
import Data.Maybe
( catMaybes, mapMaybe, maybeToList, isNothing )
import Data.String
( IsString )
import Data.Traversable
( for )
import Data.Version
( Version )
import Control.Concurrent.Async
( async, wait )
import qualified Data.ByteString.Lazy as Lazy.ByteString
( readFile )
import qualified Data.Graph as Graph
( dfs, graphFromEdges, reverseTopSort )
import Data.Map.Strict
( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Map.Lazy as Lazy
( Map )
import qualified Data.Map.Lazy as Lazy.Map
import Data.Set
( Set )
import qualified Data.Set as Set
( elems, fromList, member, toList )
import System.Directory
( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, exeExtension, listDirectory, removeDirectoryRecursive
)
import System.FilePath
( (</>), (<.>)
, isAbsolute
)
import qualified System.Process as Process
( readProcess )
import Data.Text
( Text )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
( writeFile )
import BuildEnv.BuildOne
( PkgDbDirs(..)
, getPkgDbDirsForPrep, getPkgDbDirsForBuild, getPkgDir
, setupPackage, buildUnit )
import BuildEnv.CabalPlan
import qualified BuildEnv.CabalPlan as Configured
( ConfiguredUnit(..) )
import BuildEnv.Config
import BuildEnv.Script
( BuildScript, ScriptOutput(..), ScriptConfig(..)
, emptyBuildScript
, executeBuildScript, script
, createDir, logMessage
)
import BuildEnv.Utils
( ProgPath(..), CallProcess(..), callProcessInIO, withTempDir
, AbstractSem(..), noSem, newAbstractSem
)
dummyPackageName :: IsString str => str
dummyPackageName :: forall str. IsString str => str
dummyPackageName = str
"build-env-dummy-package"
dummyUnitId :: UnitId
dummyUnitId :: UnitId
dummyUnitId = Text -> UnitId
UnitId forall a b. (a -> b) -> a -> b
$ forall str. IsString str => str
dummyPackageName forall a. Semigroup a => a -> a -> a
<> Text
"-0-inplace"
computePlan :: TempDirPermanence
-> Verbosity
-> Compiler
-> Cabal
-> CabalFilesContents
-> IO CabalPlanBinary
computePlan :: TempDirPermanence
-> Verbosity
-> Compiler
-> Cabal
-> CabalFilesContents
-> IO CabalPlanBinary
computePlan TempDirPermanence
delTemp Verbosity
verbosity Compiler
comp Cabal
cabal ( CabalFilesContents { Text
cabalContents :: CabalFilesContents -> Text
cabalContents :: Text
cabalContents, Text
projectContents :: CabalFilesContents -> Text
projectContents :: Text
projectContents } ) =
forall a. TempDirPermanence -> [Char] -> ([Char] -> IO a) -> IO a
withTempDir TempDirPermanence
delTemp [Char]
"build" \ [Char]
dir -> do
Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Text
"Computing plan in build directory " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
dir
[Char] -> Text -> IO ()
Text.writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"cabal" [Char] -> [Char] -> [Char]
<.> [Char]
"project") Text
projectContents
[Char] -> Text -> IO ()
Text.writeFile ([Char]
dir [Char] -> [Char] -> [Char]
</> forall str. IsString str => str
dummyPackageName [Char] -> [Char] -> [Char]
<.> [Char]
"cabal") Text
cabalContents
let cabalBuildArgs :: [[Char]]
cabalBuildArgs =
Cabal -> [[Char]]
globalCabalArgs Cabal
cabal forall a. [a] -> [a] -> [a]
++
[ [Char]
"build"
, [Char]
"--dry-run"
, [Char]
"--with-compiler", Compiler -> [Char]
ghcPath Compiler
comp
, Verbosity -> [Char]
cabalVerbosity Verbosity
verbosity ]
Verbosity -> Text -> IO ()
debugMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
[Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ Text
"cabal" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ( (Text
" " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ) [[Char]]
cabalBuildArgs
HasCallStack => Maybe Counter -> CallProcess -> IO ()
callProcessInIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
CP { cwd :: [Char]
cwd = [Char]
dir
, prog :: ProgPath
prog = [Char] -> ProgPath
AbsPath forall a b. (a -> b) -> a -> b
$ Cabal -> [Char]
cabalPath Cabal
cabal
, args :: [[Char]]
args = [[Char]]
cabalBuildArgs
, extraPATH :: [[Char]]
extraPATH = []
, extraEnvVars :: [([Char], [Char])]
extraEnvVars = []
, logBasePath :: Maybe [Char]
logBasePath = forall a. Maybe a
Nothing
, sem :: AbstractSem
sem = AbstractSem
noSem }
let planPath :: [Char]
planPath = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"dist-newstyle" [Char] -> [Char] -> [Char]
</> [Char]
"cache" [Char] -> [Char] -> [Char]
</> [Char]
"plan.json"
ByteString -> CabalPlanBinary
CabalPlanBinary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO ByteString
Lazy.ByteString.readFile [Char]
planPath
cabalProjectContentsFromPackages :: FilePath -> UnitSpecs -> PkgSpecs -> AllowNewer -> Text
cabalProjectContentsFromPackages :: [Char] -> UnitSpecs -> PkgSpecs -> AllowNewer -> Text
cabalProjectContentsFromPackages [Char]
workDir UnitSpecs
units PkgSpecs
pins (AllowNewer Set (Text, Text)
allowNewer) =
Text
packages
forall a. Semigroup a => a -> a -> a
<> Text
allowNewers
forall a. Semigroup a => a -> a -> a
<> Text
flagSpecs
forall a. Semigroup a => a -> a -> a
<> Text
constraints
where
packages :: Text
packages
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map PkgName [Char]
localPkgs
= Text
"packages: .\n\n"
| Bool
otherwise
= Text -> [Text] -> Text
Text.intercalate Text
",\n "
( Text
"packages: ." forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ( [Char] -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
makeAbsolute ) ( forall k a. Map k a -> [a]
Map.elems Map PkgName [Char]
localPkgs ) )
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
makeAbsolute :: FilePath -> FilePath
makeAbsolute :: [Char] -> [Char]
makeAbsolute [Char]
fp
| [Char] -> Bool
isAbsolute [Char]
fp
= [Char]
fp
| Bool
otherwise
= [Char]
workDir [Char] -> [Char] -> [Char]
</> [Char]
fp
isLocal :: (PkgSrc, PkgSpec, Set ComponentName) -> Maybe FilePath
isLocal :: (PkgSrc, PkgSpec, Set ComponentName) -> Maybe [Char]
isLocal ( Local [Char]
src, PkgSpec
_, Set ComponentName
_ ) = forall a. a -> Maybe a
Just [Char]
src
isLocal (PkgSrc, PkgSpec, Set ComponentName)
_ = forall a. Maybe a
Nothing
localPkgs :: Map PkgName [Char]
localPkgs = forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (PkgSrc, PkgSpec, Set ComponentName) -> Maybe [Char]
isLocal UnitSpecs
units
allPkgs :: PkgSpecs
allPkgs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( \ ( PkgSrc
_, PkgSpec
spec, Set ComponentName
_ ) -> PkgSpec
spec ) UnitSpecs
units
PkgSpecs -> PkgSpecs -> PkgSpecs
`unionPkgSpecsOverriding`
PkgSpecs
pins
constraints :: Text
constraints = [Text] -> Text
Text.unlines
[ [Text] -> Text
Text.unwords [Text
"constraints:", PkgName -> Text
unPkgName PkgName
nm, Text
cts]
| (PkgName
nm, PkgSpec
ps) <- forall k a. Map k a -> [(k, a)]
Map.assocs PkgSpecs
allPkgs
, Constraints Text
cts <- forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ PkgSpec -> Maybe Constraints
psConstraints PkgSpec
ps
, Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isSpace Text
cts)
]
allowNewers :: Text
allowNewers
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (Text, Text)
allowNewer
= Text
""
| Bool
otherwise
= [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
Text
"allow-newer:" forall a. a -> [a] -> [a]
:
[ Text
" " forall a. Semigroup a => a -> a -> a
<> Text
p forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
q forall a. Semigroup a => a -> a -> a
<> Text
","
| (Text
p,Text
q) <- forall a. Set a -> [a]
Set.elems Set (Text, Text)
allowNewer ]
flagSpecs :: Text
flagSpecs = [Text] -> Text
Text.unlines
[ [Text] -> Text
Text.unlines
[ Text
"package " forall a. Semigroup a => a -> a -> a
<> PkgName -> Text
unPkgName PkgName
nm
, Text
" flags: " forall a. Semigroup a => a -> a -> a
<> FlagSpec -> Text
showFlagSpec (PkgSpec -> FlagSpec
psFlags PkgSpec
ps)
]
| (PkgName
nm, PkgSpec
ps) <- forall k a. Map k a -> [(k, a)]
Map.assocs PkgSpecs
allPkgs
, let flags :: FlagSpec
flags = PkgSpec -> FlagSpec
psFlags PkgSpec
ps
, Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FlagSpec -> Bool
flagSpecIsEmpty FlagSpec
flags
]
cabalFileContentsFromPackages :: UnitSpecs -> Text
cabalFileContentsFromPackages :: UnitSpecs -> Text
cabalFileContentsFromPackages UnitSpecs
units =
[Text] -> Text
Text.unlines
[ Text
"cabal-version: 3.0"
, Text
"name: " forall a. Semigroup a => a -> a -> a
<> forall str. IsString str => str
dummyPackageName
, Text
"version: 0"
, Text
"library" ]
forall a. Semigroup a => a -> a -> a
<> Text
libDepends
forall a. Semigroup a => a -> a -> a
<> Text
exeDepends
where
isLib :: ComponentName -> Maybe Text
isLib (ComponentName ComponentType
ty Text
lib) = case ComponentType
ty of { ComponentType
Lib -> forall a. a -> Maybe a
Just Text
lib; ComponentType
_ -> forall a. Maybe a
Nothing }
isExe :: ComponentName -> Maybe Text
isExe (ComponentName ComponentType
ty Text
exe) = case ComponentType
ty of { ComponentType
Exe -> forall a. a -> Maybe a
Just Text
exe; ComponentType
_ -> forall a. Maybe a
Nothing }
allLibs :: [(PkgName, [Text])]
allLibs = [ (PkgName
pkg, [Text]
libsInPkg)
| (PkgName
pkg, (PkgSrc
_, PkgSpec
_, Set ComponentName
comps)) <- forall k a. Map k a -> [(k, a)]
Map.assocs UnitSpecs
units
, let libsInPkg :: [Text]
libsInPkg = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ComponentName -> Maybe Text
isLib forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set ComponentName
comps
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
libsInPkg) ]
allExes :: [(PkgName, [Text])]
allExes = [ (PkgName
pkg, [Text]
exesInPkg)
| (PkgName
pkg, (PkgSrc
_, PkgSpec
_, Set ComponentName
comps)) <- forall k a. Map k a -> [(k, a)]
Map.assocs UnitSpecs
units
, let exesInPkg :: [Text]
exesInPkg = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ComponentName -> Maybe Text
isExe forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set ComponentName
comps
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
exesInPkg) ]
dep :: PkgName -> [Text] -> Text
dep (PkgName Text
pkg) [Text
comp]
= Text
pkg forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
comp
dep (PkgName Text
pkg) [Text]
comps
= Text
pkg forall a. Semigroup a => a -> a -> a
<> Text
":{" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
comps forall a. Semigroup a => a -> a -> a
<> Text
"}"
libDepends :: Text
libDepends
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PkgName, [Text])]
allLibs
= Text
""
| Bool
otherwise
= Text
"\n build-depends:\n"
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
",\n"
[ Text
" " forall a. Semigroup a => a -> a -> a
<> PkgName -> [Text] -> Text
dep PkgName
pkg [Text]
libs
| (PkgName
pkg, [Text]
libs) <- [(PkgName, [Text])]
allLibs ]
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
exeDepends :: Text
exeDepends
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PkgName, [Text])]
allExes
= Text
""
| Bool
otherwise
= Text
"\n build-tool-depends:\n"
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
",\n"
[ Text
" " forall a. Semigroup a => a -> a -> a
<> PkgName -> [Text] -> Text
dep PkgName
pkg [Text]
exes
| (PkgName
pkg, [Text]
exes) <- [(PkgName, [Text])]
allExes ]
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
data CabalFilesContents
= CabalFilesContents
{ CabalFilesContents -> Text
cabalContents :: !Text
, CabalFilesContents -> Text
projectContents :: !Text
}
fetchPlan :: Verbosity
-> Cabal
-> FilePath
-> CabalPlan
-> IO ()
fetchPlan :: Verbosity -> Cabal -> [Char] -> CabalPlan -> IO ()
fetchPlan Verbosity
verbosity Cabal
cabal [Char]
fetchDir CabalPlan
cabalPlan =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Set (PkgName, Version)
pkgs \ (PkgName
pkgNm, Version
pkgVer) -> do
let nameVersion :: Text
nameVersion = PkgName -> Version -> Text
pkgNameVersion PkgName
pkgNm Version
pkgVer
nmVerStr :: [Char]
nmVerStr = Text -> [Char]
Text.unpack Text
nameVersion
Bool
pkgDirExists <- [Char] -> IO Bool
doesDirectoryExist ([Char]
fetchDir [Char] -> [Char] -> [Char]
</> [Char]
nmVerStr)
if Bool
pkgDirExists
then Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Text
"NOT fetching " forall a. Semigroup a => a -> a -> a
<> Text
nameVersion
else Verbosity -> Cabal -> [Char] -> [Char] -> IO ()
cabalFetch Verbosity
verbosity Cabal
cabal [Char]
fetchDir [Char]
nmVerStr
where
pkgs :: Set (PkgName, Version)
pkgs :: Set (PkgName, Version)
pkgs = forall a. Ord a => [a] -> Set a
Set.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PlanUnit -> Maybe (PkgName, Version)
remotePkgNameVersion
forall a b. (a -> b) -> a -> b
$ CabalPlan -> [PlanUnit]
planUnits CabalPlan
cabalPlan
remotePkgNameVersion :: PlanUnit -> Maybe (PkgName, Version)
remotePkgNameVersion :: PlanUnit -> Maybe (PkgName, Version)
remotePkgNameVersion = \case
PU_Configured ( ConfiguredUnit { $sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName = PkgName
nm, $sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion = Version
ver, $sel:puPkgSrc:ConfiguredUnit :: ConfiguredUnit -> PkgSrc
puPkgSrc = PkgSrc
src } )
| PkgSrc
Remote <- PkgSrc
src
-> forall a. a -> Maybe a
Just (PkgName
nm, Version
ver)
PlanUnit
_ -> forall a. Maybe a
Nothing
cabalFetch :: Verbosity -> Cabal -> FilePath -> String -> IO ()
cabalFetch :: Verbosity -> Cabal -> [Char] -> [Char] -> IO ()
cabalFetch Verbosity
verbosity Cabal
cabal [Char]
root [Char]
pkgNmVer = do
Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Text
"Fetching " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
pkgNmVer
let args :: [[Char]]
args = Cabal -> [[Char]]
globalCabalArgs Cabal
cabal forall a. [a] -> [a] -> [a]
++
[ [Char]
"get"
, [Char]
pkgNmVer
, Verbosity -> [Char]
cabalVerbosity Verbosity
verbosity ]
HasCallStack => Maybe Counter -> CallProcess -> IO ()
callProcessInIO forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
CP { cwd :: [Char]
cwd = [Char]
root
, prog :: ProgPath
prog = [Char] -> ProgPath
AbsPath forall a b. (a -> b) -> a -> b
$ Cabal -> [Char]
cabalPath Cabal
cabal
, [[Char]]
args :: [[Char]]
args :: [[Char]]
args
, extraPATH :: [[Char]]
extraPATH = []
, extraEnvVars :: [([Char], [Char])]
extraEnvVars = []
, logBasePath :: Maybe [Char]
logBasePath = forall a. Maybe a
Nothing
, sem :: AbstractSem
sem = AbstractSem
noSem }
buildPlan :: Verbosity
-> FilePath
-> Paths ForPrep
-> Paths ForBuild
-> BuildStrategy
-> Bool
-> Maybe [ UnitId ]
-> ( ConfiguredUnit -> UnitArgs )
-> CabalPlan
-> IO ()
buildPlan :: Verbosity
-> [Char]
-> Paths 'ForPrep
-> Paths 'ForBuild
-> BuildStrategy
-> Bool
-> Maybe [UnitId]
-> (ConfiguredUnit -> UnitArgs)
-> CabalPlan
-> IO ()
buildPlan Verbosity
verbosity [Char]
workDir
pathsForPrep :: Paths 'ForPrep
pathsForPrep@( Paths { $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = BuildPaths 'ForPrep
buildPathsForPrep })
Paths 'ForBuild
pathsForBuild
BuildStrategy
buildStrat
Bool
resumeBuild
Maybe [UnitId]
mbOnlyBuildDepsOf
ConfiguredUnit -> UnitArgs
userUnitArgs
CabalPlan
cabalPlan
= do
let paths :: BuildPaths 'ForBuild
paths@( BuildPaths { Compiler
$sel:compiler:BuildPaths :: BuildPaths 'ForBuild -> Compiler
compiler :: Compiler
compiler, [Char]
$sel:prefix:BuildPaths :: BuildPaths 'ForBuild -> [Char]
prefix :: [Char]
prefix, [Char]
$sel:destDir:BuildPaths :: BuildPaths 'ForBuild -> [Char]
destDir :: [Char]
destDir, [Char]
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> [Char]
installDir :: [Char]
installDir } )
= forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths Paths 'ForBuild
pathsForBuild
let pkgDbDirsForPrep :: PkgDbDirs 'ForPrep
pkgDbDirsForPrep@( PkgDbDirsForPrep { [Char]
$sel:tempPkgDbDir:PkgDbDirsForPrep :: PkgDbDirs 'ForPrep -> [Char]
tempPkgDbDir :: [Char]
tempPkgDbDir } )
= Paths 'ForPrep -> PkgDbDirs 'ForPrep
getPkgDbDirsForPrep Paths 'ForPrep
pathsForPrep
Bool
tempPkgDbExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
tempPkgDbDir
if
| Bool
resumeBuild Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tempPkgDbExists
-> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$
[Char]
"Cannot resume build: no package database at " forall a. Semigroup a => a -> a -> a
<> [Char]
tempPkgDbDir
| Bool -> Bool
not Bool
resumeBuild
-> do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tempPkgDbExists forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
removeDirectoryRecursive [Char]
tempPkgDbDir
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \ ( IOException
_ :: IOException ) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
tempPkgDbDir
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return ()
pkgDbDirsForBuild :: PkgDbDirs 'ForBuild
pkgDbDirsForBuild@( PkgDbDirsForBuild { [Char]
$sel:finalPkgDbDir:PkgDbDirsForBuild :: PkgDbDirs 'ForBuild -> [Char]
finalPkgDbDir :: [Char]
finalPkgDbDir } )
<- Paths 'ForBuild -> IO (PkgDbDirs 'ForBuild)
getPkgDbDirsForBuild Paths 'ForBuild
pathsForBuild
Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
[Text] -> Text
Text.unlines [ Text
"Directory structure:"
, Text
" prefix: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
prefix
, Text
" destDir: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
destDir
, Text
" installDir: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
installDir ]
Maybe (Set UnitId)
mbAlreadyBuilt <-
if Bool
resumeBuild
then let prepComp :: Compiler
prepComp = BuildPaths 'ForPrep -> Compiler
compilerForPrep BuildPaths 'ForPrep
buildPathsForPrep
in forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Compiler
-> BuildPaths 'ForPrep
-> PkgDbDirs 'ForPrep
-> Map UnitId PlanUnit
-> IO (Set UnitId)
getInstalledUnits Verbosity
verbosity Compiler
prepComp BuildPaths 'ForPrep
buildPathsForPrep PkgDbDirs 'ForPrep
pkgDbDirsForPrep Map UnitId PlanUnit
fullDepMap
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
let
unitsToBuild :: [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild :: [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild
= [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
tagUnits forall a b. (a -> b) -> a -> b
$ Maybe (Set UnitId)
-> Maybe [UnitId] -> CabalPlan -> [ConfiguredUnit]
sortPlan Maybe (Set UnitId)
mbAlreadyBuilt Maybe [UnitId]
mbOnlyBuildDepsOf CabalPlan
cabalPlan
nbUnitsToBuild :: Word
nbUnitsToBuild :: Word
nbUnitsToBuild = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild
pkgMap :: Map (PkgName, Version) ConfiguredUnit
pkgMap :: Map (PkgName, Version) ConfiguredUnit
pkgMap = forall k a. Ord k => [(k, a)] -> Map k a
Lazy.Map.fromList
[ ((PkgName
puPkgName, Version
puVersion), ConfiguredUnit
cu)
| ( cu :: ConfiguredUnit
cu@( ConfiguredUnit { PkgName
puPkgName :: PkgName
$sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName, Version
puVersion :: Version
$sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion } ), Maybe UnitId
didSetup ) <- [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild
, forall a. Maybe a -> Bool
isNothing Maybe UnitId
didSetup ]
preparation :: BuildScript
preparation :: BuildScript
preparation = do
Verbosity -> Verbosity -> [Char] -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose forall a b. (a -> b) -> a -> b
$
[Char]
"Creating final package database at " forall a. Semigroup a => a -> a -> a
<> [Char]
finalPkgDbDir
[Char] -> BuildScript
createDir [Char]
finalPkgDbDir
Verbosity -> Verbosity -> [Char] -> BuildScript
logMessage Verbosity
verbosity Verbosity
Debug forall a b. (a -> b) -> a -> b
$ [Char]
"Packages:\n" forall a. Semigroup a => a -> a -> a
<>
[[Char]] -> [Char]
unlines
[ [Char]
" - " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack (PkgName -> Version -> Text
pkgNameVersion PkgName
nm Version
ver)
| (PkgName
nm, Version
ver) <- forall k a. Map k a -> [k]
Map.keys Map (PkgName, Version) ConfiguredUnit
pkgMap ]
Verbosity -> Verbosity -> [Char] -> BuildScript
logMessage Verbosity
verbosity Verbosity
Debug forall a b. (a -> b) -> a -> b
$ [Char]
"Units:\n" forall a. Semigroup a => a -> a -> a
<>
[[Char]] -> [Char]
unlines
[ [Char]
" - " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack Text
pkgNm forall a. Semigroup a => a -> a -> a
<> [Char]
":" forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack (ComponentName -> Text
cabalComponent ComponentName
compName)
| ( ConfiguredUnit
{ $sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName = PkgName Text
pkgNm
, $sel:puComponentName:ConfiguredUnit :: ConfiguredUnit -> ComponentName
puComponentName = ComponentName
compName }
, Maybe UnitId
_ ) <- [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild
]
Verbosity -> Verbosity -> [Char] -> BuildScript
logMessage Verbosity
verbosity Verbosity
Normal forall a b. (a -> b) -> a -> b
$ [Char]
"=== BUILD START ==="
unitSetupScript :: ConfiguredUnit -> IO BuildScript
unitSetupScript :: ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
pu = do
let pkgDirForPrep :: PkgDir 'ForPrep
pkgDirForPrep = forall (use :: PathUsability).
[Char] -> Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir [Char]
workDir Paths 'ForPrep
pathsForPrep ConfiguredUnit
pu
pkgDirForBuild :: PkgDir 'ForBuild
pkgDirForBuild = forall (use :: PathUsability).
[Char] -> Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir [Char]
workDir Paths 'ForBuild
pathsForBuild ConfiguredUnit
pu
Verbosity
-> Compiler
-> BuildPaths 'ForBuild
-> PkgDbDirs 'ForBuild
-> PkgDir 'ForPrep
-> PkgDir 'ForBuild
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> IO BuildScript
setupPackage Verbosity
verbosity Compiler
compiler
BuildPaths 'ForBuild
paths PkgDbDirs 'ForBuild
pkgDbDirsForBuild PkgDir 'ForPrep
pkgDirForPrep PkgDir 'ForBuild
pkgDirForBuild
Map UnitId PlanUnit
fullDepMap ConfiguredUnit
pu
unitBuildScript :: ConfiguredUnit -> BuildScript
unitBuildScript :: ConfiguredUnit -> BuildScript
unitBuildScript ConfiguredUnit
pu =
let pkgDirForBuild :: PkgDir 'ForBuild
pkgDirForBuild = forall (use :: PathUsability).
[Char] -> Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir [Char]
workDir Paths 'ForBuild
pathsForBuild ConfiguredUnit
pu
in Verbosity
-> Compiler
-> BuildPaths 'ForBuild
-> PkgDbDirs 'ForBuild
-> PkgDir 'ForBuild
-> UnitArgs
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> BuildScript
buildUnit Verbosity
verbosity Compiler
compiler
BuildPaths 'ForBuild
paths PkgDbDirs 'ForBuild
pkgDbDirsForBuild PkgDir 'ForBuild
pkgDirForBuild
(ConfiguredUnit -> UnitArgs
userUnitArgs ConfiguredUnit
pu)
Map UnitId PlanUnit
fullDepMap ConfiguredUnit
pu
finish :: BuildScript
finish :: BuildScript
finish = do
Verbosity -> Verbosity -> [Char] -> BuildScript
logMessage Verbosity
verbosity Verbosity
Normal forall a b. (a -> b) -> a -> b
$ [Char]
"=== BUILD SUCCEEDED ==="
case BuildStrategy
buildStrat of
Execute RunStrategy
runStrat -> do
IORef Word
unitsBuiltCounterRef <- forall a. a -> IO (IORef a)
newIORef Word
0
let unitsBuiltCounter :: Maybe Counter
unitsBuiltCounter
= forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
Counter { $sel:counterRef:Counter :: IORef Word
counterRef = IORef Word
unitsBuiltCounterRef
, $sel:counterMax:Counter :: Word
counterMax = Word
nbUnitsToBuild }
case RunStrategy
runStrat of
Async AsyncSem
sem -> do
Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
Text
"\nBuilding and installing units asynchronously with " forall a. Semigroup a => a -> a -> a
<> AsyncSem -> Text
semDescription AsyncSem
sem
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter BuildScript
preparation
let unitMap :: Lazy.Map UnitId (ConfiguredUnit, Maybe UnitId)
unitMap :: Map UnitId (ConfiguredUnit, Maybe UnitId)
unitMap =
forall k a. Ord k => [(k, a)] -> Map k a
Lazy.Map.fromList
[ (UnitId
puId, (ConfiguredUnit, Maybe UnitId)
pu)
| pu :: (ConfiguredUnit, Maybe UnitId)
pu@( ConfiguredUnit { UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId }, Maybe UnitId
_ ) <- [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild ]
AbstractSem { forall r. IO r -> IO r
withAbstractSem :: AbstractSem -> forall r. IO r -> IO r
withAbstractSem :: forall r. IO r -> IO r
withAbstractSem } <- AsyncSem -> IO AbstractSem
newAbstractSem AsyncSem
sem
(Map (PkgName, Version) (Async ())
_, Map UnitId (Async ())
unitAsyncs) <- forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix \ ~(Map (PkgName, Version) (Async ())
pkgAsyncs, Map UnitId (Async ())
unitAsyncs) -> do
let
doPkgSetupAsync :: ConfiguredUnit -> IO ()
doPkgSetupAsync :: ConfiguredUnit -> IO ()
doPkgSetupAsync cu :: ConfiguredUnit
cu@( ConfiguredUnit { [UnitId]
$sel:puSetupDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puSetupDepends :: [UnitId]
puSetupDepends } ) = do
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [UnitId]
puSetupDepends \ UnitId
setupDepId ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map UnitId (Async ())
unitAsyncs forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? UnitId
setupDepId) forall a. Async a -> IO a
wait
forall r. IO r -> IO r
withAbstractSem do
BuildScript
setupScript <- ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
cu
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter BuildScript
setupScript
doUnitAsync :: ( ConfiguredUnit, Maybe UnitId ) -> IO ()
doUnitAsync :: (ConfiguredUnit, Maybe UnitId) -> IO ()
doUnitAsync ( ConfiguredUnit
pu, Maybe UnitId
_didSetup ) = do
let nm :: PkgName
nm = ConfiguredUnit -> PkgName
Configured.puPkgName ConfiguredUnit
pu
ver :: Version
ver = ConfiguredUnit -> Version
Configured.puVersion ConfiguredUnit
pu
forall a. Async a -> IO a
wait forall a b. (a -> b) -> a -> b
$ Map (PkgName, Version) (Async ())
pkgAsyncs forall k a. Ord k => Map k a -> k -> a
Map.! (PkgName
nm, Version
ver)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ConfiguredUnit -> [UnitId]
unitDepends ConfiguredUnit
pu) \ UnitId
depUnitId ->
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map UnitId (Async ())
unitAsyncs forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? UnitId
depUnitId) forall a. Async a -> IO a
wait
forall r. IO r -> IO r
withAbstractSem forall a b. (a -> b) -> a -> b
$
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter forall a b. (a -> b) -> a -> b
$ ConfiguredUnit -> BuildScript
unitBuildScript ConfiguredUnit
pu
Map (PkgName, Version) (Async ())
finalPkgAsyncs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map (PkgName, Version) ConfiguredUnit
pkgMap (forall a. IO a -> IO (Async a)
async forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredUnit -> IO ()
doPkgSetupAsync)
Map UnitId (Async ())
finalUnitAsyncs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map UnitId (ConfiguredUnit, Maybe UnitId)
unitMap (forall a. IO a -> IO (Async a)
async forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfiguredUnit, Maybe UnitId) -> IO ()
doUnitAsync)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (PkgName, Version) (Async ())
finalPkgAsyncs, Map UnitId (Async ())
finalUnitAsyncs)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Async a -> IO a
wait Map UnitId (Async ())
unitAsyncs
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter BuildScript
finish
RunStrategy
TopoSort -> do
Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity Text
"\nBuilding and installing units sequentially.\n\
\NB: pass -j<N> for increased parallelism."
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter BuildScript
preparation
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild \ ( ConfiguredUnit
cu, Maybe UnitId
didSetup ) -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe UnitId
didSetup) forall a b. (a -> b) -> a -> b
$
ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
cu forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter (ConfiguredUnit -> BuildScript
unitBuildScript ConfiguredUnit
cu)
Maybe Counter -> BuildScript -> IO ()
executeBuildScript Maybe Counter
unitsBuiltCounter BuildScript
finish
Script { $sel:scriptPath:Execute :: BuildStrategy -> [Char]
scriptPath = [Char]
fp, Bool
$sel:useVariables:Execute :: BuildStrategy -> Bool
useVariables :: Bool
useVariables } -> do
let scriptConfig :: ScriptConfig
scriptConfig :: ScriptConfig
scriptConfig =
ScriptConfig { scriptOutput :: ScriptOutput
scriptOutput = Shell { Bool
useVariables :: Bool
useVariables :: Bool
useVariables }
, scriptStyle :: Style
scriptStyle = Style
hostStyle
, scriptTotal :: Maybe Word
scriptTotal = forall a. a -> Maybe a
Just Word
nbUnitsToBuild }
Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ Text
"\nWriting build scripts to " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
Text.pack [Char]
fp
[BuildScript]
buildScripts <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild \ ( ConfiguredUnit
cu, Maybe UnitId
didSetup ) -> do
BuildScript
mbSetup <- if forall a. Maybe a -> Bool
isNothing Maybe UnitId
didSetup
then ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
cu
else forall (m :: * -> *) a. Monad m => a -> m a
return BuildScript
emptyBuildScript
let build :: BuildScript
build = ConfiguredUnit -> BuildScript
unitBuildScript ConfiguredUnit
cu
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BuildScript
mbSetup forall a. Semigroup a => a -> a -> a
<> BuildScript
build
[Char] -> Text -> IO ()
Text.writeFile [Char]
fp forall a b. (a -> b) -> a -> b
$ ScriptConfig -> BuildScript -> Text
script ScriptConfig
scriptConfig forall a b. (a -> b) -> a -> b
$
BuildScript
preparation forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat [BuildScript]
buildScripts forall a. Semigroup a => a -> a -> a
<> BuildScript
finish
where
fullDepMap :: Map UnitId PlanUnit
fullDepMap :: Map UnitId PlanUnit
fullDepMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (PlanUnit -> UnitId
planUnitUnitId PlanUnit
pu, PlanUnit
pu)
| PlanUnit
pu <- CabalPlan -> [PlanUnit]
planUnits CabalPlan
cabalPlan ]
sortPlan :: Maybe ( Set UnitId )
-> Maybe [ UnitId ]
-> CabalPlan
-> [ConfiguredUnit]
sortPlan :: Maybe (Set UnitId)
-> Maybe [UnitId] -> CabalPlan -> [ConfiguredUnit]
sortPlan Maybe (Set UnitId)
mbAlreadyBuilt Maybe [UnitId]
mbOnlyDepsOf CabalPlan
plan =
[ConfiguredUnit] -> [ConfiguredUnit]
onlyInteresting forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a, b, c) -> a
fst3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (ConfiguredUnit, UnitId, [UnitId])
lookupVertex) forall a b. (a -> b) -> a -> b
$ Graph -> [Int]
Graph.reverseTopSort Graph
gr
where
onlyInteresting :: [ConfiguredUnit] -> [ConfiguredUnit]
onlyInteresting :: [ConfiguredUnit] -> [ConfiguredUnit]
onlyInteresting
| forall a. Maybe a -> Bool
isNothing Maybe (Set UnitId)
mbAlreadyBuilt
, forall a. Maybe a -> Bool
isNothing Maybe [UnitId]
mbOnlyDepsOf
= forall a. a -> a
id
| Bool
otherwise
= forall a. (a -> Bool) -> [a] -> [a]
filter ConfiguredUnit -> Bool
isInteresting
where
isInteresting :: ConfiguredUnit -> Bool
isInteresting :: ConfiguredUnit -> Bool
isInteresting cu :: ConfiguredUnit
cu@( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId } )
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ConfiguredUnit -> Bool
reachable ConfiguredUnit
cu
= Bool
False
| Just Set UnitId
alreadyBuilt <- Maybe (Set UnitId)
mbAlreadyBuilt
, UnitId
puId forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
alreadyBuilt
= Bool
False
| Bool
otherwise
= Bool
True
reachable :: ConfiguredUnit -> Bool
reachable :: ConfiguredUnit -> Bool
reachable =
case Maybe [UnitId]
mbOnlyDepsOf of
Maybe [UnitId]
Nothing -> forall a b. a -> b -> a
const Bool
True
Just [UnitId]
onlyDepsOf ->
let reachableUnits :: Set UnitId
!reachableUnits :: Set UnitId
reachableUnits
= forall a. Ord a => [a] -> Set a
Set.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ( ConfiguredUnit -> UnitId
Configured.puId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a, b, c) -> a
fst3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (ConfiguredUnit, UnitId, [UnitId])
lookupVertex )
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
forall a b. (a -> b) -> a -> b
$ Graph -> [Int] -> Forest Int
Graph.dfs Graph
gr
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UnitId -> Maybe Int
mkVertex [UnitId]
onlyDepsOf
in \ ( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId } ) -> UnitId
puId forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
reachableUnits
fst3 :: (a,b,c) -> a
fst3 :: forall a b c. (a, b, c) -> a
fst3 (a
a,b
_,c
_) = a
a
( Graph
gr, Int -> (ConfiguredUnit, UnitId, [UnitId])
lookupVertex, UnitId -> Maybe Int
mkVertex ) =
forall key node.
Ord key =>
[(node, key, [key])]
-> (Graph, Int -> (node, key, [key]), key -> Maybe Int)
Graph.graphFromEdges
[ (ConfiguredUnit
pu, UnitId
puId, ConfiguredUnit -> [UnitId]
allDepends ConfiguredUnit
pu)
| PU_Configured pu :: ConfiguredUnit
pu@( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId } ) <- CabalPlan -> [PlanUnit]
planUnits CabalPlan
plan ]
tagUnits :: [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
tagUnits :: [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
tagUnits = Map (PkgName, Version) UnitId
-> [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
go forall k a. Map k a
Map.empty
where
go :: Map (PkgName, Version) UnitId
-> [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
go Map (PkgName, Version) UnitId
_ [] = []
go Map (PkgName, Version) UnitId
seenPkgs ( cu :: ConfiguredUnit
cu@( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId } ):[ConfiguredUnit]
cus)
| UnitId
puId forall a. Eq a => a -> a -> Bool
== UnitId
dummyUnitId
= Map (PkgName, Version) UnitId
-> [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
go Map (PkgName, Version) UnitId
seenPkgs [ConfiguredUnit]
cus
| let nm :: PkgName
nm = ConfiguredUnit -> PkgName
Configured.puPkgName ConfiguredUnit
cu
ver :: Version
ver = ConfiguredUnit -> Version
Configured.puVersion ConfiguredUnit
cu
, ( Maybe UnitId
mbUnit, Map (PkgName, Version) UnitId
newPkgs ) <- forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey (\(PkgName, Version)
_ UnitId
a UnitId
_ -> UnitId
a) (PkgName
nm,Version
ver) UnitId
puId Map (PkgName, Version) UnitId
seenPkgs
= (ConfiguredUnit
cu, Maybe UnitId
mbUnit) forall a. a -> [a] -> [a]
: Map (PkgName, Version) UnitId
-> [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
go Map (PkgName, Version) UnitId
newPkgs [ConfiguredUnit]
cus
getInstalledUnits :: Verbosity
-> Compiler
-> BuildPaths ForPrep
-> PkgDbDirs ForPrep
-> Map UnitId PlanUnit
-> IO ( Set UnitId )
getInstalledUnits :: Verbosity
-> Compiler
-> BuildPaths 'ForPrep
-> PkgDbDirs 'ForPrep
-> Map UnitId PlanUnit
-> IO (Set UnitId)
getInstalledUnits Verbosity
verbosity
( Compiler { [Char]
$sel:ghcPkgPath:Compiler :: Compiler -> [Char]
ghcPkgPath :: [Char]
ghcPkgPath } )
( BuildPathsForPrep { [Char]
$sel:installDir:BuildPathsForPrep :: BuildPaths 'ForPrep -> [Char]
installDir :: [Char]
installDir } )
( PkgDbDirsForPrep { [Char]
tempPkgDbDir :: [Char]
$sel:tempPkgDbDir:PkgDbDirsForPrep :: PkgDbDirs 'ForPrep -> [Char]
tempPkgDbDir } )
Map UnitId PlanUnit
plan = do
[[Char]]
pkgVerUnitIds <-
[Char] -> [[Char]]
words forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[Char] -> [[Char]] -> [Char] -> IO [Char]
Process.readProcess ( [Char]
ghcPkgPath )
[ [Char]
"list"
, Verbosity -> [Char]
ghcPkgVerbosity Verbosity
verbosity
, [Char]
"--show-unit-ids", [Char]
"--simple-output"
, [Char]
"--package-db", [Char]
tempPkgDbDir ]
[Char]
""
let installedLibs :: [UnitId]
installedLibs = forall a b. (a -> b) -> [a] -> [b]
map ( Text -> UnitId
UnitId forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack ) [[Char]]
pkgVerUnitIds
Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
Text
"Preinstalled libraries:\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines ( forall a b. (a -> b) -> [a] -> [b]
map UnitId -> Text
mkLine [UnitId]
installedLibs )
[[Char]]
binDirContents <- [Char] -> IO [[Char]]
listDirectory [Char]
binsDir
[UnitId]
installedBins <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [Char] -> IO (Maybe UnitId)
binDirMaybe [[Char]]
binDirContents
Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
Text
"Preinstalled executables:\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines ( forall a b. (a -> b) -> [a] -> [b]
map UnitId -> Text
mkLine [UnitId]
installedBins )
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
installedLibs forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
installedBins
where
mkLine :: UnitId -> Text
mkLine :: UnitId -> Text
mkLine ( UnitId Text
uid ) = Text
" - " forall a. Semigroup a => a -> a -> a
<> Text
uid
binsDir :: FilePath
binsDir :: [Char]
binsDir = [Char]
installDir [Char] -> [Char] -> [Char]
</> [Char]
"bin"
binDirMaybe :: FilePath -> IO (Maybe UnitId)
binDirMaybe :: [Char] -> IO (Maybe UnitId)
binDirMaybe [Char]
binDir = do
Bool
isDir <- [Char] -> IO Bool
doesDirectoryExist ( [Char]
binsDir [Char] -> [Char] -> [Char]
</> [Char]
binDir )
if Bool -> Bool
not Bool
isDir
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else
case Map UnitId PlanUnit
plan forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ( Text -> UnitId
UnitId forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack [Char]
binDir ) of
Just ( PU_Configured ConfiguredUnit
cu )
| ConfiguredUnit
{ UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId
, $sel:puComponentName:ConfiguredUnit :: ConfiguredUnit -> ComponentName
puComponentName =
ComponentName
{ $sel:componentName:ComponentName :: ComponentName -> Text
componentName = Text
comp
, $sel:componentType:ComponentName :: ComponentName -> ComponentType
componentType = ComponentType
Exe }
} <- ConfiguredUnit
cu
-> do
let exePath :: [Char]
exePath = [Char]
binsDir [Char] -> [Char] -> [Char]
</> [Char]
binDir [Char] -> [Char] -> [Char]
</> Text -> [Char]
Text.unpack Text
comp [Char] -> [Char] -> [Char]
<.> [Char]
exeExtension
Bool
exeExists <- [Char] -> IO Bool
doesFileExist [Char]
exePath
if Bool
exeExists
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just UnitId
puId
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe PlanUnit
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing