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

-- |

-- 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.Functor
  ( (<&>) )
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
  )

-- 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
  ( PkgDbDir(..)
  , getPkgDbDirForPrep, getPkgDbDirForBuild
  , 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, withNewAbstractSem
  )
import BuildEnv.Path

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

-- 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 (Text -> UnitId) -> Text -> UnitId
forall a b. (a -> b) -> a -> b
$ Text
forall str. IsString str => str
dummyPackageName Text -> Text -> Text
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
            -> SymbolicPath CWD ( Dir Project )
            -> CabalFilesContents
            -> IO CabalPlanBinary
computePlan :: TempDirPermanence
-> Verbosity
-> Compiler
-> Cabal
-> SymbolicPath CWD ('Dir Project)
-> CabalFilesContents
-> IO CabalPlanBinary
computePlan TempDirPermanence
delTemp Verbosity
verbosity Compiler
comp Cabal
cabal SymbolicPath CWD ('Dir Project)
_workDir ( CabalFilesContents { Text
cabalContents :: Text
cabalContents :: CabalFilesContents -> Text
cabalContents, Text
projectContents :: Text
projectContents :: CabalFilesContents -> Text
projectContents } ) =
  TempDirPermanence
-> FilePath
-> (AbsolutePath ('Dir Tmp) -> IO CabalPlanBinary)
-> IO CabalPlanBinary
forall a.
TempDirPermanence
-> FilePath -> (AbsolutePath ('Dir Tmp) -> IO a) -> IO a
withTempDir TempDirPermanence
delTemp FilePath
"build" \ AbsolutePath ('Dir Tmp)
tmpDir -> do
    Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Computing plan in build directory " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack ( AbsolutePath ('Dir Tmp) -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath ('Dir Tmp)
tmpDir )
    FilePath -> Text -> IO ()
Text.writeFile (AbsolutePath ('Dir Tmp) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir Tmp)
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"cabal" FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"project") Text
projectContents
    FilePath -> Text -> IO ()
Text.writeFile (AbsolutePath ('Dir Tmp) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir Tmp)
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
forall str. IsString str => str
dummyPackageName FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"cabal") Text
cabalContents
    let cabalBuildArgs :: [FilePath]
cabalBuildArgs =
          Cabal -> [FilePath]
globalCabalArgs Cabal
cabal [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
            [ FilePath
"build"
            , FilePath
"--dry-run"
            , FilePath
"--with-compiler", AbsolutePath 'File -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath ( Compiler -> AbsolutePath 'File
ghcPath Compiler
comp )
            , Verbosity -> FilePath
cabalVerbosity Verbosity
verbosity ]
    Verbosity -> Text -> IO ()
debugMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
"cabal" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ( ( Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ) (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack ) [FilePath]
cabalBuildArgs
    forall dir.
HasCallStack =>
Maybe Counter -> CallProcess dir -> IO ()
callProcessInIO @Tmp Maybe Counter
forall a. Maybe a
Nothing (CallProcess Tmp -> IO ()) -> CallProcess Tmp -> IO ()
forall a b. (a -> b) -> a -> b
$
      CP { cwd :: SymbolicPath CWD ('Dir Tmp)
cwd          = AbsolutePath ('Dir Tmp) -> SymbolicPath CWD ('Dir Tmp)
forall (to :: FileOrDir) from.
AbsolutePath to -> SymbolicPath from to
absoluteSymbolicPath AbsolutePath ('Dir Tmp)
tmpDir
         , prog :: ProgPath Tmp
prog         = AbsolutePath 'File -> ProgPath Tmp
forall from. AbsolutePath 'File -> ProgPath from
AbsPath (AbsolutePath 'File -> ProgPath Tmp)
-> AbsolutePath 'File -> ProgPath Tmp
forall a b. (a -> b) -> a -> b
$ Cabal -> AbsolutePath 'File
cabalPath Cabal
cabal
         , args :: [FilePath]
args         = [FilePath]
cabalBuildArgs
         , extraPATH :: [FilePath]
extraPATH    = []
         , extraEnvVars :: [(FilePath, FilePath)]
extraEnvVars = []
         , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
forall a. Maybe a
Nothing
         , sem :: AbstractSem
sem          = AbstractSem
noSem
         }

    let planPath :: FilePath
        planPath :: FilePath
planPath = AbsolutePath ('Dir Tmp) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir Tmp)
tmpDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"dist-newstyle" FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"cache" FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"plan.json"
    ByteString -> CabalPlanBinary
CabalPlanBinary (ByteString -> CabalPlanBinary)
-> IO ByteString -> IO CabalPlanBinary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
Lazy.ByteString.readFile FilePath
planPath

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

-- package constraints, flags and allow-newer.

cabalProjectContentsFromPackages
  :: SymbolicPath CWD ( Dir Project )
  -> UnitSpecs
  -> PkgSpecs
  -> AllowNewer
  -> Maybe IndexState
  -> IO Text
cabalProjectContentsFromPackages :: SymbolicPath CWD ('Dir Project)
-> UnitSpecs
-> PkgSpecs
-> AllowNewer
-> Maybe IndexState
-> IO Text
cabalProjectContentsFromPackages SymbolicPath CWD ('Dir Project)
workDir UnitSpecs
units PkgSpecs
pins ( AllowNewer Set (Text, Text)
allowNewer ) Maybe IndexState
mbIndexState = do

  -- Make all the local package paths into absolute paths, as we are

  -- putting the cabal.project file off in some temporary directory.

  ( [AbsolutePath ('Dir Pkg)]
localPkgs :: [ AbsolutePath ( Dir Pkg ) ] )
    <- (SymbolicPath Project ('Dir Pkg) -> IO (AbsolutePath ('Dir Pkg)))
-> [SymbolicPath Project ('Dir Pkg)]
-> IO [AbsolutePath ('Dir Pkg)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ( SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Pkg) -> IO (AbsolutePath ('Dir Pkg))
forall dir (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPath dir to -> IO (AbsolutePath to)
makeAbsolute SymbolicPath CWD ('Dir Project)
workDir ) ([SymbolicPath Project ('Dir Pkg)] -> IO [AbsolutePath ('Dir Pkg)])
-> [SymbolicPath Project ('Dir Pkg)]
-> IO [AbsolutePath ('Dir Pkg)]
forall a b. (a -> b) -> a -> b
$ ((PkgSrc, PkgSpec, Set ComponentName)
 -> Maybe (SymbolicPath Project ('Dir Pkg)))
-> [(PkgSrc, PkgSpec, Set ComponentName)]
-> [SymbolicPath Project ('Dir Pkg)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PkgSrc, PkgSpec, Set ComponentName)
-> Maybe (SymbolicPath Project ('Dir Pkg))
isLocal ( UnitSpecs -> [(PkgSrc, PkgSpec, Set ComponentName)]
forall k a. Map k a -> [a]
Map.elems UnitSpecs
units )

  let
    packages :: Text
packages
      | [AbsolutePath ('Dir Pkg)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AbsolutePath ('Dir Pkg)]
localPkgs
      = Text
"packages: .\n\n"
      | Bool
otherwise
      = Text -> [Text] -> Text
Text.intercalate Text
",\n          "
        ( Text
"packages: ." Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (AbsolutePath ('Dir Pkg) -> Text)
-> [AbsolutePath ('Dir Pkg)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ( FilePath -> Text
Text.pack (FilePath -> Text)
-> (AbsolutePath ('Dir Pkg) -> FilePath)
-> AbsolutePath ('Dir Pkg)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath ('Dir Pkg) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath ) [AbsolutePath ('Dir Pkg)]
localPkgs )
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

    constraints :: Text
constraints = [Text] -> Text
Text.unlines
        [ [Text] -> Text
Text.unwords [Text
"constraints:", PkgName -> Text
unPkgName PkgName
nm, Text
cts]
        | (PkgName
nm, PkgSpec
ps) <- PkgSpecs -> [(PkgName, PkgSpec)]
forall k a. Map k a -> [(k, a)]
Map.assocs PkgSpecs
allPkgs
        , Constraints Text
cts <- Maybe Constraints -> [Constraints]
forall a. Maybe a -> [a]
maybeToList (Maybe Constraints -> [Constraints])
-> Maybe Constraints -> [Constraints]
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
      | Set (Text, Text) -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (Text, Text)
allowNewer
      = Text
""
      | Bool
otherwise
      = [Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
          Text
"allow-newer:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
            [ Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
","
            | (Text
p,Text
q) <- Set (Text, Text) -> [(Text, Text)]
forall a. Set a -> [a]
Set.elems Set (Text, Text)
allowNewer ]

    flagSpecs :: Text
flagSpecs = [Text] -> Text
Text.unlines
        [ [Text] -> Text
Text.unlines
          [ Text
"package " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PkgName -> Text
unPkgName PkgName
nm
          , Text
"  flags: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FlagSpec -> Text
showFlagSpec (PkgSpec -> FlagSpec
psFlags PkgSpec
ps)
          ]
        | (PkgName
nm, PkgSpec
ps) <- PkgSpecs -> [(PkgName, PkgSpec)]
forall k a. Map k a -> [(k, a)]
Map.assocs PkgSpecs
allPkgs
        , let flags :: FlagSpec
flags = PkgSpec -> FlagSpec
psFlags PkgSpec
ps
        , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FlagSpec -> Bool
flagSpecIsEmpty FlagSpec
flags
        ]

    indexStateDecl :: Text
indexStateDecl = case Maybe IndexState
mbIndexState of
      Maybe IndexState
Nothing -> Text
""
      Just ( IndexState Text
date ) ->
        [Text] -> Text
Text.unlines [ Text
"index-state: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
date ]

  Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$
        Text
packages
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
allowNewers
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flagSpecs
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
constraints
     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
indexStateDecl

  where

    isLocal :: ( PkgSrc, PkgSpec, Set ComponentName ) -> Maybe ( SymbolicPath Project ( Dir Pkg ) )
    isLocal :: (PkgSrc, PkgSpec, Set ComponentName)
-> Maybe (SymbolicPath Project ('Dir Pkg))
isLocal ( Local SymbolicPath Project ('Dir Pkg)
src, PkgSpec
_, Set ComponentName
_ ) = SymbolicPath Project ('Dir Pkg)
-> Maybe (SymbolicPath Project ('Dir Pkg))
forall a. a -> Maybe a
Just SymbolicPath Project ('Dir Pkg)
src
    isLocal (PkgSrc, PkgSpec, Set ComponentName)
_ = Maybe (SymbolicPath Project ('Dir Pkg))
forall a. Maybe a
Nothing

    allPkgs :: PkgSpecs
    allPkgs :: PkgSpecs
allPkgs = ((PkgSrc, PkgSpec, Set ComponentName) -> PkgSpec)
-> UnitSpecs -> PkgSpecs
forall a b. (a -> b) -> Map PkgName a -> Map PkgName b
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).


-- | 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: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall str. IsString str => str
dummyPackageName
    , Text
"version: 0"
    , Text
"library" ]
  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
libDepends
  Text -> Text -> Text
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 -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
lib; ComponentType
_ -> Maybe Text
forall a. Maybe a
Nothing }
    isExe :: ComponentName -> Maybe Text
isExe (ComponentName ComponentType
ty Text
exe) = case ComponentType
ty of { ComponentType
Exe -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
exe; ComponentType
_ -> Maybe Text
forall a. Maybe a
Nothing }
    allLibs :: [(PkgName, [Text])]
allLibs = [ (PkgName
pkg, [Text]
libsInPkg)
              | (PkgName
pkg, (PkgSrc
_, PkgSpec
_, Set ComponentName
comps)) <- UnitSpecs -> [(PkgName, (PkgSrc, PkgSpec, Set ComponentName))]
forall k a. Map k a -> [(k, a)]
Map.assocs UnitSpecs
units
              , let libsInPkg :: [Text]
libsInPkg = (ComponentName -> Maybe Text) -> [ComponentName] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ComponentName -> Maybe Text
isLib ([ComponentName] -> [Text]) -> [ComponentName] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set ComponentName -> [ComponentName]
forall a. Set a -> [a]
Set.toList Set ComponentName
comps
              , Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
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)) <- UnitSpecs -> [(PkgName, (PkgSrc, PkgSpec, Set ComponentName))]
forall k a. Map k a -> [(k, a)]
Map.assocs UnitSpecs
units
            , let exesInPkg :: [Text]
exesInPkg = (ComponentName -> Maybe Text) -> [ComponentName] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ComponentName -> Maybe Text
isExe ([ComponentName] -> [Text]) -> [ComponentName] -> [Text]
forall a b. (a -> b) -> a -> b
$ Set ComponentName -> [ComponentName]
forall a. Set a -> [a]
Set.toList Set ComponentName
comps
            , Bool -> Bool
not ([Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
exesInPkg) ]

    dep :: PkgName -> [Text] -> Text
dep (PkgName Text
pkg) [Text
comp]
      = Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
comp
    dep (PkgName Text
pkg) [Text]
comps
      = Text
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
comps Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

    libDepends :: Text
libDepends
      | [(PkgName, [Text])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PkgName, [Text])]
allLibs
      = Text
""
      | Bool
otherwise
      = Text
"\n  build-depends:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
",\n"
               [ Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PkgName -> [Text] -> Text
dep PkgName
pkg [Text]
libs
               | (PkgName
pkg, [Text]
libs) <- [(PkgName, [Text])]
allLibs ]
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

    exeDepends :: Text
exeDepends
      | [(PkgName, [Text])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PkgName, [Text])]
allExes
      = Text
""
      | Bool
otherwise
      = Text
"\n  build-tool-depends:\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
",\n"
               [ Text
"    " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PkgName -> [Text] -> Text
dep PkgName
pkg [Text]
exes
               | (PkgName
pkg, [Text]
exes) <- [(PkgName, [Text])]
allExes ]
      Text -> Text -> Text
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
          -> SymbolicPath CWD ( Dir Project )
          -> Maybe IndexState
          -> SymbolicPath Project ( Dir Fetch )  -- ^ Directory in which to put the sources.

          -> CabalPlan
          -> IO ()
fetchPlan :: Verbosity
-> Cabal
-> SymbolicPath CWD ('Dir Project)
-> Maybe IndexState
-> SymbolicPath Project ('Dir Fetch)
-> CabalPlan
-> IO ()
fetchPlan Verbosity
verbosity Cabal
cabal SymbolicPath CWD ('Dir Project)
workDir Maybe IndexState
mbIndexState SymbolicPath Project ('Dir Fetch)
fetchDir CabalPlan
cabalPlan =
    Set (PkgName, Version) -> ((PkgName, Version) -> IO ()) -> IO ()
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 :: FilePath
nmVerStr = Text -> FilePath
Text.unpack Text
nameVersion
      Bool
pkgDirExists <- FilePath -> IO Bool
doesDirectoryExist ( SymbolicPath CWD ('Dir Project)
-> SymbolicPathX 'AllowAbsolute Project Any -> FilePath
forall dir (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPathX allowAbsolute dir to -> FilePath
interpretSymbolicPath SymbolicPath CWD ('Dir Project)
workDir (SymbolicPathX 'AllowAbsolute Project Any -> FilePath)
-> SymbolicPathX 'AllowAbsolute Project Any -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath Project ('Dir Fetch)
fetchDir SymbolicPath Project ('Dir Fetch)
-> RelativePath Fetch Any
-> SymbolicPathX 'AllowAbsolute Project Any
forall p q r. PathLike p q r => p -> q -> r
</> FilePath -> RelativePath Fetch Any
forall from (to :: FileOrDir). FilePath -> RelativePath from to
mkRelativePath FilePath
nmVerStr )
      if   Bool
pkgDirExists
      then Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"NOT fetching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nameVersion
      else Verbosity
-> Cabal
-> SymbolicPath CWD ('Dir Project)
-> Maybe IndexState
-> SymbolicPath Project ('Dir Fetch)
-> FilePath
-> IO ()
cabalFetch Verbosity
verbosity Cabal
cabal SymbolicPath CWD ('Dir Project)
workDir Maybe IndexState
mbIndexState SymbolicPath Project ('Dir Fetch)
fetchDir FilePath
nmVerStr
  where
    pkgs :: Set (PkgName, Version)
    pkgs :: Set (PkgName, Version)
pkgs = [(PkgName, Version)] -> Set (PkgName, Version)
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.

         ([(PkgName, Version)] -> Set (PkgName, Version))
-> [(PkgName, Version)] -> Set (PkgName, Version)
forall a b. (a -> b) -> a -> b
$ (PlanUnit -> Maybe (PkgName, Version))
-> [PlanUnit] -> [(PkgName, Version)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PlanUnit -> Maybe (PkgName, Version)
remotePkgNameVersion
         ([PlanUnit] -> [(PkgName, Version)])
-> [PlanUnit] -> [(PkgName, Version)]
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

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

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

cabalFetch :: Verbosity -> Cabal
           -> SymbolicPath CWD ( Dir Project )
           -> Maybe IndexState
           -> SymbolicPath Project ( Dir Fetch )
           -> String
           -> IO ()
cabalFetch :: Verbosity
-> Cabal
-> SymbolicPath CWD ('Dir Project)
-> Maybe IndexState
-> SymbolicPath Project ('Dir Fetch)
-> FilePath
-> IO ()
cabalFetch Verbosity
verbosity Cabal
cabal SymbolicPath CWD ('Dir Project)
workDir Maybe IndexState
mbIndexState SymbolicPath Project ('Dir Fetch)
root FilePath
pkgNmVer = do
    Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Fetching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
pkgNmVer
    let args :: [FilePath]
args = Cabal -> [FilePath]
globalCabalArgs Cabal
cabal [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
                 [ FilePath
"get"
                 , FilePath
pkgNmVer
                 , Verbosity -> FilePath
cabalVerbosity Verbosity
verbosity ]
                 [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [ FilePath
"--index-state=" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
indexState
                    | IndexState Text
indexState <- Maybe IndexState -> [IndexState]
forall a. Maybe a -> [a]
maybeToList Maybe IndexState
mbIndexState ]
    forall dir.
HasCallStack =>
Maybe Counter -> CallProcess dir -> IO ()
callProcessInIO @Fetch Maybe Counter
forall a. Maybe a
Nothing (CallProcess Fetch -> IO ()) -> CallProcess Fetch -> IO ()
forall a b. (a -> b) -> a -> b
$
      CP { cwd :: SymbolicPath CWD ('Dir Fetch)
cwd          = SymbolicPath CWD ('Dir Project)
workDir SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Fetch)
-> SymbolicPath CWD ('Dir Fetch)
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPath Project ('Dir Fetch)
root
         , prog :: ProgPath Fetch
prog         = AbsolutePath 'File -> ProgPath Fetch
forall from. AbsolutePath 'File -> ProgPath from
AbsPath (AbsolutePath 'File -> ProgPath Fetch)
-> AbsolutePath 'File -> ProgPath Fetch
forall a b. (a -> b) -> a -> b
$ Cabal -> AbsolutePath 'File
cabalPath Cabal
cabal
         , [FilePath]
args :: [FilePath]
args :: [FilePath]
args
         , extraPATH :: [FilePath]
extraPATH    = []
         , extraEnvVars :: [(FilePath, FilePath)]
extraEnvVars = []
         , logBasePath :: Maybe (AbsolutePath 'File)
logBasePath  = Maybe (AbsolutePath 'File)
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
          -> SymbolicPath CWD ( Dir Project )
              -- ^ Working directory.

              -- Used to compute relative paths for local packages,

              -- and to choose a logging directory.

          -> Paths ForPrep
          -> Paths ForBuild
          -> Maybe ( SymbolicPath Project ( Dir Logs ) )
              -- ^ event log directory

          -> 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
-> SymbolicPath CWD ('Dir Project)
-> Paths 'ForPrep
-> Paths 'ForBuild
-> Maybe (SymbolicPath Project ('Dir Logs))
-> BuildStrategy
-> Bool
-> Maybe [UnitId]
-> (ConfiguredUnit -> UnitArgs)
-> CabalPlan
-> IO ()
buildPlan Verbosity
verbosity SymbolicPath CWD ('Dir Project)
workDir
          pathsForPrep :: Paths 'ForPrep
pathsForPrep@( Paths { $sel:buildPaths:Paths :: forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths = BuildPaths 'ForPrep
buildPathsForPrep })
          Paths 'ForBuild
pathsForBuild
          Maybe (SymbolicPath Project ('Dir Logs))
mbEventLogDir
          BuildStrategy
buildStrat
          Bool
resumeBuild
          Maybe [UnitId]
mbOnlyBuildDepsOf
          ConfiguredUnit -> UnitArgs
userUnitArgs
          CabalPlan
cabalPlan
  = do
    let paths :: BuildPaths 'ForBuild
paths@( BuildPaths { Compiler
compiler :: Compiler
$sel:compiler:BuildPaths :: BuildPaths 'ForBuild -> Compiler
compiler, AbsolutePath ('Dir Prefix)
prefix :: AbsolutePath ('Dir Prefix)
$sel:prefix:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Prefix)
prefix, AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
$sel:installDir:BuildPaths :: BuildPaths 'ForBuild -> AbsolutePath ('Dir Install)
installDir } )
          = Paths 'ForBuild -> BuildPaths 'ForBuild
forall (use :: PathUsability). Paths use -> BuildPaths use
buildPaths Paths 'ForBuild
pathsForBuild

        pkgDbDirForPrep :: PkgDbDir 'ForPrep
pkgDbDirForPrep
          = Paths 'ForPrep -> PkgDbDir 'ForPrep
getPkgDbDirForPrep Paths 'ForPrep
pathsForPrep

    pkgDbDirs :: PkgDbDir 'ForBuild
pkgDbDirs@( PkgDbDirForBuild { AbsolutePath ('Dir PkgDb)
finalPkgDbDir :: AbsolutePath ('Dir PkgDb)
$sel:finalPkgDbDir:PkgDbDirForBuild :: PkgDbDir 'ForBuild -> AbsolutePath ('Dir PkgDb)
finalPkgDbDir } )
      <- Paths 'ForBuild -> IO (PkgDbDir 'ForBuild)
getPkgDbDirForBuild Paths 'ForBuild
pathsForBuild

    -- Check the package database exists when it should,

    -- and delete it if we are starting fresh.

    Bool
finalPkgDbExists <- FilePath -> IO Bool
doesDirectoryExist ( AbsolutePath ('Dir PkgDb) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir PkgDb)
finalPkgDbDir )
    if | Bool
resumeBuild Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
finalPkgDbExists
       -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot resume build: no package database at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> AbsolutePath ('Dir PkgDb) -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath ('Dir PkgDb)
finalPkgDbDir
       | Bool -> Bool
not Bool
resumeBuild Bool -> Bool -> Bool
&& Bool
finalPkgDbExists
       -> FilePath -> IO ()
removeDirectoryRecursive ( AbsolutePath ('Dir PkgDb) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir PkgDb)
finalPkgDbDir )
            IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \ ( IOException
_ :: IOException ) -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       | Bool
otherwise
       -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    Maybe (SymbolicPath Project ('Dir Logs))
-> (SymbolicPath Project ('Dir Logs) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (SymbolicPath Project ('Dir Logs))
mbEventLogDir \ SymbolicPath Project ('Dir Logs)
eventLogDir -> do
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True ( SymbolicPath CWD ('Dir Project)
-> SymbolicPath Project ('Dir Logs) -> FilePath
forall dir (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
SymbolicPath CWD ('Dir dir)
-> SymbolicPathX allowAbsolute dir to -> FilePath
interpretSymbolicPath SymbolicPath CWD ('Dir Project)
workDir SymbolicPath Project ('Dir Logs)
eventLogDir )

    Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
Text.unlines [ Text
"Directory structure:"
                   , Text
"    work dir: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack ( SymbolicPath CWD ('Dir Project) -> FilePath
forall a. Show a => a -> FilePath
show SymbolicPath CWD ('Dir Project)
workDir )
                   , Text
"      prefix: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack ( AbsolutePath ('Dir Prefix) -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath ('Dir Prefix)
prefix )
                   , Text
"  installDir: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack ( AbsolutePath ('Dir Install) -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath ('Dir Install)
installDir )
                   ]

    Maybe (Set UnitId)
mbAlreadyBuilt <-
      if Bool
resumeBuild
      then let prepComp :: Compiler
prepComp = BuildPaths 'ForPrep -> Compiler
compilerForPrep BuildPaths 'ForPrep
buildPathsForPrep
           in Set UnitId -> Maybe (Set UnitId)
forall a. a -> Maybe a
Just (Set UnitId -> Maybe (Set UnitId))
-> IO (Set UnitId) -> IO (Maybe (Set UnitId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Verbosity
-> Compiler
-> BuildPaths 'ForPrep
-> PkgDbDir 'ForPrep
-> Map UnitId PlanUnit
-> IO (Set UnitId)
getInstalledUnits Verbosity
verbosity Compiler
prepComp BuildPaths 'ForPrep
buildPathsForPrep PkgDbDir 'ForPrep
pkgDbDirForPrep Map UnitId PlanUnit
fullDepMap
      else Maybe (Set UnitId) -> IO (Maybe (Set UnitId))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Set UnitId)
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 ([ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)])
-> [ConfiguredUnit] -> [(ConfiguredUnit, Maybe UnitId)]
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 = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ [(ConfiguredUnit, Maybe UnitId)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild

        pkgMap :: Map (PkgName, Version) ConfiguredUnit
        pkgMap :: Map (PkgName, Version) ConfiguredUnit
pkgMap = [((PkgName, Version), ConfiguredUnit)]
-> Map (PkgName, Version) ConfiguredUnit
forall k a. Ord k => [(k, a)] -> Map k a
Lazy.Map.fromList
          [ ((PkgName
puPkgName, Version
puVersion), ConfiguredUnit
cu)
          | ( cu :: ConfiguredUnit
cu@( ConfiguredUnit { PkgName
$sel:puPkgName:ConfiguredUnit :: ConfiguredUnit -> PkgName
puPkgName :: PkgName
puPkgName, Version
$sel:puVersion:ConfiguredUnit :: ConfiguredUnit -> Version
puVersion :: Version
puVersion } ), Maybe UnitId
didSetup ) <- [(ConfiguredUnit, Maybe UnitId)]
unitsToBuild
          , Maybe UnitId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UnitId
didSetup ]

        -- Initial preparation: logging, and creating the package database.

        preparation :: BuildScript
        preparation :: BuildScript
preparation = do
          Verbosity -> Verbosity -> FilePath -> BuildScript
logMessage Verbosity
verbosity Verbosity
Verbose (FilePath -> BuildScript) -> FilePath -> BuildScript
forall a b. (a -> b) -> a -> b
$
            FilePath
"Creating package database at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> AbsolutePath ('Dir PkgDb) -> FilePath
forall a. Show a => a -> FilePath
show AbsolutePath ('Dir PkgDb)
finalPkgDbDir
          AbsolutePath ('Dir PkgDb) -> BuildScript
forall dir. AbsolutePath ('Dir dir) -> BuildScript
createDir AbsolutePath ('Dir PkgDb)
finalPkgDbDir
          Verbosity -> Verbosity -> FilePath -> BuildScript
logMessage Verbosity
verbosity Verbosity
Debug (FilePath -> BuildScript) -> FilePath -> BuildScript
forall a b. (a -> b) -> a -> b
$ FilePath
"Packages:\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
            [FilePath] -> FilePath
unlines
              [ FilePath
"  - " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack (PkgName -> Version -> Text
pkgNameVersion PkgName
nm Version
ver)
              | (PkgName
nm, Version
ver) <- Map (PkgName, Version) ConfiguredUnit -> [(PkgName, Version)]
forall k a. Map k a -> [k]
Map.keys Map (PkgName, Version) ConfiguredUnit
pkgMap ]
          Verbosity -> Verbosity -> FilePath -> BuildScript
logMessage Verbosity
verbosity Verbosity
Debug (FilePath -> BuildScript) -> FilePath -> BuildScript
forall a b. (a -> b) -> a -> b
$ FilePath
"Units:\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<>
            [FilePath] -> FilePath
unlines
              [ FilePath
"  - " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
pkgNm FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
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 -> FilePath -> BuildScript
logMessage Verbosity
verbosity Verbosity
Normal (FilePath -> BuildScript) -> FilePath -> BuildScript
forall a b. (a -> b) -> a -> b
$ FilePath
"=== 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  = Paths 'ForPrep -> ConfiguredUnit -> PkgDir 'ForPrep
forall (use :: PathUsability).
Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir Paths 'ForPrep
pathsForPrep  ConfiguredUnit
pu
              pkgDirForBuild :: PkgDir 'ForBuild
pkgDirForBuild = Paths 'ForBuild -> ConfiguredUnit -> PkgDir 'ForBuild
forall (use :: PathUsability).
Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir Paths 'ForBuild
pathsForBuild ConfiguredUnit
pu
          Verbosity
-> Compiler
-> SymbolicPath CWD ('Dir Project)
-> BuildPaths 'ForBuild
-> PkgDbDir 'ForBuild
-> PkgDir 'ForPrep
-> PkgDir 'ForBuild
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> IO BuildScript
setupPackage Verbosity
verbosity Compiler
compiler
            SymbolicPath CWD ('Dir Project)
workDir BuildPaths 'ForBuild
paths PkgDbDir 'ForBuild
pkgDbDirs PkgDir 'ForPrep
pkgDirForPrep PkgDir 'ForBuild
pkgDirForBuild
            Map UnitId PlanUnit
fullDepMap ConfiguredUnit
pu

        -- Build and install this unit.

        unitBuildScript :: Args -> ConfiguredUnit -> BuildScript
        unitBuildScript :: [FilePath] -> ConfiguredUnit -> BuildScript
unitBuildScript [FilePath]
extraConfigureArgs pu :: ConfiguredUnit
pu@( ConfiguredUnit { UnitId
puId :: UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId }) =
          let pkgDirForBuild :: PkgDir 'ForBuild
pkgDirForBuild = Paths 'ForBuild -> ConfiguredUnit -> PkgDir 'ForBuild
forall (use :: PathUsability).
Paths use -> ConfiguredUnit -> PkgDir use
getPkgDir Paths 'ForBuild
pathsForBuild ConfiguredUnit
pu
              mbEventLogArg :: Maybe FilePath
mbEventLogArg = Maybe (SymbolicPath Project ('Dir Logs))
mbEventLogDir Maybe (SymbolicPath Project ('Dir Logs))
-> (SymbolicPath Project ('Dir Logs) -> FilePath) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ SymbolicPath Project ('Dir Logs)
logDir ->
                let logPath :: FilePath
logPath = SymbolicPath Project ('Dir Logs) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath Project ('Dir Logs)
logDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"ghc" FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Text -> FilePath
Text.unpack ( UnitId -> Text
unUnitId UnitId
puId ) FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"eventlog"
                in FilePath
"--ghc-option=\"-with-rtsopts=-l-ol" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
logPath FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\""
              allConfigureArgs :: [FilePath]
allConfigureArgs =
                [[FilePath]] -> [FilePath]
forall a. Monoid a => [a] -> a
mconcat [ [FilePath]
extraConfigureArgs
                        , Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
mbEventLogArg
                        , UnitArgs -> [FilePath]
configureArgs ( ConfiguredUnit -> UnitArgs
userUnitArgs ConfiguredUnit
pu ) ]
              allUnitArgs :: UnitArgs
allUnitArgs =
                ( ConfiguredUnit -> UnitArgs
userUnitArgs ConfiguredUnit
pu ) { configureArgs = allConfigureArgs }
          in Verbosity
-> Compiler
-> SymbolicPath CWD ('Dir Project)
-> BuildPaths 'ForBuild
-> PkgDbDir 'ForBuild
-> PkgDir 'ForBuild
-> UnitArgs
-> Map UnitId PlanUnit
-> ConfiguredUnit
-> BuildScript
buildUnit Verbosity
verbosity Compiler
compiler SymbolicPath CWD ('Dir Project)
workDir
                BuildPaths 'ForBuild
paths PkgDbDir 'ForBuild
pkgDbDirs PkgDir 'ForBuild
pkgDirForBuild
                UnitArgs
allUnitArgs
                Map UnitId PlanUnit
fullDepMap ConfiguredUnit
pu

        -- Close out the build.

        finish :: BuildScript
        finish :: BuildScript
finish = do
          Verbosity -> Verbosity -> FilePath -> BuildScript
logMessage Verbosity
verbosity Verbosity
Normal (FilePath -> BuildScript) -> FilePath -> BuildScript
forall a b. (a -> b) -> a -> b
$ FilePath
"=== BUILD SUCCEEDED ==="

    case BuildStrategy
buildStrat of

      Execute RunStrategy
runStrat -> do

        -- Initialise the "units built" counter.

        IORef Word
unitsBuiltCounterRef <- Word -> IO (IORef Word)
forall a. a -> IO (IORef a)
newIORef Word
0
        let unitsBuiltCounter :: Maybe Counter
unitsBuiltCounter
              = Counter -> Maybe Counter
forall a. a -> Maybe a
Just (Counter -> Maybe Counter) -> Counter -> Maybe Counter
forall a b. (a -> b) -> a -> b
$
                Counter { $sel:counterRef:Counter :: IORef Word
counterRef = IORef Word
unitsBuiltCounterRef
                        , $sel:counterMax:Counter :: Word
counterMax = Word
nbUnitsToBuild }

            execBuildScript :: BuildScript -> IO ()
execBuildScript = SymbolicPath CWD ('Dir Project)
-> Maybe Counter -> BuildScript -> IO ()
executeBuildScript SymbolicPath CWD ('Dir Project)
workDir Maybe Counter
unitsBuiltCounter

        case RunStrategy
runStrat of

          Async AsyncSem
sem -> do

            Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
              Text
"\nBuilding and installing units asynchronously with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AsyncSem -> Text
semDescription AsyncSem
sem
            BuildScript -> IO ()
execBuildScript BuildScript
preparation

            AsyncSem -> (AbstractSem -> [FilePath] -> IO ()) -> IO ()
forall r. AsyncSem -> (AbstractSem -> [FilePath] -> IO r) -> IO r
withNewAbstractSem AsyncSem
sem \ ( AbstractSem { forall r. IO r -> IO r
withAbstractSem :: forall r. IO r -> IO r
withAbstractSem :: AbstractSem -> forall r. IO r -> IO r
withAbstractSem } ) [FilePath]
semArgs -> do

              let unitMap :: Lazy.Map UnitId (ConfiguredUnit, Maybe UnitId)
                  unitMap :: Map UnitId (ConfiguredUnit, Maybe UnitId)
unitMap =
                    [(UnitId, (ConfiguredUnit, Maybe UnitId))]
-> Map UnitId (ConfiguredUnit, Maybe UnitId)
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 ]

              (Map (PkgName, Version) (Async ())
_, Map UnitId (Async ())
unitAsyncs) <- ((Map (PkgName, Version) (Async ()), Map UnitId (Async ()))
 -> IO (Map (PkgName, Version) (Async ()), Map UnitId (Async ())))
-> IO (Map (PkgName, Version) (Async ()), Map UnitId (Async ()))
forall a. (a -> IO a) -> IO a
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]
puSetupDepends :: [UnitId]
$sel:puSetupDepends:ConfiguredUnit :: ConfiguredUnit -> [UnitId]
puSetupDepends } ) = do

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

                      [UnitId] -> (UnitId -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [UnitId]
puSetupDepends \ UnitId
setupDepId ->
                        Maybe (Async ()) -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map UnitId (Async ())
unitAsyncs Map UnitId (Async ()) -> UnitId -> Maybe (Async ())
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? UnitId
setupDepId) Async () -> IO ()
forall a. Async a -> IO a
wait

                      -- Setup the package.

                      IO () -> IO ()
forall r. IO r -> IO r
withAbstractSem do
                        BuildScript
setupScript <- ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
cu
                        BuildScript -> IO ()
execBuildScript 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.

                      Async () -> IO ()
forall a. Async a -> IO a
wait (Async () -> IO ()) -> Async () -> IO ()
forall a b. (a -> b) -> a -> b
$ Map (PkgName, Version) (Async ())
pkgAsyncs Map (PkgName, Version) (Async ()) -> (PkgName, Version) -> Async ()
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.

                      [UnitId] -> (UnitId -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ConfiguredUnit -> [UnitId]
unitDepends ConfiguredUnit
pu) \ UnitId
depUnitId ->
                        Maybe (Async ()) -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map UnitId (Async ())
unitAsyncs Map UnitId (Async ()) -> UnitId -> Maybe (Async ())
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? UnitId
depUnitId) Async () -> IO ()
forall a. Async a -> IO a
wait

                      -- Build the unit!

                      IO () -> IO ()
forall r. IO r -> IO r
withAbstractSem (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                        BuildScript -> IO ()
execBuildScript (BuildScript -> IO ()) -> BuildScript -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ConfiguredUnit -> BuildScript
unitBuildScript [FilePath]
semArgs ConfiguredUnit
pu

                -- Kick off setting up the packages...

                Map (PkgName, Version) (Async ())
finalPkgAsyncs  <- Map (PkgName, Version) ConfiguredUnit
-> (ConfiguredUnit -> IO (Async ()))
-> IO (Map (PkgName, Version) (Async ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map (PkgName, Version) ConfiguredUnit
pkgMap  (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ()))
-> (ConfiguredUnit -> IO ()) -> ConfiguredUnit -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfiguredUnit -> IO ()
doPkgSetupAsync)
                -- ... and building the units.

                Map UnitId (Async ())
finalUnitAsyncs <- Map UnitId (ConfiguredUnit, Maybe UnitId)
-> ((ConfiguredUnit, Maybe UnitId) -> IO (Async ()))
-> IO (Map UnitId (Async ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Map UnitId (ConfiguredUnit, Maybe UnitId)
unitMap (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ()))
-> ((ConfiguredUnit, Maybe UnitId) -> IO ())
-> (ConfiguredUnit, Maybe UnitId)
-> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfiguredUnit, Maybe UnitId) -> IO ()
doUnitAsync)
                (Map (PkgName, Version) (Async ()), Map UnitId (Async ()))
-> IO (Map (PkgName, Version) (Async ()), Map UnitId (Async ()))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (PkgName, Version) (Async ())
finalPkgAsyncs, Map UnitId (Async ())
finalUnitAsyncs)
              (Async () -> IO ()) -> Map UnitId (Async ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall a. Async a -> IO a
wait Map UnitId (Async ())
unitAsyncs
              BuildScript -> IO ()
execBuildScript 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."
            BuildScript -> IO ()
execBuildScript BuildScript
preparation
            [(ConfiguredUnit, Maybe UnitId)]
-> ((ConfiguredUnit, Maybe UnitId) -> IO ()) -> IO ()
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
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe UnitId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UnitId
didSetup) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
cu IO BuildScript -> (BuildScript -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BuildScript -> IO ()
execBuildScript
              BuildScript -> IO ()
execBuildScript ([FilePath] -> ConfiguredUnit -> BuildScript
unitBuildScript [] ConfiguredUnit
cu)
            BuildScript -> IO ()
execBuildScript BuildScript
finish

      Script { $sel:scriptPath:Execute :: BuildStrategy -> SymbolicPath CWD 'File
scriptPath = SymbolicPath CWD 'File
fp, Bool
useVariables :: Bool
$sel:useVariables:Execute :: BuildStrategy -> 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      = Word -> Maybe Word
forall a. a -> Maybe a
Just Word
nbUnitsToBuild
                , scriptWorkingDir :: SymbolicPath CWD ('Dir Project)
scriptWorkingDir = SymbolicPath CWD ('Dir Project)
workDir }

        Verbosity -> Text -> IO ()
normalMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"\nWriting build scripts to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack ( SymbolicPath CWD 'File -> FilePath
forall a. Show a => a -> FilePath
show SymbolicPath CWD 'File
fp )
        [BuildScript]
buildScripts <- [(ConfiguredUnit, Maybe UnitId)]
-> ((ConfiguredUnit, Maybe UnitId) -> IO BuildScript)
-> IO [BuildScript]
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   Maybe UnitId -> Bool
forall a. Maybe a -> Bool
isNothing Maybe UnitId
didSetup
                     then ConfiguredUnit -> IO BuildScript
unitSetupScript ConfiguredUnit
cu
                     else BuildScript -> IO BuildScript
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildScript
emptyBuildScript
          let build :: BuildScript
build = [FilePath] -> ConfiguredUnit -> BuildScript
unitBuildScript [] ConfiguredUnit
cu
          BuildScript -> IO BuildScript
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildScript -> IO BuildScript) -> BuildScript -> IO BuildScript
forall a b. (a -> b) -> a -> b
$ BuildScript
mbSetup BuildScript -> BuildScript -> BuildScript
forall a. Semigroup a => a -> a -> a
<> BuildScript
build
        FilePath -> Text -> IO ()
Text.writeFile ( SymbolicPath CWD 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath CWD 'File
fp ) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ScriptConfig -> BuildScript -> Text
script ScriptConfig
scriptConfig (BuildScript -> Text) -> BuildScript -> Text
forall a b. (a -> b) -> a -> b
$
          BuildScript
preparation BuildScript -> BuildScript -> BuildScript
forall a. Semigroup a => a -> a -> a
<> [BuildScript] -> BuildScript
forall a. Monoid a => [a] -> a
mconcat [BuildScript]
buildScripts BuildScript -> BuildScript -> BuildScript
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 = [(UnitId, PlanUnit)] -> Map UnitId PlanUnit
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 ([ConfiguredUnit] -> [ConfiguredUnit])
-> [ConfiguredUnit] -> [ConfiguredUnit]
forall a b. (a -> b) -> a -> b
$ (Int -> ConfiguredUnit) -> [Int] -> [ConfiguredUnit]
forall a b. (a -> b) -> [a] -> [b]
map ((ConfiguredUnit, UnitId, [UnitId]) -> ConfiguredUnit
forall a b c. (a, b, c) -> a
fst3 ((ConfiguredUnit, UnitId, [UnitId]) -> ConfiguredUnit)
-> (Int -> (ConfiguredUnit, UnitId, [UnitId]))
-> Int
-> ConfiguredUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (ConfiguredUnit, UnitId, [UnitId])
lookupVertex) ([Int] -> [ConfiguredUnit]) -> [Int] -> [ConfiguredUnit]
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.

      | Maybe (Set UnitId) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Set UnitId)
mbAlreadyBuilt
      , Maybe [UnitId] -> Bool
forall a. Maybe a -> Bool
isNothing Maybe [UnitId]
mbOnlyDepsOf
      = [ConfiguredUnit] -> [ConfiguredUnit]
forall a. a -> a
id
      | Bool
otherwise
      = (ConfiguredUnit -> Bool) -> [ConfiguredUnit] -> [ConfiguredUnit]
forall a. (a -> Bool) -> [a] -> [a]
filter ConfiguredUnit -> Bool
isInteresting

      where
        isInteresting :: ConfiguredUnit -> Bool
        isInteresting :: ConfiguredUnit -> Bool
isInteresting cu :: ConfiguredUnit
cu@( ConfiguredUnit { UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId } )
          | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfiguredUnit -> Bool
reachable ConfiguredUnit
cu
          = Bool
False
          | Just Set UnitId
alreadyBuilt <- Maybe (Set UnitId)
mbAlreadyBuilt
          , UnitId
puId UnitId -> Set UnitId -> Bool
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 -> Bool -> ConfiguredUnit -> Bool
forall a b. a -> b -> a
const Bool
True
            Just [UnitId]
onlyDepsOf ->
              let reachableUnits :: Set UnitId
                  !reachableUnits :: Set UnitId
reachableUnits
                    = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList
                    ([UnitId] -> Set UnitId) -> [UnitId] -> Set UnitId
forall a b. (a -> b) -> a -> b
$ (Int -> UnitId) -> [Int] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map ( ConfiguredUnit -> UnitId
Configured.puId (ConfiguredUnit -> UnitId)
-> (Int -> ConfiguredUnit) -> Int -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfiguredUnit, UnitId, [UnitId]) -> ConfiguredUnit
forall a b c. (a, b, c) -> a
fst3 ((ConfiguredUnit, UnitId, [UnitId]) -> ConfiguredUnit)
-> (Int -> (ConfiguredUnit, UnitId, [UnitId]))
-> Int
-> ConfiguredUnit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (ConfiguredUnit, UnitId, [UnitId])
lookupVertex )
                    ([Int] -> [UnitId]) -> [Int] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ (Tree Int -> [Int]) -> [Tree Int] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Int -> [Int]
forall a. Tree a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
                    ([Tree Int] -> [Int]) -> [Tree Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Graph -> [Int] -> [Tree Int]
Graph.dfs Graph
gr
                    ([Int] -> [Tree Int]) -> [Int] -> [Tree Int]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Maybe Int) -> [UnitId] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe UnitId -> Maybe Int
mkVertex [UnitId]
onlyDepsOf
              in \ ( ConfiguredUnit { UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId } ) -> UnitId
puId UnitId -> Set UnitId -> Bool
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 ) =
      [(ConfiguredUnit, UnitId, [UnitId])]
-> (Graph, Int -> (ConfiguredUnit, UnitId, [UnitId]),
    UnitId -> Maybe Int)
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
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: 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 Map (PkgName, Version) UnitId
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
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: UnitId
puId } ):[ConfiguredUnit]
cus)
      | UnitId
puId UnitId -> UnitId -> Bool
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 ) <- ((PkgName, Version) -> UnitId -> UnitId -> UnitId)
-> (PkgName, Version)
-> UnitId
-> Map (PkgName, Version) UnitId
-> (Maybe UnitId, Map (PkgName, Version) UnitId)
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) (ConfiguredUnit, Maybe UnitId)
-> [(ConfiguredUnit, Maybe UnitId)]
-> [(ConfiguredUnit, Maybe UnitId)]
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
                  -> PkgDbDir ForPrep
                  -> Map UnitId PlanUnit
                  -> IO ( Set UnitId )
getInstalledUnits :: Verbosity
-> Compiler
-> BuildPaths 'ForPrep
-> PkgDbDir 'ForPrep
-> Map UnitId PlanUnit
-> IO (Set UnitId)
getInstalledUnits Verbosity
verbosity
                  ( Compiler { AbsolutePath 'File
ghcPkgPath :: AbsolutePath 'File
$sel:ghcPkgPath:Compiler :: Compiler -> AbsolutePath 'File
ghcPkgPath } )
                  ( BuildPathsForPrep { AbsolutePath ('Dir Install)
installDir :: AbsolutePath ('Dir Install)
$sel:installDir:BuildPathsForPrep :: BuildPaths 'ForPrep -> AbsolutePath ('Dir Install)
installDir } )
                  ( PkgDbDirForPrep { AbsolutePath ('Dir PkgDb)
finalPkgDbDir :: AbsolutePath ('Dir PkgDb)
$sel:finalPkgDbDir:PkgDbDirForPrep :: PkgDbDir 'ForPrep -> AbsolutePath ('Dir PkgDb)
finalPkgDbDir } )
                  Map UnitId PlanUnit
plan = do
  [FilePath]
pkgVerUnitIds <-
    FilePath -> [FilePath]
words (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    FilePath -> [FilePath] -> FilePath -> IO FilePath
Process.readProcess ( AbsolutePath 'File -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath 'File
ghcPkgPath )
      [ FilePath
"list"
      , Verbosity -> FilePath
ghcPkgVerbosity Verbosity
verbosity
      , FilePath
"--show-unit-ids", FilePath
"--simple-output"
      , FilePath
"--package-db", AbsolutePath ('Dir PkgDb) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir PkgDb)
finalPkgDbDir ]
        -- TODO: allow user package databases too?

      FilePath
""
  let installedLibs :: [UnitId]
installedLibs = (FilePath -> UnitId) -> [FilePath] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map ( Text -> UnitId
UnitId (Text -> UnitId) -> (FilePath -> Text) -> FilePath -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack ) [FilePath]
pkgVerUnitIds
  Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text
"Preinstalled libraries:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines ( (UnitId -> Text) -> [UnitId] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> Text
mkLine [UnitId]
installedLibs )

  [FilePath]
binDirContents <- FilePath -> IO [FilePath]
listDirectory FilePath
binsDir
  [UnitId]
installedBins  <- [Maybe UnitId] -> [UnitId]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UnitId] -> [UnitId]) -> IO [Maybe UnitId] -> IO [UnitId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO (Maybe UnitId)) -> [FilePath] -> IO [Maybe UnitId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM FilePath -> IO (Maybe UnitId)
binDirMaybe [FilePath]
binDirContents
  Verbosity -> Text -> IO ()
verboseMsg Verbosity
verbosity (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    Text
"Preinstalled executables:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines ( (UnitId -> Text) -> [UnitId] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> Text
mkLine [UnitId]
installedBins )

  Set UnitId -> IO (Set UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set UnitId -> IO (Set UnitId)) -> Set UnitId -> IO (Set UnitId)
forall a b. (a -> b) -> a -> b
$ [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
installedLibs Set UnitId -> Set UnitId -> Set UnitId
forall a. Semigroup a => a -> a -> a
<> [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
installedBins
  where

    mkLine :: UnitId -> Text
    mkLine :: UnitId -> Text
mkLine ( UnitId Text
uid ) = Text
"  - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uid

    binsDir :: FilePath
    binsDir :: FilePath
binsDir = AbsolutePath ('Dir Install) -> FilePath
forall (to :: FileOrDir). AbsolutePath to -> FilePath
getAbsolutePath AbsolutePath ('Dir Install)
installDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
"bin"
    binDirMaybe :: FilePath -> IO ( Maybe UnitId )
    binDirMaybe :: FilePath -> IO (Maybe UnitId)
binDirMaybe FilePath
binDir = do
      Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist ( FilePath
binsDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
binDir )
      if Bool -> Bool
not Bool
isDir
      then Maybe UnitId -> IO (Maybe UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnitId
forall a. Maybe a
Nothing
      else
        case Map UnitId PlanUnit
plan Map UnitId PlanUnit -> UnitId -> Maybe PlanUnit
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? ( Text -> UnitId
UnitId (Text -> UnitId) -> Text -> UnitId
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack FilePath
binDir ) of
          -- Is this directory name the 'UnitId' of an executable

          -- in the build plan?

          Just ( PU_Configured ConfiguredUnit
cu )
            | ConfiguredUnit
              { UnitId
$sel:puId:ConfiguredUnit :: ConfiguredUnit -> UnitId
puId :: 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 :: FilePath
exePath = FilePath
binsDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
binDir FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> Text -> FilePath
Text.unpack Text
comp FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
exeExtension
                  Bool
exeExists <- FilePath -> IO Bool
doesFileExist FilePath
exePath
                  if Bool
exeExists
                  then Maybe UnitId -> IO (Maybe UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnitId -> IO (Maybe UnitId))
-> Maybe UnitId -> IO (Maybe UnitId)
forall a b. (a -> b) -> a -> b
$ UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
puId
                  else Maybe UnitId -> IO (Maybe UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnitId
forall a. Maybe a
Nothing
          Maybe PlanUnit
_ -> Maybe UnitId -> IO (Maybe UnitId)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnitId
forall a. Maybe a
Nothing