{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# 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 ( isProperPrefixOf )
import           Path.Extra ( forgivingResolveDir, rejectMissingDir )
import           Path.IO ( getCurrentDir )
import           RIO.Process ( HasProcessContext )
import           Stack.SourceMap ( additionalDepPackage )
import           Stack.Prelude
import           Stack.Types.BuildConfig
                   ( BuildConfig (..), HasBuildConfig (..) )
import           Stack.Types.BuildOpts ( BuildOptsCLI (..) )
import           Stack.Types.Config ( Config (..) )
import           Stack.Types.NamedComponent
                   ( NamedComponent (..), renderComponent )
import           Stack.Types.Build.Exception ( BuildPrettyException (..) )
import           Stack.Types.ProjectConfig ( ProjectConfig (..) )
import           Stack.Types.SourceMap
                   ( DepPackage (..), GlobalPackage (..), PackageType (..)
                   , ProjectPackage, SMActual (..), SMTargets (..)
                   , SMWanted (..), Target (..), ppComponents, ppRoot
                   )

-- | 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 (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, 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)

-- | 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 (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, 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)

-- | 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 StyleDoc [(RawInput, RawTarget)])
parseRawTargetDirs :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> m (Either StyleDoc [(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 :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
forgivingResolveDir 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
$
          if | Text -> Text -> Bool
T.isPrefixOf Text
"stack-yaml=" Text
t -> StyleDoc
projectOptionTypo
             | Text -> Text -> Bool
T.isSuffixOf Text
".yaml" Text
t -> StyleDoc
projectYamlExtTypo
             | Bool
otherwise ->
                [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"Directory not found:"
                  , Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
        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
$
              [StyleDoc] -> StyleDoc
fillSep
                [ Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t)
                , String -> StyleDoc
flow String
"is not a local package directory and it is not a \
                       \parent directory of any local package directory."
                ]
            [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

  projectOptionTypo :: StyleDoc
  projectOptionTypo :: StyleDoc
projectOptionTypo = let o :: String
o = String
"stack-yaml=" in Int -> Int -> String -> StyleDoc
projectTypo Int
2 (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
o) String
o

  projectYamlExtTypo :: StyleDoc
  projectYamlExtTypo :: StyleDoc
projectYamlExtTypo = let o :: String
o = String
"stack-yaml " in Int -> Int -> String -> StyleDoc
projectTypo (Int
2 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
o) Int
0 String
o

  projectTypo :: Int -> Int -> String -> StyleDoc
  projectTypo :: Int -> Int -> String -> StyleDoc
projectTypo Int
padLength Int
dropLength String
option =
    [StyleDoc] -> StyleDoc
vsep
      [ Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. IsString a => String -> a
fromString (forall a. Int -> a -> [a]
replicate Int
padLength Char
' ') forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
t))
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
" is not a directory."
      , Style -> StyleDoc -> StyleDoc
style Style
Highlight (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ String
"--" forall a. Semigroup a => a -> a -> a
<> String
option)
        forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Dir (forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
dropLength forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t)
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
" might work as a project option."
      ]

-- | 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 StyleDoc ResolveResult)
resolveRawTarget :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either StyleDoc ResolveResult)
resolveRawTarget SMActual GlobalPackage
sma Map PackageName PackageLocation
allLocs (RawInput
ri, RawTarget
rt) =
  RawTarget -> RIO env (Either StyleDoc 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 StyleDoc 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
$
        [StyleDoc] -> StyleDoc
fillSep
          [ Style -> StyleDoc -> StyleDoc
style Style
Target forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text
cname
          , String -> StyleDoc
flow String
"doesn't seem to be a local target. Run"
          , Style -> StyleDoc -> StyleDoc
style Style
Shell forall a b. (a -> b) -> a -> b
$ String -> StyleDoc
flow String
"stack ide targets"
          , String -> StyleDoc
flow String
"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
$
           [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Ambiguous component name"
             , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cname) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , StyleDoc
"matches:"
             ]
        forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
             ( forall a b. (a -> b) -> [a] -> [b]
map
                 ( \(PackageName
pn, NamedComponent
nc) -> [StyleDoc] -> StyleDoc
fillSep
                     [ StyleDoc
"component"
                     , Style -> StyleDoc -> StyleDoc
style
                         Style
PkgComponent
                         (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ NamedComponent -> Text
renderComponent NamedComponent
nc)
                     , String -> StyleDoc
flow String
"of package"
                     , Style -> StyleDoc -> StyleDoc
style Style
PkgComponent (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pn)
                     ]
                 )
                 [(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
$
        [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Unknown local package:"
          , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      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
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ StyleDoc
"Component"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ NamedComponent -> Text
renderComponent NamedComponent
comp)
                  , String -> StyleDoc
flow String
"does not exist in package"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
          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
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ StyleDoc
"Component"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
comp)
                  , String -> StyleDoc
flow String
"does not exist in package"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
              [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
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"Ambiguous component name"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
comp)
                  , String -> StyleDoc
flow String
"for package"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name)
                  , String -> StyleDoc
flow String
"matches components:"
                  , [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$
                      forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
                        (forall a b. (a -> b) -> [a] -> [b]
map NamedComponent -> StyleDoc
ncToStyleDoc [NamedComponent]
matches)
                  ]
   where
    ncToStyleDoc :: NamedComponent -> StyleDoc
    ncToStyleDoc :: NamedComponent -> StyleDoc
ncToStyleDoc = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent

  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 StyleDoc 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 StyleDoc ResolveResult
deferToConstructPlan PackageName
name
          ReplacedGlobalPackage [PackageName]
_ -> PackageName -> RIO env (Either StyleDoc ResolveResult)
hackageLatest PackageName
name
    | Bool
otherwise = PackageName -> RIO env (Either StyleDoc 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
$
        [StyleDoc] -> StyleDoc
fillSep
          [ Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name)
          , String -> StyleDoc
flow String
"target has a specific version number, but it is a local \
                 \package. To avoid confusion, we will not install the \
                 \specified version or build the local one. To 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 StyleDoc ResolveResult
deferToConstructPlan PackageName
name
                else PackageName -> Version -> RIO env (Either StyleDoc 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
$
            [StyleDoc] -> StyleDoc
fillSep
              [ String -> StyleDoc
flow String
"Package with identifier was targeted on the command \
                     \line:"
              , Style -> StyleDoc -> StyleDoc
style Style
Target (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
              , String -> StyleDoc
flow String
"but it was specified from a non-index location:"
              , String -> StyleDoc
flow forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Text
textDisplay PackageLocation
loc' forall a. Semigroup a => a -> a -> a
<> Text
"."
              , String -> StyleDoc
flow String
"Recommendation: 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 StyleDoc 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 StyleDoc 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 StyleDoc ResolveResult
deferToConstructPlan PackageName
name
      Just PackageLocationImmutable
loc ->
        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 StyleDoc 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 StyleDoc 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 StyleDoc 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
       ( [StyleDoc]
       , Map PackageName Target
       , Map PackageName PackageLocationImmutable
       )
combineResolveResults :: forall env.
HasLogFunc env =>
[ResolveResult]
-> RIO
     env
     ([StyleDoc], 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 -> 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
      ([StyleDoc]
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 forall a b. (a -> b) -> a -> b
$
                String -> StyleDoc
flow String
"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
$ [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"The package"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
                  , String -> StyleDoc
flow String
"was specified in multiple, incompatible ways:"
                  , [StyleDoc] -> StyleDoc
fillSep forall a b. (a -> b) -> a -> b
$
                      forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (forall a. a -> Maybe a
Just Style
Target) Bool
False
                        (forall a b. (a -> b) -> [a] -> [b]
map ResolveResult -> StyleDoc
rrToStyleDoc [ResolveResult]
rrs)
                  ]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StyleDoc]
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)
 where
  rrToStyleDoc :: ResolveResult -> StyleDoc
  rrToStyleDoc :: ResolveResult -> StyleDoc
rrToStyleDoc = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawInput -> Text
unRawInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolveResult -> RawInput
rrRaw

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

-- 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

  ([StyleDoc]
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 StyleDoc [(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

  ([StyleDoc]
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 StyleDoc ResolveResult)
resolveRawTarget SMActual GlobalPackage
smActual Map PackageName PackageLocation
depLocs

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

  case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[StyleDoc]
errs1, [StyleDoc]
errs2, [StyleDoc]
errs3] of
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [StyleDoc]
errs -> forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException [StyleDoc]
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 e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException
            [ [StyleDoc] -> StyleDoc
fillSep
                [ String -> StyleDoc
flow String
"The specified targets matched no packages. Perhaps you \
                       \need to run"
                , Style -> StyleDoc -> StyleDoc
style Style
Shell (String -> StyleDoc
flow String
"stack init") forall a. Semigroup a => a -> a -> a
<> StyleDoc
"?"
                ]
            ]
      | 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 e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException
            [ String -> StyleDoc
flow String
"The project contains no local packages (packages not \
                   \marked with 'extra-dep')."
            ]
      | Bool
otherwise -> forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException
          [ String -> StyleDoc
flow String
"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