{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Build the project.


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

import           Stack.Prelude hiding (loadPackage)
import           Data.Aeson (Value (Object, Array), (.=), object)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.List ((\\), isPrefixOf)
import           Data.List.Extra (groupSort)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as TIO
import           Data.Text.Read (decimal)
import qualified Data.Vector as V
import qualified Data.Yaml as Yaml
import qualified Distribution.PackageDescription as C
import           Distribution.Types.Dependency (depLibraries)
import           Distribution.Version (mkVersion)
import           Path (parent)
import           Stack.Build.ConstructPlan
import           Stack.Build.Execute
import           Stack.Build.Installed
import           Stack.Build.Source
import           Stack.Package
import           Stack.Setup (withNewLocalBuildTargets)
import           Stack.Types.Build
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.SourceMap

import           Stack.Types.Compiler (compilerVersionText, getGhcVersion)
import           System.Terminal (fixCodePage)

-- | 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
  Bool
mcp <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configModifyCodePage
  Version
ghcVersion <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Version
getGhcVersion
  forall x y a. x -> y -> a -> a
fixCodePage Bool
mcp Version
ghcVersion forall a b. (a -> b) -> a -> b
$ do
    BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
    SourceMap
sourceMap <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
    [LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    [LocalPackage]
depsLocals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
    let allLocals :: [LocalPackage]
allLocals = [LocalPackage]
locals forall a. Semigroup a => a -> a -> a
<> [LocalPackage]
depsLocals

    forall env. HasLogFunc env => [ProjectPackage] -> RIO env ()
checkSubLibraryDependencies (forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ SourceMap -> Map PackageName ProjectPackage
smProject SourceMap
sourceMap)

    BuildOptsCLI
boptsCli <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasEnvConfig env => Lens' env EnvConfig
envConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> BuildOptsCLI
envConfigBuildOptsCLI
    -- Set local files, necessary for file watching

    Path Abs File
stackYaml <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env (Path Abs File)
stackYamlL
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Set (Path Abs File) -> IO ())
msetLocalFiles forall a b. (a -> b) -> a -> b
$ \Set (Path Abs File) -> IO ()
setLocalFiles -> do
      [Set (Path Abs File)]
files <-
        if BuildOptsCLI -> Bool
boptsCLIWatchAll BuildOptsCLI
boptsCli
        then forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall env.
HasEnvConfig env =>
LocalPackage -> RIO env (Set (Path Abs File))
lpFiles LocalPackage
lp | LocalPackage
lp <- [LocalPackage]
allLocals]
        else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LocalPackage]
allLocals forall a b. (a -> b) -> a -> b
$ \LocalPackage
lp -> do
          let pn :: PackageName
pn = Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
lp)
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pn (SMTargets -> Map PackageName Target
smtTargets forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap) of
            Maybe Target
Nothing ->
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
Set.empty
            Just (TargetAll PackageType
_) ->
              forall env.
HasEnvConfig env =>
LocalPackage -> RIO env (Set (Path Abs File))
lpFiles LocalPackage
lp
            Just (TargetComps Set NamedComponent
components) ->
              forall env.
HasEnvConfig env =>
Set NamedComponent -> LocalPackage -> RIO env (Set (Path Abs File))
lpFilesForComponents Set NamedComponent
components LocalPackage
lp
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Set (Path Abs File) -> IO ()
setLocalFiles forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
Set.insert Path Abs File
stackYaml forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set (Path Abs File)]
files

    forall (m :: * -> *). MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable [LocalPackage]
allLocals

    InstallMap
installMap <- forall (m :: * -> *). MonadIO m => SourceMap -> m InstallMap
toInstallMap SourceMap
sourceMap
    (InstalledMap
installedMap, [DumpPackage]
globalDumpPkgs, [DumpPackage]
snapshotDumpPkgs, [DumpPackage]
localDumpPkgs) <-
        forall env.
HasEnvConfig env =>
InstallMap
-> RIO
     env (InstalledMap, [DumpPackage], [DumpPackage], [DumpPackage])
