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

{-|
Module      : Stack.Build
Description : Build the project.
License     : BSD-3-Clause

Build the project.
-}

module Stack.Build
  ( buildCmd
  , build
  , buildLocalTargets
  , loadPackage
  , mkBaseConfigOpts
  , splitObjsWarning
  ) where

import           Data.Attoparsec.Args ( EscapingMode (Escaping), parseArgs )
import qualified Data.Either.Extra as EE
import           Data.List ( (\\) )
import           Data.List.Extra ( groupSort )
import qualified Data.Map as Map
import qualified Data.Set as Set
-- import qualified Distribution.PackageDescription as C

-- import           Distribution.Types.Dependency ( Dependency (..), depLibraries )

import           Distribution.Version ( mkVersion )
import           RIO.NonEmpty ( nonEmpty )
import qualified RIO.NonEmpty as NE
import           Stack.Build.ConstructPlan ( constructPlan )
import           Stack.Build.Execute ( executePlan, preFetch, printPlan )
import           Stack.Build.Installed ( getInstalled, toInstallMap )
import           Stack.Build.Source ( localDependencies, projectLocalPackages )
import           Stack.Build.Target ( NeedTargets (..) )
import           Stack.FileWatch ( fileWatch, fileWatchPoll )
import           Stack.Package ( buildableExes, resolvePackage )
import           Stack.Prelude hiding ( loadPackage )
import           Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig )
import           Stack.Setup ( withNewLocalBuildTargets )
import           Stack.Types.Build.Exception
                   ( BuildException (..), BuildPrettyException (..) )
import           Stack.Types.BuildConfig ( HasBuildConfig, configFileL )
import           Stack.Types.BuildOpts ( BuildOpts (..) )
import           Stack.Types.BuildOptsCLI
                   ( BuildCommand (..), BuildOptsCLI (..), FileWatchOpts (..) )
import           Stack.Types.BuildOptsMonoid
                   ( buildOptsMonoidBenchmarksL, buildOptsMonoidHaddockL
                   , buildOptsMonoidInstallExesL, buildOptsMonoidTestsL
                   )
import           Stack.Types.CompilerPaths ( HasCompiler, cabalVersionL )
import           Stack.Types.ComponentUtils
                   ( StackUnqualCompName, unqualCompToString )
import           Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL )
import           Stack.Types.ConfigureOpts ( BaseConfigOpts (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig (..), HasEnvConfig (..), HasSourceMap
                   , actualCompilerVersionL, installationRootDeps
                   , installationRootLocal, packageDatabaseDeps
                   , packageDatabaseExtra, packageDatabaseLocal
                   )
import           Stack.Types.GlobalOpts ( globalOptsBuildOptsMonoidL )
import           Stack.Types.NamedComponent ( exeComponents )
import           Stack.Types.Package
                   ( InstallLocation (..), LocalPackage (..), Package (..)
                   , PackageConfig (..), lpFiles, lpFilesForComponents
                   )
import           Stack.Types.Plan
                   ( Plan (..), Task (..), TaskType (..), taskLocation
                   , taskProvides
                   )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.Runner ( Runner, globalOptsL )
import           Stack.Types.SourceMap
                   ( SMTargets (..), SourceMap (..), Target (..) )

newtype CabalVersionPrettyException
  = CabalVersionNotSupported Version
  deriving Int -> CabalVersionPrettyException -> ShowS
[CabalVersionPrettyException] -> ShowS
CabalVersionPrettyException -> String
(Int -> CabalVersionPrettyException -> ShowS)
-> (CabalVersionPrettyException -> String)
-> ([CabalVersionPrettyException] -> ShowS)
-> Show CabalVersionPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CabalVersionPrettyException -> ShowS
showsPrec :: Int -> CabalVersionPrettyException -> ShowS
$cshow :: CabalVersionPrettyException -> String
show :: CabalVersionPrettyException -> String
$cshowList :: [CabalVersionPrettyException] -> ShowS
showList :: [CabalVersionPrettyException] -> ShowS
Show

instance Pretty CabalVersionPrettyException where
  pretty :: CabalVersionPrettyException -> StyleDoc
pretty (CabalVersionNotSupported Version
cabalVer) =
    StyleDoc
"[S-5973]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ String -> StyleDoc
flow String
"Stack builds with the version of the Cabal package that comes \
                \with the specified version of GHC. However, Stack no longer \
                \supports such Cabal versions before 2.2. Version"
         , String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
cabalVer
         , String -> StyleDoc
flow String
"was found. To fix this, either use Stack"
         , StyleDoc
downgradeRecommendation
         , String -> StyleDoc
flow String
"or earlier or use a snapshot that specifies a version of GHC \
                \that is 8.4 or later. Stackage LTS Haskell 12.0"
         , StyleDoc -> StyleDoc
parens (Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"lts-12.0")
         , String -> StyleDoc
flow String
"or later or Nightly 2018-03-13"
         , StyleDoc -> StyleDoc
parens (Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"nightly-2018-03-13")
         , String -> StyleDoc
flow String
"or later specify such GHC versions."
         ]
   where
    -- Due to a bug, Stack 2.15.1 does not support Cabal < 2.

    downgradeRecommendation :: StyleDoc
