{-# 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]
(Int -> CabalVersionException -> ShowS)
-> (CabalVersionException -> [Char])
-> ([CabalVersionException] -> ShowS)
-> Show CabalVersionException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CabalVersionException -> ShowS
showsPrec :: Int -> CabalVersionException -> ShowS
$cshow :: CabalVersionException -> [Char]
show :: CabalVersionException -> [Char]
$cshowList :: [CabalVersionException] -> ShowS
showList :: [CabalVersionException] -> ShowS
Show, Typeable)

instance Exception CabalVersionException where
    displayException :: CabalVersionException -> [Char]
displayException (AllowNewerNotSupported Version
cabalVer) = [[Char]] -> [Char]
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) = [[Char]] -> [Char]
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]
(Int -> QueryException -> ShowS)
-> (QueryException -> [Char])
-> ([QueryException] -> ShowS)
-> Show QueryException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryException -> ShowS
showsPrec :: Int -> QueryException -> ShowS
$cshow :: QueryException -> [Char]
show :: QueryException -> [Char]
$cshowList :: [QueryException] -> ShowS
showList :: [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 " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
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: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
code [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> [Char]
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 <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> env -> Const Bool env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const Bool Config) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configModifyCodePage
  Version
ghcVersion <- 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 -> RIO env Version)
-> Getting Version env Version -> RIO env Version
forall a b. (a -> b) -> a -> b
$ Getting Version env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionLGetting Version env ActualCompiler
-> ((Version -> Const Version Version)
    -> ActualCompiler -> Const Version ActualCompiler)
-> Getting Version env Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ActualCompiler -> Version) -> SimpleGetter ActualCompiler Version
forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Version
getGhcVersion
  Bool -> Version -> RIO env () -> RIO env ()
forall x y a. x -> y -> a -> a
fixCodePage Bool
mcp Version
ghcVersion (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
    BuildOpts
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
sourceMap <- Getting SourceMap env SourceMap -> RIO env SourceMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting SourceMap env SourceMap -> RIO env SourceMap)
-> Getting SourceMap env SourceMap -> RIO env SourceMap
forall a b. (a -> b) -> a -> b
$ (EnvConfig -> Const SourceMap EnvConfig)
-> env -> Const SourceMap env
forall env. HasEnvConfig env => Lens' env EnvConfig
Lens' env EnvConfig
envConfigL((EnvConfig -> Const SourceMap EnvConfig)
 -> env -> Const SourceMap env)
-> ((SourceMap -> Const SourceMap SourceMap)
    -> EnvConfig -> Const SourceMap EnvConfig)
-> Getting SourceMap env SourceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EnvConfig -> SourceMap) -> SimpleGetter EnvConfig SourceMap
forall s a. (s -> a) -> SimpleGetter s a
to EnvConfig -> SourceMap
envConfigSourceMap
    [LocalPackage]
locals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    [LocalPackage]
depsLocals <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
localDependencies
    let allLocals :: [LocalPackage]
allLocals = [LocalPackage]
locals [LocalPackage] -> [LocalPackage] -> [LocalPackage]
forall a. Semigroup a => a -> a -> a
<> [LocalPackage]
depsLocals

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

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

    Path Abs File