getInstalled InstallMap
installMap

    BaseConfigOpts
baseConfigOpts <- forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
    Plan
plan <- forall env.
HasEnvConfig env =>
BaseConfigOpts
-> [DumpPackage]
-> (PackageLocationImmutable
    -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package)
-> SourceMap
-> InstalledMap
-> Bool
-> RIO env Plan
constructPlan BaseConfigOpts
baseConfigOpts [DumpPackage]
localDumpPkgs forall env.
(HasBuildConfig env, HasSourceMap env) =>
PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO env Package
loadPackage SourceMap
sourceMap InstalledMap
installedMap (BuildOptsCLI -> Bool
boptsCLIInitialBuildSteps BuildOptsCLI
boptsCli)

    Bool
allowLocals <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowLocals
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowLocals forall a b. (a -> b) -> a -> b
$ case Plan -> [PackageIdentifier]
justLocals Plan
plan of
      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [PackageIdentifier]
localsIdents -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [PackageIdentifier] -> StackBuildException
LocalPackagesPresent [PackageIdentifier]
localsIdents

    forall env. HasEnvConfig env => RIO env ()
checkCabalVersion
    forall env. HasLogFunc env => BuildOpts -> RIO env ()
warnAboutSplitObjs BuildOpts
bopts
    forall env. HasLogFunc env => [LocalPackage] -> Plan -> RIO env ()
warnIfExecutablesWithSameNameCouldBeOverwritten [LocalPackage]
locals Plan
plan

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BuildOpts -> Bool
boptsPreFetch BuildOpts
bopts) forall a b. (a -> b) -> a -> b
$
        forall env. HasEnvConfig env => Plan -> RIO env ()
preFetch Plan
plan

    if BuildOptsCLI -> Bool
boptsCLIDryrun BuildOptsCLI
boptsCli
        then forall env. HasRunner env => Plan -> RIO env ()
printPlan Plan
plan
        else forall env.
HasEnvConfig env =>
BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> InstalledMap
-> Map PackageName Target
-> Plan
-> RIO env ()
executePlan BuildOptsCLI
boptsCli BaseConfigOpts
baseConfigOpts [LocalPackage]
locals
                         [DumpPackage]
globalDumpPkgs
                         [DumpPackage]
snapshotDumpPkgs
                         [DumpPackage]
localDumpPkgs
                         InstalledMap
installedMap
                         (SMTargets -> Map PackageName Target
smtTargets forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap)
                         Plan
plan

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

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

checkCabalVersion :: HasEnvConfig env => RIO env ()
checkCabalVersion :: forall env. HasEnvConfig env => RIO env ()
checkCabalVersion = do
    Bool
allowNewer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasConfig env => Lens' env Config
configLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
    Version
cabalVer <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasCompiler env => SimpleGetter env Version
cabalVersionL
    -- https://github.com/haskell/cabal/issues/2023

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
allowNewer Bool -> Bool -> Bool
&& Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
22]) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
        [Char] -> CabalVersionException
CabalVersionException forall a b. (a -> b) -> a -> b
$
            [Char]
"Error: --allow-newer requires at least Cabal version 1.22, but version " forall a. [a] -> [a] -> [a]
++
            Version -> [Char]
versionString Version
cabalVer forall a. [a] -> [a] -> [a]
++
            [Char]
" was found."
    -- Since --exact-configuration is always passed, some old cabal

    -- versions can no longer be used. See the following link for why

    -- it's 1.19.2:

    -- https://github.com/haskell/cabal/blob/580fe6b6bf4e1648b2f66c1cb9da9f1f1378492c/cabal-install/Distribution/Client/Setup.hs#L592

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
cabalVer forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
19, Int
2]) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$
        [Char] -> CabalVersionException
CabalVersionException forall a b. (a -> b) -> a -> b
$
            [Char]
"Stack no longer supports Cabal versions older than 1.19.2, but version " forall a. [a] -> [a] -> [a]
++
            Version -> [Char]
