{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE ViewPatterns        #-}

-- | Parsing command line targets

--

-- There are two relevant data sources for performing this parsing:

-- the project configuration, and command line arguments. Project

-- configurations includes the resolver (defining a LoadedSnapshot of

-- global and snapshot packages), local dependencies, and project

-- packages. It also defines local flag overrides.

--

-- The command line arguments specify both additional local flag

-- overrides and targets in their raw form.

--

-- Flags are simple: we just combine CLI flags with config flags and

-- make one big map of flags, preferring CLI flags when present.

--

-- Raw targets can be a package name, a package name with component,

-- just a component, or a package name and version number. We first

-- must resolve these raw targets into both simple targets and

-- additional dependencies. This works as follows:

--

-- * If a component is specified, find a unique project package which

--   defines that component, and convert it into a name+component

--   target.

--

-- * Ensure that all name+component values refer to valid components

--   in the given project package.

--

-- * For names, check if the name is present in the snapshot, local

--   deps, or project packages. If it is not, then look up the most

--   recent version in the package index and convert to a

--   name+version.

--

-- * For name+version, first ensure that the name is not used by a

--   project package. Next, if that name+version is present in the

--   snapshot or local deps _and_ its location is PLIndex, we have the

--   package. Otherwise, add to local deps with the appropriate

--   PLIndex.

--

-- If in either of the last two bullets we added a package to local

-- deps, print a warning to the user recommending modifying the

-- extra-deps.

--

-- Combine the various 'ResolveResults's together into 'Target'

-- values, by combining various components for a single package and

-- ensuring that no conflicting statements were made about targets.

--

-- At this point, we now have a Map from package name to SimpleTarget,

-- and an updated Map of local dependencies. We still have the

-- aggregated flags, and the snapshot and project packages.

--

-- Finally, we upgrade the snapshot by using

-- calculatePackagePromotion.

module Stack.Build.Target
  ( -- * Types

    Target (..)
  , NeedTargets (..)
  , PackageType (..)
  , parseTargets
    -- * Convenience helpers

  , gpdVersion
    -- * Test suite exports

  , parseRawTarget
  , RawTarget (..)
  , UnresolvedComponent (..)
  ) where

import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import           Path
import           Path.Extra ( rejectMissingDir )
import           Path.IO
import           RIO.Process ( HasProcessContext )
import           Stack.SourceMap
import           Stack.Prelude
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Build
import           Stack.Types.SourceMap

-- | Do we need any targets? For example, `stack build` will fail if

-- no targets are provided.

data NeedTargets = NeedTargets | AllowNoTargets

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

-- Get the RawInput

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


-- | Raw target information passed on the command line.

newtype RawInput = RawInput { RawInput -> Text
unRawInput :: Text }

getRawInput :: BuildOptsCLI -> Map PackageName ProjectPackage -> ([Text], [RawInput])
getRawInput :: BuildOptsCLI
-> Map PackageName ProjectPackage -> ([Text], [RawInput])
getRawInput BuildOptsCLI
boptscli Map PackageName ProjectPackage
locals =
    let textTargets' :: [Text]
textTargets' = BuildOptsCLI -> [Text]
boptsCLITargets BuildOptsCLI
boptscli
        textTargets :: [Text]
textTargets =
            -- Handle the no targets case, which means we pass in the names of all project packages

            if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets'
                then forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) (forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
locals)
                else [Text]
textTargets'
     in ([Text]
textTargets', forall a b. (a -> b) -> [a] -> [b]
map Text -> RawInput
RawInput [Text]
textTargets)

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

-- Turn RawInput into RawTarget

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


-- | The name of a component, which applies to executables, test

-- suites, and benchmarks

type ComponentName = Text

-- | Either a fully resolved component, or a component name that could be

-- either an executable, test, or benchmark