stackYaml <- Getting (Path Abs File) env (Path Abs File)
-> RIO env (Path Abs File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Path Abs File) env (Path Abs File)
forall env. HasBuildConfig env => Lens' env (Path Abs File)
Lens' env (Path Abs File)
stackYamlL
    Maybe (Set (Path Abs File) -> IO ())
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (Set (Path Abs File) -> IO ())
msetLocalFiles (((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ())
-> ((Set (Path Abs File) -> IO ()) -> RIO env ()) -> RIO env ()
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 [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 = Package -> PackageName
packageName (LocalPackage -> Package
lpPackage LocalPackage
lp)
          case PackageName -> Map PackageName Target -> Maybe Target
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pn (SMTargets -> Map PackageName Target
smtTargets (SMTargets -> Map PackageName Target)
-> SMTargets -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ SourceMap -> SMTargets
smTargets SourceMap
sourceMap) 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
      IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Set (Path Abs File) -> IO ()
setLocalFiles (Set (Path Abs File) -> IO ()) -> Set (Path Abs File) -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Set (Path Abs File) -> Set (Path Abs File)
forall a. Ord a => a -> Set a -> Set a
Set.insert Path Abs File
stackYaml (Set (Path Abs File) -> Set (Path Abs File))
-> Set (Path Abs File) -> Set (Path Abs File)
forall a b. (a -> b) -> a -> b
$ [Set (Path Abs File)] -> Set (Path Abs File)
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set (Path Abs File)]
files

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

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

    BaseConfigOpts
baseConfigOpts <- BuildOptsCLI -> RIO env BaseConfigOpts
forall env.
HasEnvConfig env =>
BuildOptsCLI -> RIO env BaseConfigOpts
mkBaseConfigOpts BuildOptsCLI
boptsCli
    Plan
plan <- BaseConfigOpts
-> [DumpPackage]
-> (PackageLocationImmutable
    -> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package)
-> SourceMap
-> InstalledMap
-> Bool
-> RIO env 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 PackageLocationImmutable
-> Map FlagName Bool -> [Text] -> [Text] -> RIO EnvConfig Package
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 <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> env -> Const Bool env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const Bool Config) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowLocals
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowLocals (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ case Plan -> [PackageIdentifier]
justLocals Plan
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. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BuildException -> RIO env ()) -> BuildException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [PackageIdentifier] -> BuildException
LocalPackagesPresent [PackageIdentifier]
localsIdents

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

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

    if BuildOptsCLI -> Bool
boptsCLIDryrun BuildOptsCLI
boptsCli
        then Plan -> RIO env ()
forall env. HasRunner env => Plan -> RIO env ()
printPlan Plan
plan
        else BuildOptsCLI
-> BaseConfigOpts
-> [LocalPackage]
-> [DumpPackage]
-> [DumpPackage]
-> [DumpPackage]
-> InstalledMap
-> Map PackageName Target
-> Plan
-> RIO env ()
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 (SMTargets -> Map PackageName Target)
-> SMTargets -> Map PackageName Target
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 =
  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
.
    Plan -> Map PackageName Task
planTasks

checkCabalVersion :: HasEnvConfig env => RIO env ()
checkCabalVersion :: forall env. HasEnvConfig env => RIO env ()
checkCabalVersion = do
    Bool
allowNewer <- Getting Bool env Bool -> RIO env Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Bool env Bool -> RIO env Bool)
-> Getting Bool env Bool -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ (Config -> Const Bool Config) -> env -> Const Bool env
forall env. HasConfig env => Lens' env Config
Lens' env Config
configL((Config -> Const Bool Config) -> env -> Const Bool env)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool env Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Bool) -> SimpleGetter Config Bool
forall s a. (s -> a) -> SimpleGetter s a
to Config -> Bool
configAllowNewer
    Version
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
    -- https://github.com/haskell/cabal/issues/2023

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
allowNewer Bool -> Bool -> Bool
&& Version
cabalVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
22]) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ CabalVersionException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CabalVersionException -> RIO env ())
-> CabalVersionException -> RIO env ()
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

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
cabalVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
1, Int
19, Int
2]) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ CabalVersionException -> RIO env ()
forall e a. Exception e => e -> RIO env a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (CabalVersionException -> RIO env ())
-> CabalVersionException -> RIO env ()
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
    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"
    [(Text, ([PackageName], [PackageName]))]
-> ((Text, ([PackageName], [PackageName])) -> RIO env ())
-> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text ([PackageName], [PackageName])
-> [(Text, ([PackageName], [PackageName]))]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text ([PackageName], [PackageName])
warnings) (((Text, ([PackageName], [PackageName])) -> RIO env ())
 -> RIO env ())
-> ((Text, ([PackageName], [PackageName])) -> RIO env ())
-> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(Text
exe,([PackageName]
toBuild,[PackageName]
otherLocals)) -> do
        let exe_s :: Text
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 = Text
"several executables with the same name:"
                | Bool
otherwise = Text
"executable"
            exesText :: [PackageName] -> Text
exesText [PackageName]
pkgs =
                Text -> [Text] -> Text
T.intercalate
                    Text
", "
                    [Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
p) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
exe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" | PackageName
p <- [PackageName]
pkgs]
        (Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ())