versionString Version
cabalVer forall a. [a] -> [a] -> [a]
++
            [Char]
" was found.  To fix this, consider updating the resolver to lts-3.0 or later / nightly-2015-05-05 or later."

newtype CabalVersionException = CabalVersionException { CabalVersionException -> [Char]
unCabalVersionException :: String }
    deriving (Typeable)

instance Show CabalVersionException where show :: CabalVersionException -> [Char]
show = CabalVersionException -> [Char]
unCabalVersionException
instance Exception CabalVersionException

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

warnIfExecutablesWithSameNameCouldBeOverwritten
    :: HasLogFunc env => [LocalPackage] -> Plan -> RIO env ()
warnIfExecutablesWithSameNameCouldBeOverwritten :: forall env. HasLogFunc env => [LocalPackage] -> Plan -> RIO env ()
warnIfExecutablesWithSameNameCouldBeOverwritten [LocalPackage]
locals Plan
plan = do
    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"
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map Text ([PackageName], [PackageName])
warnings) forall a b. (a -> b) -> a -> b
$ \(Text
exe,([PackageName]
toBuild,[PackageName]
otherLocals)) -> do
        let exe_s :: Text
exe_s
                | forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
toBuild forall a. Ord a => a -> a -> Bool
> Int
1 = Text
"several executables with the same name:"
                | Bool
otherwise = Text
"executable"
            exesText :: [PackageName] -> Text
exesText [PackageName]
pkgs =
                Text -> [Text] -> Text
T.intercalate
                    Text
", "
                    [Text
"'" forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
p) forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> Text
exe forall a. Semigroup a => a -> a -> a
<> Text
"'" | PackageName
p <- [PackageName]
pkgs]
        (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
            [ [ Text
"Building " forall a. Semigroup a => a -> a -> a
<> Text
exe_s forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> [PackageName] -> Text
exesText [PackageName]
toBuild forall a. Semigroup a => a -> a -> a
<> Text
"." ]
            , [ Text
"Only one of them will be available via 'stack exec' or locally installed."
              | forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
toBuild forall a. Ord a => a -> a -> Bool
> Int
1
              ]
            , [ Text
"Other executables with the same name might be overwritten: " forall a. Semigroup a => a -> a -> a
<>
                [PackageName] -> Text
exesText [PackageName]
otherLocals forall a. Semigroup a => a -> a -> a
<> Text
"."
              | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
otherLocals)
              ]
            ]
  where
    -- Cases of several local 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 local packages that have an

    --                     executable with the same name

    --                   )

    warnings :: Map Text ([PackageName],[PackageName])
    warnings :: Map Text ([PackageName], [PackageName])
warnings =
        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,forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageName
localPkgs forall a. Eq a => [a] -> [a] -> [a]
\\ forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageName
pkgsToBuild) of
                    (PackageName
_ :| [],[]) ->
                        -- We want to build the executable of single local package

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

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

                        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 local packages with an executable of the

                        --    same name that might get overwritten.

                        -- Both cases warrant a warning.

                        forall a. a -> Maybe a
Just (forall a. NonEmpty a -> [a]
NE.toList NonEmpty PackageName
pkgsToBuild,[PackageName]
otherLocals))
            (forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map Text (NonEmpty PackageName)
exesToBuild Map Text (NonEmpty PackageName)
localExes)
    exesToBuild :: Map Text (NonEmpty PackageName)
    exesToBuild :: Map Text (NonEmpty PackageName)
