{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |

-- Module      :  BuildEnv.Build

-- Description :  Computing, fetching and building plans

--

-- 'computePlan' computes a Cabal plan by generating @pkg.cabal@ and

-- @cabal.project@ files with the given dependencies, constraints, flags...,

-- calling @cabal build --dry-run@ to compute a build plan, and parsing

-- the resulting @plan.json@ file.

--

-- 'fetchPlan' calls @cabal unpack@ to fetch all packages in the given plan.

--

-- 'buildPlan' builds each unit in the build plan from source,

-- using 'buildUnit'. This can be done either asynchronously or sequentially

-- in dependency order, depending on the 'BuildStrategy'.

-- 'buildPlan' can also be used to output a shell script containing

-- build instructions, with the 'Script' 'BuildStrategy'.

module BuildEnv.Build
  ( -- * Computing, fetching and building plans

    computePlan
  , fetchPlan
  , buildPlan

    -- * Generating @pkg.cabal@ and @cabal.project@ files.

  , CabalFilesContents(..)
  , cabalFileContentsFromPackages
  , cabalProjectContentsFromPackages
  ) where

-- base

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 )

-- async

import Control.Concurrent.Async
  ( async, wait )

-- bytestring

import qualified Data.ByteString.Lazy as Lazy.ByteString
  ( readFile )

-- containers

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 )

-- directory

import System.Directory
  ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
  , exeExtension, listDirectory, removeDirectoryRecursive
  )

-- filepath

import System.FilePath
  ( (</>), (<.>)
  , isAbsolute
  )

-- process

import qualified System.Process as Process
  ( readProcess )

-- text

import Data.Text
  ( Text )
import qualified Data.Text    as Text
import qualified Data.Text.IO as Text
  ( writeFile )

-- build-env

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
  )

--------------------------------------------------------------------------------

-- Planning.


-- | The name of the dummy cabal package on which we will call

-- @cabal@ to obtain a build plan.

dummyPackageName :: IsString str => str
dummyPackageName :: forall str. IsString str => str
dummyPackageName = str
"build-env-dummy-package"

-- | The 'UnitId' of the (local) dummy package (version 0).

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"

-- | Query @cabal@ to obtain a build plan for the given packages,

-- by reading the output @plan.json@ of a @cabal build --dry-run@ invocation.

--

-- Use 'cabalFileContentsFromPackages' and 'cabalProjectContentsFromPackages'

-- to generate the @cabal@ file contents from a collection of packages with

-- constraints and flags.

-- See also 'BuildEnv.File.parseCabalDotConfigPkgs' and

-- 'BuildEnv.File.parseSeedFile' for other ways of obtaining this information.

--

-- Use 'parsePlanBinary' to convert the returned 'CabalPlanBinary' into

-- a 'CabalPlan'.

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

-- | The contents of a dummy @cabal.project@ file, specifying

-- package constraints, flags and allow-newer.

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 from the SEED file (units) should override

      -- constraints from the cabal.config file (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
        ]

-- | The contents of a dummy Cabal file with dependencies on

-- the specified units (without any constraints).

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"

-- | The file contents of the Cabal files of a Cabal project:

-- @pkg.cabal@ and @cabal.project@.

data CabalFilesContents
  = CabalFilesContents
    { CabalFilesContents -> Text
cabalContents   :: !Text
      -- ^ The package Cabal file contents.

    , CabalFilesContents -> Text
projectContents :: !Text
      -- ^ The @cabal.project@ file contents.

    }

--------------------------------------------------------------------------------

-- Fetching.


-- | Fetch the sources of a 'CabalPlan', calling @cabal get@ on each

-- package and putting it into the correspondingly named and versioned

-- subfolder of the specified directory (e.g. @pkg-name-1.2.3@).

fetchPlan :: Verbosity
          -> Cabal
          -> FilePath  -- ^ Directory in which to put the sources.

          -> 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
               -- Some packages might have multiple components;

               -- we don't want to fetch the package itself multiple times.

         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 -- only fetch remote packages

        -> forall a. a -> Maybe a