data UnresolvedComponent
    = ResolvedComponent !NamedComponent
    | UnresolvedComponent !ComponentName
    deriving (Int -> UnresolvedComponent -> ShowS
[UnresolvedComponent] -> ShowS
UnresolvedComponent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnresolvedComponent] -> ShowS
$cshowList :: [UnresolvedComponent] -> ShowS
show :: UnresolvedComponent -> String
$cshow :: UnresolvedComponent -> String
showsPrec :: Int -> UnresolvedComponent -> ShowS
$cshowsPrec :: Int -> UnresolvedComponent -> ShowS
Show, UnresolvedComponent -> UnresolvedComponent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c/= :: UnresolvedComponent -> UnresolvedComponent -> Bool
== :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c== :: UnresolvedComponent -> UnresolvedComponent -> Bool
Eq, Eq UnresolvedComponent
UnresolvedComponent -> UnresolvedComponent -> Bool
UnresolvedComponent -> UnresolvedComponent -> Ordering
UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
$cmin :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
max :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
$cmax :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
>= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c>= :: UnresolvedComponent -> UnresolvedComponent -> Bool
> :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c> :: UnresolvedComponent -> UnresolvedComponent -> Bool
<= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c<= :: UnresolvedComponent -> UnresolvedComponent -> Bool
< :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c< :: UnresolvedComponent -> UnresolvedComponent -> Bool
compare :: UnresolvedComponent -> UnresolvedComponent -> Ordering
$ccompare :: UnresolvedComponent -> UnresolvedComponent -> Ordering
Ord)

-- | Raw command line input, without checking against any databases or list of

-- locals. Does not deal with directories

data RawTarget
    = RTPackageComponent !PackageName !UnresolvedComponent
    | RTComponent !ComponentName
    | RTPackage !PackageName
    -- Explicitly _not_ supporting revisions on the command line. If

    -- you want that, you should be modifying your stack.yaml! (In

    -- fact, you should probably do that anyway, we're just letting

    -- people be lazy, since we're Haskeletors.)

    | RTPackageIdentifier !PackageIdentifier
  deriving (Int -> RawTarget -> ShowS
[RawTarget] -> ShowS
RawTarget -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawTarget] -> ShowS
$cshowList :: [RawTarget] -> ShowS
show :: RawTarget -> String
$cshow :: RawTarget -> String
showsPrec :: Int -> RawTarget -> ShowS
$cshowsPrec :: Int -> RawTarget -> ShowS
Show, RawTarget -> RawTarget -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawTarget -> RawTarget -> Bool
$c/= :: RawTarget -> RawTarget -> Bool
== :: RawTarget -> RawTarget -> Bool
$c== :: RawTarget -> RawTarget -> Bool
Eq)

-- | Same as @parseRawTarget@, but also takes directories into account.

parseRawTargetDirs :: MonadIO m
                   => Path Abs Dir -- ^ current directory

                   -> Map PackageName ProjectPackage
                   -> RawInput -- ^ raw target information from the commandline

                   -> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs Path Abs Dir
root Map PackageName ProjectPackage
locals RawInput
ri =
    case Text -> Maybe RawTarget
parseRawTarget Text
t of
        Just RawTarget
rt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right [(RawInput
ri, RawTarget
rt)]
        Maybe RawTarget
Nothing -> do
            Maybe (Path Abs Dir)
mdir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir Path Abs Dir
root (Text -> String
T.unpack Text
t))
              forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs Dir) -> m (Maybe (Path Abs Dir))
rejectMissingDir
            case Maybe (Path Abs Dir)
mdir of
                Maybe (Path Abs Dir)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Directory not found: " Text -> Text -> Text
`T.append` Text
t
                Just Path Abs Dir
dir ->
                    case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}. Path Abs Dir -> (a, ProjectPackage) -> Maybe a
childOf Path Abs Dir
dir) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName ProjectPackage
locals of
                        [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                            Text
"No local directories found as children of " Text -> Text -> Text
`T.append`
                            Text
t
                        [PackageName]
names -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((RawInput
ri, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> RawTarget
RTPackage) [PackageName]
names
  where
    childOf :: Path Abs Dir -> (a, ProjectPackage) -> Maybe a
childOf Path Abs Dir
dir (a
name, ProjectPackage
pp) =
        if Path Abs Dir
dir forall a. Eq a => a -> a -> Bool
== ProjectPackage -> Path Abs Dir
ppRoot ProjectPackage
pp Bool -> Bool -> Bool
|| forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Abs Dir
dir (ProjectPackage -> Path Abs Dir
ppRoot ProjectPackage
pp)
            then forall a. a -> Maybe a
Just a
name
            else forall a. Maybe a
Nothing

    RawInput Text
t = RawInput
ri

-- | If this function returns @Nothing@, the input should be treated as a

-- directory.

parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget Text
t =
        (PackageIdentifier -> RawTarget
RTPackageIdentifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
s)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PackageName -> RawTarget
RTPackage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageName
parsePackageName String
s)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> RawTarget
RTComponent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t)
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe RawTarget
parsePackageComponent
  where
    s :: String
s = Text -> String
T.unpack Text
t

    parsePackageComponent :: Maybe RawTarget