-> ([[Text]] -> Utf8Builder) -> [[Text]] -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display (Text -> Utf8Builder)
-> ([[Text]] -> Text) -> [[Text]] -> Utf8Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
            [ [ Text
"Building " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
exe_s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [PackageName] -> Text
exesText [PackageName]
toBuild Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." ]
            , [ Text
"Only one of them will be available via 'stack exec' 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
              ]
            , [ Text
"Other executables with the same name might be overwritten: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                [PackageName] -> Text
exesText [PackageName]
otherLocals Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
              | Bool -> Bool
not ([PackageName] -> Bool
forall a. [a] -> Bool
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 =
        ((NonEmpty PackageName, NonEmpty PackageName)
 -> Maybe ([PackageName], [PackageName]))
-> Map Text (NonEmpty PackageName, NonEmpty PackageName)
-> Map Text ([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 local package

                        -- and there are no other local 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 local 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 Text (NonEmpty PackageName)
-> Map Text (NonEmpty PackageName)
-> Map Text (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 Text (NonEmpty PackageName)
exesToBuild Map Text (NonEmpty PackageName)
localExes)
    exesToBuild :: Map Text (NonEmpty PackageName)
    exesToBuild :: Map Text (NonEmpty PackageName)
exesToBuild =
        [(Text, PackageName)] -> Map Text (NonEmpty PackageName)
forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect
            [ (Text
exe,PackageName
pkgName')
            | (PackageName
pkgName',Task
task) <- Map PackageName Task -> [(PackageName, 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 <- (Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text])
-> (LocalPackage -> Set Text) -> LocalPackage -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set NamedComponent -> Set Text
exeComponents (Set NamedComponent -> Set Text)
-> (LocalPackage -> Set NamedComponent) -> LocalPackage -> Set Text
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 =
        [(Text, PackageName)] -> Map Text (NonEmpty PackageName)
forall k v. Ord k => [(k, v)] -> Map k (NonEmpty v)
collect
            [ (Text
exe,Package -> PackageName
packageName Package
pkg)
            | Package
pkg <- (LocalPackage -> Package) -> [LocalPackage] -> [Package]
forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Package
lpPackage [LocalPackage]
locals
            , Text
exe <- Set Text -> [Text]
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 = ([v] -> NonEmpty v) -> Map k [v] -> Map k (NonEmpty v)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [v] -> NonEmpty v
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (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

warnAboutSplitObjs :: HasLogFunc env => BuildOpts -> RIO env ()
warnAboutSplitObjs :: forall env. HasLogFunc env => BuildOpts -> RIO env ()
warnAboutSplitObjs BuildOpts
bopts | BuildOpts -> Bool
boptsSplitObjs BuildOpts
bopts = do
    Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Building with --split-objs is enabled. " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString [Char]
splitObjsWarning
warnAboutSplitObjs BuildOpts
_ = () -> RIO env ()
forall a. a -> RIO env a
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 <- 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
    Path Abs Dir
snapDBPath <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseDeps
    Path Abs Dir
localDBPath <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
packageDatabaseLocal
    Path Abs Dir
snapInstallRoot <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootDeps
    Path Abs Dir
localInstallRoot <- RIO env (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
installationRootLocal
    [Path Abs Dir]
packageExtraDBs <- RIO env [Path Abs Dir]
forall env (m :: * -> *).
(MonadReader env m, HasEnvConfig env) =>
m [Path Abs Dir]
packageDatabaseExtra
    BaseConfigOpts -> RIO env BaseConfigOpts
forall a. a -> RIO env a
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 <- 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
platform <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
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 (GenericPackageDescription -> Package)
-> RIO env GenericPackageDescription -> RIO env Package
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageLocationImmutable -> RIO env GenericPackageDescription
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 =
        RIO env Value
forall env. HasEnvConfig env => RIO env Value
rawBuildInfo
    RIO env Value -> (Value -> RIO env Value) -> RIO env Value
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> [Text]) -> [Text] -> Value -> RIO env Value
forall {f :: * -> *}.
MonadIO f =>
([Text] -> [Text]) -> [Text] -> Value -> f Value
select [Text] -> [Text]
forall a. a -> a
id [Text]
selectors0
    RIO env Value -> (Value -> RIO env ()) -> RIO env ()
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> (Value -> IO ()) -> Value -> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
TIO.putStrLn (Text -> IO ()) -> (Value -> Text) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addGlobalHintsComment (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode
  where
    select :: ([Text] -> [Text]) -> [Text] -> Value -> f Value
select [Text] -> [Text]
_ [] Value
value = Value -> f Value
forall a. a -> f a
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 Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
sel) Object
o of
                    Maybe Value
Nothing -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
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 Reader Int
forall a. Integral a => Reader a
decimal Text
sel of
                    Right (Int
i, Text
"")
                        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array -> Int
forall a. Vector a -> Int
V.length Array
v -> Value -> f Value
cont (Value -> f Value) -> Value -> f Value
forall a b. (a -> b) -> a -> b
$ Array
v Array -> Int -> Value
forall a. Vector a -> Int -> a
V.! Int
i
                        | Bool
otherwise -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
IndexOutOfRange [Text]
sels'
                    Either [Char] (Int, Text)
_ -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
forall a b. (a -> b) -> a -> b
$ [Text] -> QueryException
NoNumericSelector [Text]
sels'
            Value
_ -> QueryException -> f Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (QueryException -> f Value) -> QueryException -> f Value
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 ([Text] -> [Text]) -> ([Text] -> [Text]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
selText -> [Text] -> [Text]
forall 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
      | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
selectors0 = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
globalHintsLine (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment Text -> Text -> Text
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"] [Text] -> [Text] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Text]
selectors0 = (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
globalHintsComment))
      | Bool
otherwise = Text -> Text
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 <- RIO env [LocalPackage]
forall env. HasEnvConfig env => RIO env [LocalPackage]
projectLocalPackages
    Text
wantedCompiler <- Getting Text env Text -> RIO env Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text env Text -> RIO env Text)
-> Getting Text env Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ Getting Text env WantedCompiler
forall s r. HasBuildConfig s => Getting r s WantedCompiler
wantedCompilerVersionLGetting Text env WantedCompiler
-> ((Text -> Const Text Text)
    -> WantedCompiler -> Const Text WantedCompiler)
-> Getting Text env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(WantedCompiler -> Text) -> SimpleGetter WantedCompiler Text
forall s a. (s -> a) -> SimpleGetter s a
to (Utf8Builder -> Text
utf8BuilderToText (Utf8Builder -> Text)
-> (WantedCompiler -> Utf8Builder) -> WantedCompiler -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WantedCompiler -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display)
    Text
actualCompiler <- Getting Text env Text -> RIO env Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting Text env Text -> RIO env Text)
-> Getting Text env Text -> RIO env Text
forall a b. (a -> b) -> a -> b
$ Getting Text env ActualCompiler
forall env. HasSourceMap env => SimpleGetter env ActualCompiler
SimpleGetter env ActualCompiler
actualCompilerVersionLGetting Text env ActualCompiler
-> ((Text -> Const Text Text)
    -> ActualCompiler -> Const Text ActualCompiler)
-> Getting Text env Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ActualCompiler -> Text) -> SimpleGetter ActualCompiler Text
forall s a. (s -> a) -> SimpleGetter s a
to ActualCompiler -> Text
compilerVersionText
    Value -> RIO env Value
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> RIO env Value) -> Value -> RIO env Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
        [ Key
"locals" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Object -> Value
Object ([Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([Pair] -> Object) -> [Pair] -> Object
forall a b. (a -> b) -> a -> b
$ (LocalPackage -> Pair) -> [LocalPackage] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map LocalPackage -> Pair
localToPair [LocalPackage]
locals)
        , Key
"compiler" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= [Pair] -> Value
object
            [ Key
"wanted" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
wantedCompiler
            , Key
"actual" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Text
actualCompiler
            ]
        ]
  where
    localToPair :: LocalPackage -> Pair
localToPair LocalPackage
lp =
        (Text -> Key
Key.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString (PackageName -> [Char]) -> PackageName -> [Char]
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" Key -> CabalString Version -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Version -> CabalString Version
forall a. a -> CabalString a
CabalString (Package -> Version
packageVersion Package
p)
            , Key
"path" Key -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> Pair
.= Path Abs Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
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 =
    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
$ BuildException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BuildException -> m ()) -> BuildException -> m ()
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 <- Set NamedComponent -> [NamedComponent]
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
  [ProjectPackage] -> (ProjectPackage -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProjectPackage]
proj ((ProjectPackage -> RIO env ()) -> RIO env ())
-> (ProjectPackage -> RIO env ()) -> RIO env ()
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 <- IO GenericPackageDescription -> RIO env GenericPackageDescription
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> RIO env GenericPackageDescription)
-> IO GenericPackageDescription
-> RIO env GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ CommonPackage -> IO GenericPackageDescription
cpGPD (CommonPackage -> IO GenericPackageDescription)
-> (ProjectPackage -> CommonPackage)
-> ProjectPackage
-> IO GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon (ProjectPackage -> IO GenericPackageDescription)
-> ProjectPackage -> IO GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ ProjectPackage
p

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

    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([LibraryName] -> Bool
forall {t :: * -> *}. Foldable t => t LibraryName -> Bool
subLibDepExist [LibraryName]
libraries)
      (Utf8Builder -> RIO env ()
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 =
      (LibraryName -> Bool) -> t LibraryName -> Bool
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