Just (PkgName
nm, Version
ver)
      PlanUnit
_ -> forall a. Maybe a
Nothing

-- | Call @cabal get@ to fetch a single package from Hackage.

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 }

--------------------------------------------------------------------------------

-- Building.


-- | Build a 'CabalPlan'. This will install all the packages in the plan

-- by running their @Setup@ scripts. Libraries will be registered

-- into a local package database at @installDir/package.conf@.

buildPlan :: Verbosity
          -> FilePath
              -- ^ Working directory.

              -- Used to compute relative paths for local packages,

              -- and to choose a logging directory.

          -> Paths ForPrep
          -> Paths ForBuild
          -> BuildStrategy
          -> Bool
             -- ^ @True@ <> resume a previously-started build,

             -- skipping over units that were already built.

             --

             -- This function will fail if this argument is @False@

             -- and one of the units has already been registered in the

             -- package database.

          -> Maybe [ UnitId ]
             -- ^ @Just units@: only build @units@ and their transitive

             -- dependencies, instead of the full build plan.

          -> ( ConfiguredUnit -> UnitArgs )
             -- ^ Extra arguments for each unit in the build plan.

          -> CabalPlan
             -- ^ Build plan to execute.

          -> 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
    -- Create the temporary package database, if it doesn't already exist.

    -- We also create the final installation package database,

    -- but this happens later, in (*), as part of the build script itself.

    --

    -- See Note [Using two package databases] in BuildOne.

    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 -- Units to build, in dependency order.

        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 ]

        -- Initial preparation: logging, and creating the final

        -- package database.

        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 ==="

        -- Setup the package for this unit.

        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

        -- Build and install this unit.

        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

        -- Close out the build.

        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

        -- Initialise the "units built" counter.

        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 -- Compile the Setup script of the package the unit belongs to.

                  -- (This should happen only once per package.)

                  doPkgSetupAsync :: ConfiguredUnit -> IO ()
                  doPkgSetupAsync :: ConfiguredUnit -> IO ()
doPkgSetupAsync cu :: ConfiguredUnit
cu@( ConfiguredUnit { [UnitId]
$sel:puSetupDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puSetupDepends :: [UnitId]
puSetupDepends } ) = do

                    -- Wait for the @setup-depends@ units.

                    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

                    -- Setup the package.

                    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

                  -- Configure, build and install the unit.

                  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

                    -- Wait for the package to have been setup.

                    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)

                    -- Wait until we have built the units we depend on.

                    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

                    -- Build the unit!

                    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

              -- Kick off setting up the packages...

              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)
              -- ... and building the units.

              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

    -- This needs to have ALL units, as that's how we pass correct

    -- Unit IDs for dependencies.

    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 ]


-- | Sort the units in a 'CabalPlan' in dependency order.

sortPlan :: Maybe ( Set UnitId )
             -- ^ - @Just skip@ <=> skip these already-built units.

             --   - @Nothing@ <=> don't skip any units.

         -> Maybe [ UnitId ]
             -- ^ - @Just keep@ <=> only return units that belong

             --     to the transitive closure of @keep@.

             --   - @Nothing@ <=> return all units in the plan.

         -> 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
      -- Fast path: don't filter out anything.

      | 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 ]

-- | Tag units in a build plan: the first unit we compile in each package

-- is tagged (with @'Nothing'@) as having the responsibility to build

-- the Setup executable for the package it belongs to, while other units

-- in this same package are tagged with @'Just' uid@, where @uid@ is the unit

-- which is responsible for building the Setup executable.

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

-- | Compute the set of @UnitId@s that have already been installed, to avoid

-- unnecessarily recompiling them.

--

-- This set of already-installed units is computed by querying the following:

--

--  - Library: is it already registered in the package database?

--  - Executable: is there an executable of the correct name in the binary

--    directory associated with the unit?

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 ]
        -- TODO: allow user package databases too?

      [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
          -- Is this directory name the 'UnitId' of an executable

          -- in the build plan?

          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 -- If so, does it contain the executable we expect?

                  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