exesToBuild =
        forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect
            [ (Text
exe,PackageName
pkgName')
            | (PackageName
pkgName',Task
task) <- forall k a. Map k a -> [(k, a)]
Map.toList (Plan -> Map PackageName Task
planTasks Plan
plan)
            , TTLocalMutable LocalPackage
lp <- [Task -> TaskType
taskType Task
task]
            , Text
exe <- (forall a. Set a -> [a]
Set.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
exeComponents forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPackage -> Set NamedComponent
lpComponents) LocalPackage
lp
            ]
    localExes :: Map Text (NonEmpty PackageName)
    localExes :: Map Text (NonEmpty PackageName)
localExes =
        forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect
            [ (Text
exe,Package -> PackageName
packageName Package
pkg)
            | Package
pkg <- forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Package
lpPackage [LocalPackage]
locals
            , Text
exe <- forall a. Set a -> [a]
Set.toList (Package -> Set Text
packageExes Package
pkg)
            ]
    collect :: Ord k => [(k,v)] -> Map k (NonEmpty v)
    collect :: forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. [(k, a)] -> Map k a
Map.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => [(k, v)] -> [(k, [v])]
groupSort

warnAboutSplitObjs :: HasLogFunc env => BuildOpts -> RIO env ()
warnAboutSplitObjs :: forall env. HasLogFunc env => BuildOpts -> RIO env ()
warnAboutSplitObjs BuildOpts
bopts | BuildOpts -> Bool
boptsSplitObjs BuildOpts
bopts = do
    forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Building with --split-objs is enabled. " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
splitObjsWarning
warnAboutSplitObjs BuildOpts
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

splitObjsWarning :: String
splitObjsWarning :: [Char]
splitObjsWarning = [[Char]] -> [Char]
unwords
     [ [Char]
"Note that this feature is EXPERIMENTAL, and its behavior may be changed and improved."
     , [Char]
"You will need to clean your workdirs before use. If you want to compile all dependencies"
     , [Char]
"with split-objs, you will need to delete the snapshot (and all snapshots that could"
     , [Char]
"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
boptsCli = do
    BuildOpts
bopts <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s. HasConfig s => Lens' s BuildOpts
buildOptsL
    Path Abs Dir
snapDBPath <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
    Path Abs Dir
localDBPath <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
    Path Abs Dir
snapInstallRoot <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
    Path Abs Dir
localInstallRoot <- forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
    [Path Abs Dir]
packageExtraDBs <- forall env (m :: * -> *).
(MonadReader env m, HasEnvConfig env) =>
m [Path Abs Dir]
packageDatabaseExtra
    forall (m :: * -> *) a. Monad m => a -> m a
return BaseConfigOpts
        { bcoSnapDB :: Path Abs Dir
bcoSnapDB = Path Abs Dir
snapDBPath
        , bcoLocalDB :: Path Abs Dir
bcoLocalDB = Path Abs Dir
localDBPath
        , bcoSnapInstallRoot :: Path Abs Dir
bcoSnapInstallRoot = Path Abs Dir
snapInstallRoot
        , bcoLocalInstallRoot :: Path Abs Dir
bcoLocalInstallRoot = Path Abs Dir
localInstallRoot
        , bcoBuildOpts :: BuildOpts
bcoBuildOpts = BuildOpts
bopts
        , bcoBuildOptsCLI :: BuildOptsCLI
bcoBuildOptsCLI = BuildOptsCLI
boptsCli
        , bcoExtraDBs :: [Path Abs Dir]
bcoExtraDBs = [Path Abs Dir]
packageExtraDBs
        }

-- | 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
  ActualCompiler
compiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionL
  Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
  let pkgConfig :: PackageConfig
pkgConfig = PackageConfig
        { packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
False
        , packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
False
        , packageConfigFlags :: Map FlagName Bool
packageConfigFlags = Map FlagName Bool
flags
        , packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = [Text]
ghcOptions
        , packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = [Text]
cabalConfigOpts
        , packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
compiler
        , packageConfigPlatform :: Platform
packageConfigPlatform = Platform
platform
        }
  PackageConfig -> GenericPackageDescription -> Package
resolvePackage PackageConfig
pkgConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocationImmutable -> RIO env GenericPackageDescription
loadCabalFileImmutable PackageLocationImmutable
loc

-- | Query information about the build and print the result to stdout in YAML format.

queryBuildInfo :: HasEnvConfig env
               => [Text] -- ^ selectors

               -> RIO env ()
queryBuildInfo :: forall env. HasEnvConfig env => [Text] -> RIO env ()
queryBuildInfo [Text]
selectors0 =
        forall env. HasEnvConfig env => RIO env Value
rawBuildInfo
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {m :: * -> *} {a}.
(MonadIO m, Show a) =>
([Text] -> a) -> [Text] -> Value -> m Value
select forall a. a -> a
id [Text]
selectors0
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
TIO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addGlobalHintsComment forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Yaml.encode
  where
    select :: ([Text] -> a) -> [Text] -> Value -> m Value
select [Text] -> a
_ [] Value
value = forall (m :: * -> *) a. Monad m => a -> m a
return Value
value
    select [Text] -> a
front (Text
sel:[Text]
sels) Value
value =
        case Value
value of
            Object Object
o ->
                case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
sel) Object
o of
                    Maybe Value
Nothing -> forall {m :: * -> *} {a}. MonadIO m => [Char] -> m a
err [Char]
"Selector not found"
                    Just Value
value' -> Value -> m Value
cont Value
value'
            Array Array
v ->
                case forall a. Integral a => Reader a
decimal Text
sel of
                    Right (Int
i, Text
"")
                        | Int
i forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i forall a. Ord a => a -> a -> Bool
< forall a. Vector a -> Int
V.length Array
v -> Value -> m Value
cont forall a b. (a -> b) -> a -> b
$ Array
v forall a. Vector a -> Int -> a
V.! Int
i
                        | Bool
otherwise -> forall {m :: * -> *} {a}. MonadIO m => [Char] -> m a
err [Char]
"Index out of range"
                    Either [Char] (Int, Text)
_ -> forall {m :: * -> *} {a}. MonadIO m => [Char] -> m a
err [Char]
"Encountered array and needed numeric selector"
            Value
_ -> forall {m :: * -> *} {a}. MonadIO m => [Char] -> m a
err forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot apply selector to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
value
      where
        cont :: Value -> m Value
cont = ([Text] -> a) -> [Text] -> Value -> m Value
select ([Text] -> a
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
selforall a. a -> [a] -> [a]
:)) [Text]
sels
        err :: [Char] -> m a