parsePackageComponent =
        case Text -> Text -> [Text]
T.splitOn Text
":" Text
t of
            [Text
pname, Text
"lib"]
                | Just PackageName
pname' <- String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
pname) ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' forall a b. (a -> b) -> a -> b
$ NamedComponent -> UnresolvedComponent
ResolvedComponent NamedComponent
CLib
            [Text
pname, Text
cname]
                | Just PackageName
pname' <- String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
pname) ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' forall a b. (a -> b) -> a -> b
$ Text -> UnresolvedComponent
UnresolvedComponent Text
cname
            [Text
pname, Text
typ, Text
cname]
                | Just PackageName
pname' <- String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
pname)
                , Just Text -> NamedComponent
wrapper <- forall {a}.
(Eq a, IsString a) =>
a -> Maybe (Text -> NamedComponent)
parseCompType Text
typ ->
                    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' forall a b. (a -> b) -> a -> b
$ NamedComponent -> UnresolvedComponent
ResolvedComponent forall a b. (a -> b) -> a -> b
$ Text -> NamedComponent
wrapper Text
cname
            [Text]
_ -> forall a. Maybe a
Nothing

    parseCompType :: a -> Maybe (Text -> NamedComponent)
parseCompType a
t' =
        case a
t' of
            a
"exe" -> forall a. a -> Maybe a
Just Text -> NamedComponent
CExe
            a
"test" -> forall a. a -> Maybe a
Just Text -> NamedComponent
CTest
            a
"bench" -> forall a. a -> Maybe a
Just Text -> NamedComponent
CBench
            a
_ -> forall a. Maybe a
Nothing

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

-- Resolve the raw targets

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


data ResolveResult = ResolveResult
  { ResolveResult -> PackageName
rrName :: !PackageName
  , ResolveResult -> RawInput
rrRaw :: !RawInput
  , ResolveResult -> Maybe NamedComponent
rrComponent :: !(Maybe NamedComponent)
  -- ^ Was a concrete component specified?

  , ResolveResult -> Maybe PackageLocationImmutable
rrAddedDep :: !(Maybe PackageLocationImmutable)
  -- ^ Only if we're adding this as a dependency

  , ResolveResult -> PackageType
rrPackageType :: !PackageType
  }

-- | Convert a 'RawTarget' into a 'ResolveResult' (see description on

-- the module).

resolveRawTarget ::
       (HasLogFunc env, HasPantryConfig env, HasProcessContext env)
    => SMActual GlobalPackage
    -> Map PackageName PackageLocation
    -> (RawInput, RawTarget)
    -> RIO env (Either Text ResolveResult)
resolveRawTarget :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget SMActual GlobalPackage
sma Map PackageName PackageLocation
allLocs (RawInput
ri, RawTarget
rt) =
  RawTarget -> RIO env (Either Text ResolveResult)
go RawTarget
rt
  where
    locals :: Map PackageName ProjectPackage
locals = forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual GlobalPackage
sma
    deps :: Map PackageName DepPackage
deps = forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackage
sma
    globals :: Map PackageName GlobalPackage
globals = forall global. SMActual global -> Map PackageName global
smaGlobal SMActual GlobalPackage
sma
    -- Helper function: check if a 'NamedComponent' matches the given 'ComponentName'

    isCompNamed :: ComponentName -> NamedComponent -> Bool
    isCompNamed :: Text -> NamedComponent -> Bool
isCompNamed Text
_ NamedComponent
CLib = Bool
False
    isCompNamed Text