downgradeRecommendation = if Version
cabalVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
2]
      then StyleDoc
"2.15.3 or 2.13.1"
      else StyleDoc
"2.15.3"

instance Exception CabalVersionPrettyException

-- | Helper for build and install commands

buildCmd :: BuildOptsCLI -> RIO Runner ()
buildCmd :: BuildOptsCLI -> RIO Runner ()
buildCmd BuildOptsCLI
opts = do
  Bool -> RIO Runner () -> RIO Runner ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
"-prof" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) ([String] -> Bool) -> (Text -> [String]) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Either String [String] -> [String]
forall b a. b -> Either a b -> b
fromRight [] (Either String [String] -> [String])
-> (Text -> Either String [String]) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EscapingMode -> Text -> Either String [String]
parseArgs EscapingMode
Escaping) BuildOptsCLI
opts.ghcOptions) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
    BuildPrettyException -> RIO Runner ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO BuildPrettyException
GHCProfOptionInvalid
  (Runner -> Runner) -> RIO Runner () -> RIO Runner ()
forall a. (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
    case BuildOptsCLI
opts.fileWatch of
      FileWatchOpts
FileWatchPoll -> (((Set (Path Abs File) -> IO ()) -> RIO Runner ())
 -> RIO EnvConfig ())
-> RIO Runner ()
withFileWatchHook ((Set (Path Abs File) -> IO ()) -> RIO Runner ())
-> RIO EnvConfig ()
forall env.
(HasConfig env, HasTerm env) =>
((Set (Path Abs File) -> IO ()) -> RIO Runner ()) -> RIO env ()
fileWatchPoll
      FileWatchOpts
FileWatch -> (((Set (Path Abs File) -> IO ()) -> RIO Runner ())
 -> RIO EnvConfig ())
-> RIO Runner ()
withFileWatchHook ((Set (Path Abs File) -> IO ()) -> RIO Runner ())
-> RIO EnvConfig ()
forall env.
(HasConfig env, HasTerm env) =>
((Set (Path Abs File) -> IO ()) -> RIO Runner ()) -> RIO env ()
fileWatch
      FileWatchOpts
NoFileWatch -> Maybe (Set (Path Abs File) -> IO ()) -> RIO Runner ()
inner Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing
 where
  withFileWatchHook :: (((Set (Path Abs File) -> IO ()) -> RIO Runner ())
 -> RIO EnvConfig ())
-> RIO Runner ()
withFileWatchHook ((Set (Path Abs File) -> IO ()) -> RIO Runner ())
-> RIO EnvConfig ()
fileWatchAction =
    -- This loads the full configuration in order to obtain the file-watch-hook

    -- setting. That is likely not the most efficient approach.

    ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
NeedTargets BuildOptsCLI
opts (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
      ((Set (Path Abs File) -> IO ()) -> RIO Runner ())
-> RIO EnvConfig ()
fileWatchAction (Maybe (Set (Path Abs File) -> IO ()) -> RIO Runner ()
inner (Maybe (Set (Path Abs File) -> IO ()) -> RIO Runner ())
-> ((Set (Path Abs File) -> IO ())
    -> Maybe (Set (Path Abs File) -> IO ()))
-> (Set (Path Abs File) -> IO ())
-> RIO Runner ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (Path Abs File) -> IO ())
-> Maybe (Set (Path Abs File) -> IO ())
forall a. a -> Maybe a
Just)
  inner ::
       Maybe (Set (Path Abs File) -> IO ())
    -> RIO Runner ()
  inner :: Maybe (Set (Path Abs File) -> IO ()) -> RIO Runner ()
inner Maybe (Set (Path Abs File) -> IO ())
setLocalFiles = ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig () -> RIO Config ()
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
NeedTargets BuildOptsCLI
opts (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$
    Maybe (Set (Path Abs File) -> IO ()) -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
Stack.Build.build Maybe (Set (Path Abs File) -> IO ())
setLocalFiles
  -- Read the build command from the CLI and enable it to run

  modifyGO :: GlobalOpts -> GlobalOpts
modifyGO =
    case BuildOptsCLI
opts.command of
      BuildCommand
Test -> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set
        ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidTestsL)
        (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
      BuildCommand
Haddock -> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set
        ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidHaddockL)
        (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
      BuildCommand
Bench -> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set
        ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidBenchmarksL)
        (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
      BuildCommand
Install -> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
-> Maybe Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a b -> b -> s -> t
set
        ((BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> ASetter GlobalOpts GlobalOpts (Maybe Bool) (Maybe Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidInstallExesL)
        (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
      BuildCommand
Build -> GlobalOpts -> GlobalOpts
forall a. a -> a
id -- Default case is just Build


-- | Build.

--

--   If a buildLock is passed there is an important contract here.  That lock must

--   protect the snapshot, and it must be safe to unlock it if there are no further

--   modifications to the snapshot to be performed by this build.

build :: HasEnvConfig env
      => Maybe (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files

      -> RIO env ()
build :: forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
msetLocalFiles = do
  bopts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
  sourceMap <- view $ envConfigL . to (.sourceMap)
  locals <- projectLocalPackages
  depsLocals <- localDependencies
  boptsCli <- view $ envConfigL . to (.buildOptsCLI)
  -- Set local files, necessary for file watching

  configFile <- view configFileL
  let allLocals = [LocalPackage]
locals [LocalPackage] -> [LocalPackage] -> [LocalPackage]
forall a. Semigroup a => a -> a -> a
<> [LocalPackage]
depsLocals
      -- We are indifferent as to whether the configuration file is a

      -- user-specifc global or a project-level one.

      eitherConfigFile = Either (Path Abs File) (Path Abs File) -> Path Abs File
forall a. Either a a -> a
EE.fromEither Either (Path Abs File) (Path Abs File)
configFile
  for_ msetLocalFiles $ \Set (Path Abs File) -> IO ()
setLocalFiles -> do
    files <-
      if BuildOptsCLI
boptsCli.watchAll
      then [RIO env (Set (Path Abs File))] -> RIO env [Set (Path Abs File)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [LocalPackage -> RIO env (Set (Path Abs File))
forall env.
HasEnvConfig env =>
LocalPackage -> RIO env (Set (Path Abs File))
lpFiles LocalPackage
lp | LocalPackage
lp <- [LocalPackage]
allLocals]
      else [LocalPackage]
-> (LocalPackage -> RIO env (Set (Path Abs File)))
-> RIO env [Set (Path Abs File)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LocalPackage]
allLocals ((LocalPackage -> RIO env (Set (Path Abs File)))
 -> RIO env [Set (Path Abs File)])
-> (LocalPackage -> RIO env (Set (Path Abs File)))
-> RIO env [Set (Path Abs File)]
forall a b. (a -> b) -> a -> b
$ \LocalPackage
lp -> do
        let pn :: PackageName
pn = LocalPackage
lp.package.name
        case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pn SourceMap
sourceMap.targets.targets of
          Maybe Target
Nothing ->
            Set (Path Abs File) -> RIO env (Set (Path Abs File))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set (Path Abs File)
forall a. Set a
Set.empty
          Just (TargetAll PackageType
_) ->
            LocalPackage -> RIO env (Set (Path Abs File))
forall env.
HasEnvConfig env =>
LocalPackage -> RIO env (Set (Path Abs File))
lpFiles LocalPackage
lp
          Just (TargetComps Set NamedComponent
components) ->
            Set NamedComponent -> LocalPackage -> RIO env (Set (Path Abs File))
forall env.
HasEnvConfig env =>
Set NamedComponent -> LocalPackage -> RIO env (Set (Path Abs File))
lpFilesForComponents Set NamedComponent
components LocalPackage
lp
    liftIO $ setLocalFiles $ Set.insert eitherConfigFile $ Set.unions files

  checkComponentsBuildable allLocals

  installMap <- toInstallMap sourceMap
  (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <-
      getInstalled installMap

  baseConfigOpts <- mkBaseConfigOpts boptsCli
  plan <- constructPlan
            baseConfigOpts
            localDumpPkgs
            loadPackage
            sourceMap
            installedMap
            boptsCli.initialBuildSteps

  allowLocals <- view $ configL . to (.allowLocals)
  unless allowLocals $ case justLocals plan of
    [] -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [PackageIdentifier]
localsIdents -> BuildException -> RIO env ()
forall e a. (HasCallStack, Exception e) => e -> RIO env a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [PackageIdentifier] -> BuildException
LocalPackagesPresent [PackageIdentifier]
localsIdents

  checkCabalVersion
  haddockCompsSupported <- warnAboutHaddockComps bopts
  let disableHaddockComps =
        (env -> env) -> RIO env a -> RIO env a
forall a. (env -> env) -> RIO env a -> RIO env a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((env -> env) -> RIO env a -> RIO env a)
-> (env -> env) -> RIO env a -> RIO env a
forall a b. (a -> b) -> a -> b
$ ASetter env env BuildOpts BuildOpts
-> (BuildOpts -> BuildOpts) -> env -> env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter env env BuildOpts BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL ((BuildOpts -> BuildOpts) -> env -> env)
-> (BuildOpts -> BuildOpts) -> env -> env
forall a b. (a -> b) -> a -> b
$ \BuildOpts
bo ->
          BuildOpts
bo
            { haddockExecutables = False
            , haddockTests = False
            , haddockBenchmarks = False
            }
      withHaddockCompsGuarded = if Bool
haddockCompsSupported
        then RIO env () -> RIO env ()
forall a. a -> a
id
        else RIO env () -> RIO env ()
forall {a}. RIO env a -> RIO env a
disableHaddockComps
  warnAboutSplitObjs bopts
  warnIfExecutablesWithSameNameCouldBeOverwritten locals plan

  when bopts.preFetch $
      preFetch plan

  if boptsCli.dryrun
    then
      printPlan plan
    else
      withHaddockCompsGuarded $ executePlan
        boptsCli
        baseConfigOpts
        locals
        globalDumpPkgs
        snapshotDumpPkgs
        localDumpPkgs
        installedMap
        sourceMap.targets.targets
        plan

-- | Build one or more local targets.

buildLocalTargets ::
     HasEnvConfig env
  => NonEmpty Text
     -- ^ Local targets to build.

  -> RIO env (Either SomeException ())
buildLocalTargets :: forall env.
HasEnvConfig env =>
NonEmpty Text -> RIO env (Either SomeException ())
buildLocalTargets NonEmpty Text
targets =
  RIO env () -> RIO env (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO env () -> RIO env (Either SomeException ()))
-> RIO env () -> RIO env (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ [Text] -> RIO env () -> RIO env ()
forall env a. HasEnvConfig env => [Text] -> RIO env a -> RIO env a
withNewLocalBuildTargets (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Text
targets) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing

justLocals :: Plan -> [PackageIdentifier]
justLocals :: Plan -> [PackageIdentifier]
justLocals =
  (Task -> PackageIdentifier) -> [Task] -> [PackageIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map Task -> PackageIdentifier
taskProvides ([Task] -> [PackageIdentifier])
-> (Plan -> [Task]) -> Plan -> [PackageIdentifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Task -> Bool) -> [Task] -> [Task]
forall a. (a -> Bool) -> [a] -> [a]
filter ((InstallLocation -> InstallLocation -> Bool
forall a. Eq a => a -> a -> Bool
== InstallLocation
Local) (InstallLocation -> Bool)
-> (Task -> InstallLocation) -> Task -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Task -> InstallLocation
taskLocation) ([Task] -> [Task]) -> (Plan -> [Task]) -> Plan -> [Task]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Map PackageName Task -> [Task]
forall k a. Map k a -> [a]
Map.elems (Map PackageName Task -> [Task])
-> (Plan -> Map PackageName Task) -> Plan -> [Task]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (.tasks)

checkCabalVersion :: HasEnvConfig env => RIO env ()
checkCabalVersion :: forall env. HasEnvConfig env => RIO env ()
checkCabalVersion = do
  cabalVer <- Getting Version env Version -> RIO env Version
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Version env Version
forall env. HasCompiler env => SimpleGetter env Version
SimpleGetter env Version
cabalVersionL
  when (cabalVer < mkVersion [2, 2]) $
    prettyThrowM $ CabalVersionNotSupported cabalVer

-- | See https://github.com/commercialhaskell/stack/issues/1198.

warnIfExecutablesWithSameNameCouldBeOverwritten ::
     HasTerm env
  => [LocalPackage]
  -> Plan
  -> RIO env ()
warnIfExecutablesWithSameNameCouldBeOverwritten :: forall env. HasTerm env => [LocalPackage] -> Plan -> RIO env ()
warnIfExecutablesWithSameNameCouldBeOverwritten [LocalPackage]
locals Plan
plan = do
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Checking if we are going to build multiple executables with the same name"
  [(StackUnqualCompName, ([PackageName], [PackageName]))]
-> ((StackUnqualCompName, ([PackageName], [PackageName]))
    -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map StackUnqualCompName ([PackageName], [PackageName])
-> [(StackUnqualCompName, ([PackageName], [PackageName]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map StackUnqualCompName ([PackageName], [PackageName])
warnings) (((StackUnqualCompName, ([PackageName], [PackageName]))
  -> RIO env ())
 -> RIO env ())
-> ((StackUnqualCompName, ([PackageName], [PackageName]))
    -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(StackUnqualCompName
exe, ([PackageName]
toBuild, [PackageName]
otherLocals)) -> do
    let exe_s :: StyleDoc
exe_s
          | [PackageName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
toBuild Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 = String -> StyleDoc
flow String
"several executables with the same name:"
          | Bool
otherwise = StyleDoc
"executable"
        exesText :: [PackageName] -> StyleDoc
exesText [PackageName]
pkgs =
          [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ StyleDoc -> [StyleDoc] -> [StyleDoc]
punctuate
            StyleDoc
","
            [ Style -> StyleDoc -> StyleDoc
style
                Style
PkgComponent
                (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> StackUnqualCompName -> String
unqualCompToString StackUnqualCompName
exe)
            | PackageName
p <- [PackageName]
pkgs
            ]
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL ([StyleDoc] -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall a b. (a -> b) -> a -> b
$
         [ StyleDoc
"Building"
         , StyleDoc
exe_s
         , [PackageName] -> StyleDoc
exesText [PackageName]
toBuild StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
      [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Only one of them will be available via"
             , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack exec"
             , String -> StyleDoc
flow String
"or locally installed."
             ]
         | [PackageName] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
toBuild Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
         ]
      [StyleDoc] -> [StyleDoc] -> [StyleDoc]
forall a. Semigroup a => a -> a -> a
<> [ [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Other executables with the same name might be overwritten:"
             , [PackageName] -> StyleDoc
exesText [PackageName]
otherLocals StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
             ]
         | Bool -> Bool
not ([PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
otherLocals)
         ]
 where
  -- Cases of several project packages having executables with the same name.

  -- The Map entries have the following form:

  --

  --  executable name: ( package names for executables that are being built

  --                   , package names for other project packages that have an

  --                     executable with the same name

  --                   )

  warnings :: Map StackUnqualCompName ([PackageName],[PackageName])
  warnings :: Map StackUnqualCompName ([PackageName], [PackageName])
warnings =
    ((NonEmpty PackageName, NonEmpty PackageName)
 -> Maybe ([PackageName], [PackageName]))
-> Map
     StackUnqualCompName (NonEmpty PackageName, NonEmpty PackageName)
-> Map StackUnqualCompName ([PackageName], [PackageName])
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe
      (\(NonEmpty PackageName
pkgsToBuild, NonEmpty PackageName
localPkgs) ->
        case (NonEmpty PackageName
pkgsToBuild, NonEmpty PackageName -> [PackageName]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageName
localPkgs [PackageName] -> [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a] -> [a]
\\ NonEmpty PackageName -> [PackageName]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageName
pkgsToBuild) of
          (PackageName
_ :| [], []) ->
            -- We want to build the executable of single project package

            -- and there are no other project packages with an executable of

            -- the same name. Nothing to warn about, ignore.

            Maybe ([PackageName], [PackageName])
forall a. Maybe a
Nothing
          (NonEmpty PackageName
_, [PackageName]
otherLocals) ->
            -- We could be here for two reasons (or their combination):

            -- 1) We are building two or more executables with the same

            --    name that will end up overwriting each other.

            -- 2) In addition to the executable(s) that we want to build

            --    there are other project packages with an executable of the

            --    same name that might get overwritten.

            -- Both cases warrant a warning.

            ([PackageName], [PackageName])
-> Maybe ([PackageName], [PackageName])
forall a. a -> Maybe a
Just (NonEmpty PackageName -> [PackageName]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageName
pkgsToBuild, [PackageName]
otherLocals))
      ((NonEmpty PackageName
 -> NonEmpty PackageName
 -> (NonEmpty PackageName, NonEmpty PackageName))
-> Map StackUnqualCompName (NonEmpty PackageName)
-> Map StackUnqualCompName (NonEmpty PackageName)
-> Map
     StackUnqualCompName (NonEmpty PackageName, NonEmpty PackageName)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map StackUnqualCompName (NonEmpty PackageName)
exesToBuild Map StackUnqualCompName (NonEmpty PackageName)
localExes)
  exesToBuild :: Map StackUnqualCompName (NonEmpty PackageName)
  exesToBuild :: Map StackUnqualCompName (NonEmpty PackageName)
exesToBuild =
    [(StackUnqualCompName, PackageName)]
-> Map StackUnqualCompName (NonEmpty PackageName)
forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect
      [ (StackUnqualCompName
exe, PackageName
pkgName')
      | (PackageName
pkgName', Task
task) <- Map PackageName Task -> [(PackageName, Task)]
forall k a. Map k a -> [(k, a)]
Map.toList Plan
plan.tasks
      , TTLocalMutable LocalPackage
lp <- [Task
task.taskType]
      , StackUnqualCompName
exe <- (Set StackUnqualCompName -> [StackUnqualCompName]
forall a. Set a -> [a]
Set.toList (Set StackUnqualCompName -> [StackUnqualCompName])
-> (LocalPackage -> Set StackUnqualCompName)
-> LocalPackage
-> [StackUnqualCompName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set StackUnqualCompName
exeComponents (Set NamedComponent -> Set StackUnqualCompName)
-> (LocalPackage -> Set NamedComponent)
-> LocalPackage
-> Set StackUnqualCompName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.components)) LocalPackage
lp
      ]
  localExes :: Map StackUnqualCompName (NonEmpty PackageName)
  localExes :: Map StackUnqualCompName (NonEmpty PackageName)
localExes =
    [(StackUnqualCompName, PackageName)]
-> Map StackUnqualCompName (NonEmpty PackageName)
forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect
      [ (StackUnqualCompName
exe, Package
pkg.name)
      | Package
pkg <- (LocalPackage -> Package) -> [LocalPackage] -> [Package]
forall a b. (a -> b) -> [a] -> [b]
map (.package) [LocalPackage]
locals
      , StackUnqualCompName
exe <- Set StackUnqualCompName -> [StackUnqualCompName]
forall a. Set a -> [a]
Set.toList (Package -> Set StackUnqualCompName
buildableExes Package
pkg)
      ]
  collect :: Ord k => [(k, v)] -> Map k (NonEmpty v)
  collect :: forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect = ([v] -> Maybe (NonEmpty v)) -> Map k [v] -> Map k (NonEmpty v)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe [v] -> Maybe (NonEmpty v)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Map k [v] -> Map k (NonEmpty v))
-> ([(k, v)] -> Map k [v]) -> [(k, v)] -> Map k (NonEmpty v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, [v])] -> Map k [v]
forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList ([(k, [v])] -> Map k [v])
-> ([(k, v)] -> [(k, [v])]) -> [(k, v)] -> Map k [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(k, v)] -> [(k, [v])]
forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort

warnAboutHaddockComps ::
     (HasCompiler env, HasTerm env)
  => BuildOpts
  -> RIO env Bool
warnAboutHaddockComps :: forall env.
(HasCompiler env, HasTerm env) =>
BuildOpts -> RIO env Bool
warnAboutHaddockComps BuildOpts
bopts = do
  let haddockCompsWanted :: Bool
haddockCompsWanted =
           BuildOpts
bopts.haddockExecutables
        Bool -> Bool -> Bool
|| BuildOpts
bopts.haddockTests
        Bool -> Bool -> Bool
|| BuildOpts
bopts.haddockBenchmarks
  cabalVer <- Getting Version env Version -> RIO env Version
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Version env Version
forall env. HasCompiler env => SimpleGetter env Version
SimpleGetter env Version
cabalVersionL
  if haddockCompsWanted && cabalVer < mkVersion [3, 8, 1]
    then do
      prettyWarnL
        [ flow "Stack builds Haddock documentation with the version of the \
               \Cabal package that comes with the specified version of GHC. \
               \Version"
        , fromString $ versionString cabalVer
        , flow "was found, which does not support the building of \
               \documentation for executables, test suites or benchmarks. \
               \Options to build such documentation will be ignored. To use \
               \the options, use a snapshot that specifies a version of GHC \
               \that is 9.4 or later. Stackage LTS Haskell 21.0"
        , parens (style Shell "lts-21.0")
        , flow "or later or Nightly 2022-11-19"
        , parens (style Shell "nightly-2022-11-19")
        , flow "or later specify such GHC versions."
        ]
      pure False
    else pure haddockCompsWanted

warnAboutSplitObjs :: HasTerm env => BuildOpts -> RIO env ()
warnAboutSplitObjs :: forall env. HasTerm env => BuildOpts -> RIO env ()
warnAboutSplitObjs BuildOpts
bopts |  BuildOpts
bopts.splitObjs =
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
    [ String -> StyleDoc
flow String
"Building with"
    , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--split-objs"
    , String -> StyleDoc
flow String
"is enabled."
    , String -> StyleDoc
flow String
splitObjsWarning
    ]
warnAboutSplitObjs BuildOpts
_ = () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Text warning about the experimental nature of Stack's @--split-objs@ flag.

splitObjsWarning :: String
splitObjsWarning :: String
splitObjsWarning =
  String
"Note that this feature is EXPERIMENTAL, and its behavior may be changed and \
  \improved. You will need to clean your workdirs before use. If you want to \
  \compile all dependencies with split-objs, you will need to delete the \
  \snapshot (and all snapshots that could reference that snapshot)."

-- | Get the @BaseConfigOpts@ necessary for constructing configure options

mkBaseConfigOpts :: (HasEnvConfig env)
                 => BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts :: forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
buildOptsCLI = do
  buildOpts <- Getting BuildOpts env BuildOpts -> RIO env BuildOpts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildOpts env BuildOpts
forall s. HasConfig s => Lens' s BuildOpts
Lens' env BuildOpts
buildOptsL
  snapDB <- packageDatabaseDeps
  localDB <- packageDatabaseLocal
  snapInstallRoot <- installationRootDeps
  localInstallRoot <- installationRootLocal
  extraDBs <- packageDatabaseExtra
  pure BaseConfigOpts
    { snapDB
    , localDB
    , snapInstallRoot
    , localInstallRoot
    , buildOpts
    , buildOptsCLI
    , extraDBs
    }

-- | Provide a function for loading package information from the package index

loadPackage ::
     (HasBuildConfig env, HasSourceMap env)
  => PackageLocationImmutable
  -> Map FlagName Bool
  -> [Text] -- ^ GHC options

  -> [Text] -- ^ Cabal configure options

  -> RIO env Package
loadPackage :: forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
loadPackage PackageLocationImmutable
loc Map FlagName Bool
flags [Text]
ghcOptions [Text]
cabalConfigOpts = do
  compilerVersion <- Getting ActualCompiler env ActualCompiler -> RIO env ActualCompiler
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ActualCompiler env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionL
  platform <- view platformL
  let pkgConfig = PackageConfig
        { enableTests :: Bool
enableTests = Bool
False
        , enableBenchmarks :: Bool
enableBenchmarks = Bool
False
        , Map FlagName Bool
flags :: Map FlagName Bool
flags :: Map FlagName Bool
flags
        , [Text]
ghcOptions :: [Text]
ghcOptions :: [Text]
ghcOptions
        , [Text]
cabalConfigOpts :: [Text]
cabalConfigOpts :: [Text]
cabalConfigOpts
        , ActualCompiler
compilerVersion :: ActualCompiler
compilerVersion :: ActualCompiler
compilerVersion
        , Platform
platform :: Platform
platform :: Platform
platform
        }
  resolvePackage pkgConfig <$> loadCabalFileImmutable loc

checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable :: forall (m :: * -> *). MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable [LocalPackage]
lps =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(PackageName, NamedComponent)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, NamedComponent)]
unbuildable) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    BuildPrettyException -> m ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (BuildPrettyException -> m ()) -> BuildPrettyException -> m ()
forall a b. (a -> b) -> a -> b
$ [(PackageName, NamedComponent)] -> BuildPrettyException
SomeTargetsNotBuildable [(PackageName, NamedComponent)]
unbuildable
 where
  unbuildable :: [(PackageName, NamedComponent)]
unbuildable =
    [ (LocalPackage
lp.package.name, NamedComponent
c)
    | LocalPackage
lp <- [LocalPackage]
lps
    , NamedComponent
c <- Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList LocalPackage
lp.unbuildable
    ]