err [Char]
msg = forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString forall a b. (a -> b) -> a -> b
$ [Char]
msg forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ([Text] -> a
front [Text
sel])
    -- Include comments to indicate that this portion of the "stack

    -- query" API is not necessarily stable.

    addGlobalHintsComment :: Text -> Text
addGlobalHintsComment
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
selectors0 = Text -> Text -> Text -> Text
T.replace Text
globalHintsLine (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment forall a. Semigroup a => a -> a -> a
<> Text
globalHintsLine)
      -- Append comment instead of pre-pending. The reasoning here is

      -- that something *could* expect that the result of 'stack query

      -- global-hints ghc-boot' is just a string literal. Seems easier

      -- for to expect the first line of the output to be the literal.

      | [Text
"global-hints"] forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Text]
selectors0 = (forall a. Semigroup a => a -> a -> a
<> (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment))
      | Bool
otherwise = forall a. a -> a
id
    globalHintsLine :: Text
globalHintsLine = Text
"\nglobal-hints:\n"
    globalHintsComment :: Text
globalHintsComment = [Text] -> Text
T.concat
      [ Text
"# Note: global-hints is experimental and may be renamed / removed in the future.\n"
      , Text
"# See https://github.com/commercialhaskell/stack/issues/3796"
      ]
-- | Get the raw build information object

rawBuildInfo :: HasEnvConfig env => RIO env Value
rawBuildInfo :: forall env. HasEnvConfig env => RIO env Value
rawBuildInfo = do
    [LocalPackage]
locals <- forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    Text
wantedCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
    Text
actualCompiler <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasSourceMap env => SimpleGetter env ActualCompiler
actualCompilerVersionLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Text
compilerVersionText
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
        [ Key
"locals" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object (forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Pair
localToPair [LocalPackage]
locals)
        , Key
"compiler" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"wanted" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
wantedCompiler
            , Key
"actual" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
actualCompiler
            ]
        ]
  where
    localToPair :: LocalPackage -> Pair