t1 (CInternalLib Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
    isCompNamed Text
t1 (CExe Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
    isCompNamed Text
t1 (CTest Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
    isCompNamed Text
t1 (CBench Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2

    go :: RawTarget -> RIO env (Either Text ResolveResult)
go (RTComponent Text
cname) = do
        -- Associated list from component name to package that defines

        -- it. We use an assoc list and not a Map so we can detect

        -- duplicates.

        [(PackageName, NamedComponent)]
allPairs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Map PackageName ProjectPackage
locals
          forall a b. (a -> b) -> a -> b
$ \PackageName
name ProjectPackage
pp -> do
              Set NamedComponent
comps <- forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents ProjectPackage
pp
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageName
name, ) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set NamedComponent
comps
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> NamedComponent -> Bool
isCompNamed Text
cname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(PackageName, NamedComponent)]
allPairs of
                [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
cname Text -> Text -> Text
`T.append` Text
" doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets"
                [(PackageName
name, NamedComponent
comp)] -> forall a b. b -> Either a b
Right ResolveResult
                  { rrName :: PackageName
rrName = PackageName
name
                  , rrRaw :: RawInput
rrRaw = RawInput
ri
                  , rrComponent :: Maybe NamedComponent
rrComponent = forall a. a -> Maybe a
Just NamedComponent
comp
                  , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
                  , rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
                  }
                [(PackageName, NamedComponent)]
matches -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                    [ Text
"Ambiguous component name "
                    , Text
cname
                    , Text
", matches: "
                    , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [(PackageName, NamedComponent)]
matches
                    ]
    go (RTPackageComponent PackageName
name UnresolvedComponent
ucomp) =
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName ProjectPackage
locals of
            Maybe ProjectPackage
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Unknown local package: " forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name
            Just ProjectPackage
pp -> do
                Set NamedComponent
comps <- forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents ProjectPackage
pp
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case UnresolvedComponent
ucomp of
                    ResolvedComponent NamedComponent
comp
                        | NamedComponent
comp forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NamedComponent
comps -> forall a b. b -> Either a b
Right ResolveResult
                            { rrName :: PackageName
rrName = PackageName
name
                            , rrRaw :: RawInput
rrRaw = RawInput
ri
                            , rrComponent :: Maybe NamedComponent
rrComponent = forall a. a -> Maybe a
Just NamedComponent
comp
                            , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
                            , rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
                            }
                        | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                            [ String
"Component "
                            , forall a. Show a => a -> String
show NamedComponent
comp
                            , String
" does not exist in package "
                            , PackageName -> String
packageNameString PackageName
name
                            ]
                    UnresolvedComponent Text
comp ->
                        case forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> NamedComponent -> Bool
isCompNamed Text
comp) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set NamedComponent
comps of
                            [] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                                [ Text
"Component "
                                , Text
comp
                                , Text
" does not exist in package "
                                , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
                                ]
                            [NamedComponent
x] -> forall a b. b -> Either a b
Right ResolveResult
                              { rrName :: PackageName
rrName = PackageName
name
                              , rrRaw :: RawInput
rrRaw = RawInput
ri
                              , rrComponent :: Maybe NamedComponent
rrComponent = forall a. a -> Maybe a
Just NamedComponent
x
                              , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
                              , rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
                              }
                            [NamedComponent]
matches -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                                [ Text
"Ambiguous component name "
                                , Text
comp
                                , Text
" for package "
                                , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
                                , Text
": "
                                , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [NamedComponent]
matches
                                ]

    go (RTPackage PackageName
name)
      | forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName ProjectPackage
locals = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ResolveResult
          { rrName :: PackageName
rrName = PackageName
name
          , rrRaw :: RawInput
rrRaw = RawInput
ri
          , rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
          , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
          , rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
          }
      | forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName DepPackage
deps =
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
      | Just GlobalPackage
gp <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName GlobalPackage
globals =
          case GlobalPackage
gp of
              GlobalPackage Version
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
              ReplacedGlobalPackage [PackageName]
_ -> PackageName -> RIO env (Either Text ResolveResult)
hackageLatest PackageName
name
      | Bool
otherwise = PackageName -> RIO env (Either Text ResolveResult)
hackageLatest PackageName
name

    -- Note that we use getLatestHackageRevision below, even though it's

    -- non-reproducible, to avoid user confusion. In any event,

    -- reproducible builds should be done by updating your config

    -- files!


    go (RTPackageIdentifier ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
version))
      | forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName ProjectPackage
locals = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
            [ forall a. Show a => a -> Text
tshow (PackageName -> String
packageNameString PackageName
name)
            , Text
" target has a specific version number, but it is a local package."
            , Text
"\nTo avoid confusion, we will not install the specified version or build the local one."
            , Text
"\nTo build the local package, specify the target without an explicit version."
            ]
      | Bool
otherwise =
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName PackageLocation
allLocs of
            -- Installing it from the package index, so we're cool

            -- with overriding it if necessary

            Just (PLImmutable (PLIHackage (PackageIdentifier PackageName
_name Version
versionLoc) BlobKey
_cfKey TreeKey
_treeKey)) ->
              if Version
version forall a. Eq a => a -> a -> Bool
== Version
versionLoc
              then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
              else PackageName -> Version -> RIO env (Either Text ResolveResult)
hackageLatestRevision PackageName
name Version
version
            -- The package was coming from something besides the

            -- index, so refuse to do the override

            Just PackageLocation
loc' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
              [ Text
"Package with identifier was targeted on the command line: "
              , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
              , Text
", but it was specified from a non-index location: "
              , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show PackageLocation
loc'
              , Text
".\nRecommendation: add the correctly desired version to extra-deps."
              ]
            -- Not present at all, add it from Hackage

            Maybe PackageLocation
Nothing -> do
              Maybe (Revision, BlobKey, TreeKey)
mrev <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Revision, BlobKey, TreeKey)
mrev of
                Maybe (Revision, BlobKey, TreeKey)
