{-# 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           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.Prelude hiding ( loadPackage )
import           Stack.Setup ( withNewLocalBuildTargets )
import           Stack.Types.Build
import           Stack.Types.Compiler ( compilerVersionText, getGhcVersion )
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.SourceMap
import           System.Terminal ( fixCodePage )

data CabalVersionException
    = AllowNewerNotSupported Version
    | CabalVersionNotSupported Version
    deriving (Int -> CabalVersionException -> ShowS
[CabalVersionException] -> ShowS
CabalVersionException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CabalVersionException] -> ShowS
$cshowList :: [CabalVersionException] -> ShowS
show :: CabalVersionException -> [Char]
$cshow :: CabalVersionException -> [Char]
showsPrec :: Int -> CabalVersionException -> ShowS
$cshowsPrec :: Int -> CabalVersionException -> ShowS
Show, Typeable)

instance Exception CabalVersionException where
    displayException :: CabalVersionException -> [Char]
displayException (AllowNewerNotSupported Version
cabalVer) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-8503]\n"
        , [Char]
"'--allow-newer' requires Cabal version 1.22 or greater, but "
        , [Char]
"version "
        , Version -> [Char]
versionString Version
cabalVer
        , [Char]
" was found."
        ]
    displayException (CabalVersionNotSupported Version
cabalVer) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [Char]
"Error: [S-5973]\n"
        , [Char]
"Stack no longer supports Cabal versions before 1.19.2, "
        , [Char]
"but version "
        , Version -> [Char]
versionString Version
cabalVer
        , [Char]
" was found. To fix this, consider updating the resolver to lts-3.0 "
        , [Char]
"or later or to nightly-2015-05-05 or later."
        ]

data QueryException
    = SelectorNotFound [Text]
    | IndexOutOfRange [Text]
    | NoNumericSelector [Text]
    | CannotApplySelector Value [Text]
    deriving (Int -> QueryException -> ShowS
[QueryException] -> ShowS
QueryException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [QueryException] -> ShowS
$cshowList :: [QueryException] -> ShowS
show :: QueryException -> [Char]
$cshow :: QueryException -> [Char]
showsPrec :: Int -> QueryException -> ShowS
$cshowsPrec :: Int -> QueryException -> ShowS
Show, Typeable)

instance Exception QueryException where
    displayException :: QueryException -> [Char]
displayException (SelectorNotFound [Text]
sels) =
        [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-4419]" [Char]
"Selector not found" [Text]
sels
    displayException (IndexOutOfRange [Text]
sels) =
        [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-8422]" [Char]
"Index out of range" [Text]
sels
    displayException (NoNumericSelector [Text]
sels) =
        [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-4360]" [Char]
"Encountered array and needed numeric selector" [Text]
sels
    displayException (CannotApplySelector Value
value [Text]
sels) =
        [Char] -> [Char] -> [Text] -> [Char]
err [Char]
"[S-1711]" ([Char]
"Cannot apply selector to " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
value) [Text]
sels

-- | Helper function for 'QueryException' instance of 'Show'

err :: String -> String -> [Text] -> String
err :: [Char] -> [Char] -> [Text] -> [Char]
err [Char]
msg [Char]
code [Text]
sels = [Char]
"Error: " forall a. [a] -> [a] -> [a]
++ [Char]
code forall a. [a] -> [a] -> [a]
++ [Char]
"\n" forall a. [a] -> [a] -> [a]
++ [Char]
msg forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Text]
sels

-- | 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
      [PackageIdentifier]
localsIdents -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ [PackageIdentifier] -> BuildException
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
$
        Version -> CabalVersionException
AllowNewerNotSupported Version
cabalVer
    -- 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
$
        Version -> CabalVersionException
CabalVersionNotSupported Version
cabalVer

-- | 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

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 (f :: * -> *) a. Applicative f => a -> f a
pure 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 {f :: * -> *}.
MonadIO f =>
([Text] -> [Text]) -> [Text] -> Value -> f 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] -> [Text]) -> [Text] -> Value -> f Value
select [Text] -> [Text]
_ [] Value
value = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
value
    select [Text] -> [Text]
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 :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
SelectorNotFound [Text]
sels'
                    Just Value
value' -> Value -> f 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 -> f Value
cont forall a b. (a -> b) -> a -> b
$ Array
v forall a. Vector a -> Int -> a
V.! Int
i
                        | Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
IndexOutOfRange [Text]
sels'
                    Either [Char] (Int, Text)
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
NoNumericSelector [Text]
sels'
            Value
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Value -> [Text] -> QueryException
CannotApplySelector Value
value [Text]
sels'
      where
        cont :: Value -> f Value
cont = ([Text] -> [Text]) -> [Text] -> Value -> f Value
select ([Text] -> [Text]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
selforall a. a -> [a] -> [a]
:)) [Text]
sels
        sels' :: [Text]
sels' = [Text] -> [Text]
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 (f :: * -> *) a. Applicative f => a -> f a
pure 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)] -> BuildException
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