localToPair LocalPackage
lp =
        (Text -> Key
Key.fromText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ Package -> PackageName
packageName Package
p, Value
value)
      where
        p :: Package
p = LocalPackage -> Package
lpPackage LocalPackage
lp
        value :: Value
value = [Pair] -> Value
object
            [ Key
"version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. a -> CabalString a
CabalString (Package -> Version
packageVersion Package
p)
            , Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall b t. Path b t -> [Char]
toFilePath (forall b t. Path b t -> Path b Dir
parent forall a b. (a -> b) -> a -> b
$ LocalPackage -> Path Abs File
lpCabalFile LocalPackage
lp)
            ]

checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable :: forall (m :: * -> *). MonadThrow m => [LocalPackage] -> m ()
checkComponentsBuildable [LocalPackage]
lps =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, NamedComponent)]
unbuildable) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [(PackageName, NamedComponent)] -> StackBuildException
SomeTargetsNotBuildable [(PackageName, NamedComponent)]
unbuildable
  where
    unbuildable :: [(PackageName, NamedComponent)]
unbuildable =
        [ (Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
lp), NamedComponent
c)
        | LocalPackage
lp <- [LocalPackage]
lps
        , NamedComponent
c <- forall a. Set a -> [a]
Set.toList (LocalPackage -> Set NamedComponent
lpUnbuildable LocalPackage
lp)
        ]

-- | Find if sublibrary dependency exist in each project

checkSubLibraryDependencies :: HasLogFunc env => [ProjectPackage] -> RIO env ()
checkSubLibraryDependencies :: forall env. HasLogFunc env => [ProjectPackage] -> RIO env ()
checkSubLibraryDependencies [ProjectPackage]
proj = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProjectPackage]
proj forall a b. (a -> b) -> a -> b
$ \ProjectPackage
p -> do
    C.GenericPackageDescription PackageDescription
_ Maybe Version
_ [PackageFlag]
_ Maybe (CondTree ConfVar [Dependency] Library)
lib [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
subLibs [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
foreignLibs [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exes [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
tests [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benches <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon forall a b. (a -> b) -> a -> b
$ ProjectPackage
p

    let dependencies :: [Dependency]
dependencies = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {v} {c} {a}. (a, CondTree v c a) -> c
getDeps [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
subLibs forall a. Semigroup a => a -> a -> a
<>
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {v} {c} {a}. (a, CondTree v c a) -> c
getDeps [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)]
foreignLibs forall a. Semigroup a => a -> a -> a
<>
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {v} {c} {a}. (a, CondTree v c a) -> c
getDeps [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)]
exes forall a. Semigroup a => a -> a -> a
<>
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {v} {c} {a}. (a, CondTree v c a) -> c
getDeps [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)]
tests forall a. Semigroup a => a -> a -> a
<>
                       forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {v} {c} {a}. (a, CondTree v c a) -> c
getDeps [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)]
benches forall a. Semigroup a => a -> a -> a
<>
                       forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall v c a. CondTree v c a -> c
C.condTreeConstraints Maybe (CondTree ConfVar [Dependency] Library)
lib
        libraries :: [LibraryName]
libraries = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> NonEmptySet LibraryName
depLibraries) [Dependency]
dependencies

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall {t :: * -> *}. Foldable t => t LibraryName -> Bool
subLibDepExist [LibraryName]
libraries)
      (forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"SubLibrary dependency is not supported, this will almost certainly fail")
  where
    getDeps :: (a, CondTree v c a) -> c
getDeps (a
_, C.CondNode a
_ c
dep [CondBranch v c a]
_) = c
dep
    subLibDepExist :: t LibraryName -> Bool
subLibDepExist t LibraryName
lib =
      forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\LibraryName
x ->
        case LibraryName
x of
          C.LSubLibName UnqualComponentName
_ -> Bool
True
          LibraryName
C.LMainLibName  -> Bool
False
      ) t LibraryName
lib