Nothing -> PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
                Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> forall a b. b -> Either a b
Right ResolveResult
                  { rrName :: PackageName
rrName = PackageName
name
                  , rrRaw :: RawInput
rrRaw = RawInput
ri
                  , rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
                  , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
                  , rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
                  }

    hackageLatest :: PackageName -> RIO env (Either Text ResolveResult)
hackageLatest PackageName
name = do
        Maybe PackageLocationImmutable
mloc <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
YesRequireHackageIndex PackageName
name UsePreferredVersions
UsePreferredVersions
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe PackageLocationImmutable
mloc of
          Maybe PackageLocationImmutable
Nothing -> PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
          Just PackageLocationImmutable
loc -> do
            forall a b. b -> Either a b
Right ResolveResult
                  { rrName :: PackageName
rrName = PackageName
name
                  , rrRaw :: RawInput
rrRaw = RawInput
ri
                  , rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
                  , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. a -> Maybe a
Just PackageLocationImmutable
loc
                  , rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
                  }

    hackageLatestRevision :: PackageName -> Version -> RIO env (Either Text ResolveResult)
hackageLatestRevision PackageName
name Version
version = do
        Maybe (Revision, BlobKey, TreeKey)
mrev <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Revision, BlobKey, TreeKey)
mrev of
          Maybe (Revision, BlobKey, TreeKey)
Nothing -> PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
          Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> forall a b. b -> Either a b
Right ResolveResult
            { rrName :: PackageName
rrName = PackageName
name
            , rrRaw :: RawInput
rrRaw = RawInput
ri
            , rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
            , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
            , rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
            }

    -- This is actually an error case. We _could_ pure a

    -- Left value here, but it turns out to be better to defer

    -- this until the ConstructPlan phase, and let it complain

    -- about the missing package so that we get more errors

    -- together, plus the fancy colored output from that

    -- module.

    deferToConstructPlan :: PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name = forall a b. b -> Either a b
Right ResolveResult
              { rrName :: PackageName
rrName = PackageName
name
              , rrRaw :: RawInput
rrRaw = RawInput
ri
              , rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
              , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
              , rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
              }
---------------------------------------------------------------------------------

-- Combine the ResolveResults

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


combineResolveResults
  :: forall env. HasLogFunc env
  => [ResolveResult]
  -> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocationImmutable)
combineResolveResults :: forall env.
HasLogFunc env =>
[ResolveResult]
-> RIO
     env
     ([Text], Map PackageName Target,
      Map PackageName PackageLocationImmutable)
combineResolveResults [ResolveResult]
results = do
    Map PackageName PackageLocationImmutable
addedDeps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ResolveResult]
results forall a b. (a -> b) -> a -> b
$ \ResolveResult
result ->
      case ResolveResult -> Maybe PackageLocationImmutable
rrAddedDep ResolveResult
result of
        Maybe PackageLocationImmutable
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
        Just PackageLocationImmutable
pl -> do
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (ResolveResult -> PackageName
rrName ResolveResult
result) PackageLocationImmutable
pl

    let m0 :: Map PackageName [ResolveResult]
m0 = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ResolveResult
rr -> forall k a. k -> a -> Map k a
Map.singleton (ResolveResult -> PackageName
rrName ResolveResult
rr) [ResolveResult
rr]) [ResolveResult]
results
        ([Text]
errs, [Map PackageName Target]
ms) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName [ResolveResult]
m0) forall a b. (a -> b) -> a -> b
$ \(PackageName
name, [ResolveResult]
rrs) ->
            let mcomps :: [Maybe NamedComponent]
mcomps = forall a b. (a -> b) -> [a] -> [b]
map ResolveResult -> Maybe NamedComponent
rrComponent [ResolveResult]
rrs in
            -- Confirm that there is either exactly 1 with no component, or

            -- that all rrs are components

            case [ResolveResult]
rrs of
                [] -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"Somehow got no rrComponent values, that can't happen"
                [ResolveResult
rr] | forall a. Maybe a -> Bool
isNothing (ResolveResult -> Maybe NamedComponent
rrComponent ResolveResult
rr) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton PackageName
name forall a b. (a -> b) -> a -> b
$ PackageType -> Target
TargetAll forall a b. (a -> b) -> a -> b
$ ResolveResult -> PackageType
rrPackageType ResolveResult
rr
                [ResolveResult]
_
                  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
isJust [Maybe NamedComponent]
mcomps -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton PackageName
name forall a b. (a -> b) -> a -> b
$ Set NamedComponent -> Target
TargetComps forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe NamedComponent]
mcomps
                  | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                      [ Text
"The package "
                      , String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
                      , Text
" was specified in multiple, incompatible ways: "
                      , [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RawInput -> Text
unRawInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolveResult -> RawInput
rrRaw) [ResolveResult]
rrs
                      ]

    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
errs, forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map PackageName Target]
ms, Map PackageName PackageLocationImmutable
addedDeps)

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

-- OK, let's do it!

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


parseTargets :: HasBuildConfig env
    => NeedTargets
    -> Bool
    -> BuildOptsCLI
    -> SMActual GlobalPackage
    -> RIO env SMTargets
parseTargets :: forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptscli SMActual GlobalPackage
smActual = do
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
 ?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Parsing the targets"
  BuildConfig
bconfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
  Path Abs Dir
workingDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  Map PackageName ProjectPackage
locals <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
  let ([Text]
textTargets', [RawInput]
rawInput) = BuildOptsCLI
-> Map PackageName ProjectPackage -> ([Text], [RawInput])
getRawInput BuildOptsCLI
boptscli Map PackageName ProjectPackage
locals

  ([Text]
errs1, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [(RawInput, RawTarget)]
rawTargets) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawInput]
rawInput forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
MonadIO m =>
Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs Path Abs Dir
workingDir Map PackageName ProjectPackage
locals

  let depLocs :: Map PackageName PackageLocation
depLocs = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map DepPackage -> PackageLocation
dpLocation forall a b. (a -> b) -> a -> b
$ forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackage
smActual

  ([Text]
errs2, [ResolveResult]
resolveResults) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RawInput, RawTarget)]
rawTargets forall a b. (a -> b) -> a -> b
$
    forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget SMActual GlobalPackage
smActual Map PackageName PackageLocation
depLocs

  ([Text]
errs3, Map PackageName Target
targets, Map PackageName PackageLocationImmutable
addedDeps) <- forall env.
HasLogFunc env =>
[ResolveResult]
-> RIO
     env
     ([Text], Map PackageName Target,
      Map PackageName PackageLocationImmutable)
combineResolveResults [ResolveResult]
resolveResults

  case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]
errs1, [Text]
errs2, [Text]
errs3] of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Text]
errs -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException [Text]
errs

  case (forall k a. Map k a -> Bool
Map.null Map PackageName Target
targets, NeedTargets
needTargets) of
    (Bool
False, NeedTargets
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Bool
True, NeedTargets
AllowNoTargets) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Bool
True, NeedTargets
NeedTargets)
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets' Bool -> Bool -> Bool
&& BuildConfig -> Bool
bcImplicitGlobal BuildConfig
bconfig -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException
          [Text
"The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets' Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map PackageName ProjectPackage
locals -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException
          [Text
"The project contains no local packages (packages not marked with 'extra-dep')"]
      | Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException
          [Text
"The specified targets matched no packages"]

  Map PackageName DepPackage
addedDeps' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage Bool
haddockDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> PackageLocation
PLImmutable) Map PackageName PackageLocationImmutable
addedDeps

  forall (f :: * -> *) a. Applicative f => a -> f a
pure SMTargets
    { smtTargets :: Map PackageName Target
smtTargets = Map PackageName Target
targets
    , smtDeps :: Map PackageName DepPackage
smtDeps = Map PackageName DepPackage
addedDeps'
    }
  where
    bcImplicitGlobal :: BuildConfig -> Bool
bcImplicitGlobal BuildConfig
bconfig =
      case Config -> ProjectConfig (Project, Path Abs File)
configProject forall a b. (a -> b) -> a -> b
$ BuildConfig -> Config
bcConfig BuildConfig
bconfig of
        PCProject (Project, Path Abs File)
_ -> Bool
False
        ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
        PCNoProject [PackageIdentifierRevision]
_ -> Bool
False