{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE NoFieldSelectors      #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}

{-|
Module      : Stack.Build.Target
Description : Parsing command line targets.
License     : BSD-3-Clause

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
snapshot (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 t'ResolveResult's together into t'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 (..)
  , parseTargets
    -- * Convenience helpers

  , gpdVersion
    -- * Test suite exports

  , parseRawTarget
  , RawTarget (..)
  , UnresolvedComponent (..)
  , ComponentName
  , ResolveResult
  ) 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.BuildOptsCLI ( BuildOptsCLI (..) )
import           Stack.Types.ComponentUtils ( unqualCompFromText )
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
rawInput :: 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
boptscli.targetsCLI
      textTargets :: [Text]
textTargets =
        -- Handle the no targets case, which means we pass in the names of all

        -- project packages

        if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets'
          then (PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (PackageName -> String) -> PackageName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) (Map PackageName ProjectPackage -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
locals)
          else [Text]
textTargets'
  in  ([Text]
textTargets', (Text -> RawInput) -> [Text] -> [RawInput]
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
(UnresolvedComponent -> UnresolvedComponent -> Bool)
-> (UnresolvedComponent -> UnresolvedComponent -> Bool)
-> Eq UnresolvedComponent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnresolvedComponent -> UnresolvedComponent -> Bool
== :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c/= :: UnresolvedComponent -> UnresolvedComponent -> Bool
/= :: UnresolvedComponent -> UnresolvedComponent -> Bool
Eq, Eq UnresolvedComponent
Eq UnresolvedComponent =>
(UnresolvedComponent -> UnresolvedComponent -> Ordering)
-> (UnresolvedComponent -> UnresolvedComponent -> Bool)
-> (UnresolvedComponent -> UnresolvedComponent -> Bool)
-> (UnresolvedComponent -> UnresolvedComponent -> Bool)
-> (UnresolvedComponent -> UnresolvedComponent -> Bool)
-> (UnresolvedComponent
    -> UnresolvedComponent -> UnresolvedComponent)
-> (UnresolvedComponent
    -> UnresolvedComponent -> UnresolvedComponent)
-> Ord 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
$ccompare :: UnresolvedComponent -> UnresolvedComponent -> Ordering
compare :: UnresolvedComponent -> UnresolvedComponent -> Ordering
$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
>= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$cmax :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
max :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
$cmin :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
min :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
Ord, Int -> UnresolvedComponent -> ShowS
[UnresolvedComponent] -> ShowS
UnresolvedComponent -> String
(Int -> UnresolvedComponent -> ShowS)
-> (UnresolvedComponent -> String)
-> ([UnresolvedComponent] -> ShowS)
-> Show UnresolvedComponent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnresolvedComponent -> ShowS
showsPrec :: Int -> UnresolvedComponent -> ShowS
$cshow :: UnresolvedComponent -> String
show :: UnresolvedComponent -> String
$cshowList :: [UnresolvedComponent] -> ShowS
showList :: [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
(RawTarget -> RawTarget -> Bool)
-> (RawTarget -> RawTarget -> Bool) -> Eq RawTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawTarget -> RawTarget -> Bool
== :: RawTarget -> RawTarget -> Bool
$c/= :: RawTarget -> RawTarget -> Bool
/= :: RawTarget -> RawTarget -> Bool
Eq, Int -> RawTarget -> ShowS
[RawTarget] -> ShowS
RawTarget -> String
(Int -> RawTarget -> ShowS)
-> (RawTarget -> String)
-> ([RawTarget] -> ShowS)
-> Show RawTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawTarget -> ShowS
showsPrec :: Int -> RawTarget -> ShowS
$cshow :: RawTarget -> String
show :: RawTarget -> String
$cshowList :: [RawTarget] -> ShowS
showList :: [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 -> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc [(RawInput, RawTarget)]
 -> m (Either StyleDoc [(RawInput, RawTarget)]))
-> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a b. (a -> b) -> a -> b
$ [(RawInput, RawTarget)] -> Either StyleDoc [(RawInput, RawTarget)]
forall a b. b -> Either a b
Right [(RawInput
ri, RawTarget
rt)]
    Maybe RawTarget
Nothing -> do
      Maybe (Path Abs Dir)
mdir <- Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Maybe (Path Abs Dir))
forgivingResolveDir Path Abs Dir
root (Text -> String
T.unpack Text
t) m (Maybe (Path Abs Dir))
-> (Maybe (Path Abs Dir) -> m (Maybe (Path Abs Dir)))
-> m (Maybe (Path Abs Dir))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe (Path Abs Dir) -> m (Maybe (Path Abs Dir))
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 -> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc [(RawInput, RawTarget)]
 -> m (Either StyleDoc [(RawInput, RawTarget)]))
-> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc [(RawInput, RawTarget)]
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc [(RawInput, RawTarget)])
-> StyleDoc -> Either StyleDoc [(RawInput, RawTarget)]
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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
        Just Path Abs Dir
dir ->
          case ((PackageName, ProjectPackage) -> Maybe PackageName)
-> [(PackageName, ProjectPackage)] -> [PackageName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Path Abs Dir -> (PackageName, ProjectPackage) -> Maybe PackageName
forall {a}. Path Abs Dir -> (a, ProjectPackage) -> Maybe a
childOf Path Abs Dir
dir) ([(PackageName, ProjectPackage)] -> [PackageName])
-> [(PackageName, ProjectPackage)] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ Map PackageName ProjectPackage -> [(PackageName, ProjectPackage)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName ProjectPackage
locals of
            [] -> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc [(RawInput, RawTarget)]
 -> m (Either StyleDoc [(RawInput, RawTarget)]))
-> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc [(RawInput, RawTarget)]
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc [(RawInput, RawTarget)])
-> StyleDoc -> Either StyleDoc [(RawInput, RawTarget)]
forall a b. (a -> b) -> a -> b
$
              [StyleDoc] -> StyleDoc
fillSep
                [ Style -> StyleDoc -> StyleDoc
style Style
Dir (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t)
                , String -> StyleDoc
flow String
"is not a local directory for a package and it is not a \
                       \parent directory of any such directory."
                ]
            [PackageName]
names -> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc [(RawInput, RawTarget)]
 -> m (Either StyleDoc [(RawInput, RawTarget)]))
-> Either StyleDoc [(RawInput, RawTarget)]
-> m (Either StyleDoc [(RawInput, RawTarget)])
forall a b. (a -> b) -> a -> b
$ [(RawInput, RawTarget)] -> Either StyleDoc [(RawInput, RawTarget)]
forall a b. b -> Either a b
Right ([(RawInput, RawTarget)]
 -> Either StyleDoc [(RawInput, RawTarget)])
-> [(RawInput, RawTarget)]
-> Either StyleDoc [(RawInput, RawTarget)]
forall a b. (a -> b) -> a -> b
$ (PackageName -> (RawInput, RawTarget))
-> [PackageName] -> [(RawInput, RawTarget)]
forall a b. (a -> b) -> [a] -> [b]
map ((RawInput
ri, ) (RawTarget -> (RawInput, RawTarget))
-> (PackageName -> RawTarget)
-> PackageName
-> (RawInput, RawTarget)
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 Path Abs Dir -> Path Abs Dir -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectPackage -> Path Abs Dir
ppRoot ProjectPackage
pp Bool -> Bool -> Bool
|| Path Abs Dir -> Path Abs Dir -> Bool
forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Abs Dir
dir (ProjectPackage -> Path Abs Dir
ppRoot ProjectPackage
pp)
      then a -> Maybe a
forall a. a -> Maybe a
Just a
name
      else Maybe a
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 (String -> Int
forall a. [a] -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
padLength Char
' ') StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
t))
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
" is not a directory."
      , Style -> StyleDoc -> StyleDoc
style Style
Highlight (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ String
"--" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
option)
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Style -> StyleDoc -> StyleDoc
style Style
Dir (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> ShowS -> String -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
dropLength (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t)
        StyleDoc -> StyleDoc -> StyleDoc
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 (PackageIdentifier -> RawTarget)
-> Maybe PackageIdentifier -> Maybe RawTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
s)
  Maybe RawTarget -> Maybe RawTarget -> Maybe RawTarget
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PackageName -> RawTarget
RTPackage (PackageName -> RawTarget) -> Maybe PackageName -> Maybe RawTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageName
parsePackageName String
s)
  Maybe RawTarget -> Maybe RawTarget -> Maybe RawTarget
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> RawTarget
RTComponent (Text -> RawTarget) -> Maybe Text -> Maybe RawTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t)
  Maybe RawTarget -> Maybe RawTarget -> Maybe RawTarget
forall a. Maybe a -> Maybe a -> Maybe a
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 HasCallStack => Text -> Text -> [Text]
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) ->
            RawTarget -> Maybe RawTarget
forall a. a -> Maybe a
Just (RawTarget -> Maybe RawTarget) -> RawTarget -> Maybe RawTarget
forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' (UnresolvedComponent -> RawTarget)
-> UnresolvedComponent -> RawTarget
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) ->
            RawTarget -> Maybe RawTarget
forall a. a -> Maybe a
Just (RawTarget -> Maybe RawTarget) -> RawTarget -> Maybe RawTarget
forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' (UnresolvedComponent -> RawTarget)
-> UnresolvedComponent -> RawTarget
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 <- Text -> Maybe (Text -> NamedComponent)
forall {a}.
(Eq a, IsString a) =>
a -> Maybe (Text -> NamedComponent)
parseCompType Text
typ ->
            RawTarget -> Maybe RawTarget
forall a. a -> Maybe a
Just (RawTarget -> Maybe RawTarget) -> RawTarget -> Maybe RawTarget
forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' (UnresolvedComponent -> RawTarget)
-> UnresolvedComponent -> RawTarget
forall a b. (a -> b) -> a -> b
$ NamedComponent -> UnresolvedComponent
ResolvedComponent (NamedComponent -> UnresolvedComponent)
-> NamedComponent -> UnresolvedComponent
forall a b. (a -> b) -> a -> b
$ Text -> NamedComponent
wrapper Text
cname
      [Text]
_ -> Maybe RawTarget
forall a. Maybe a
Nothing

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

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

-- Resolve the raw targets

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


-- | A type representing results of resolving a raw target.

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

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

  , ResolveResult -> PackageType
packageType :: !PackageType
  }

-- | Convert a 'RawTarget' into a t'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
rawInput, RawTarget
rt) =
  RawTarget -> RIO env (Either StyleDoc ResolveResult)
go RawTarget
rt
 where
  locals :: Map PackageName ProjectPackage
locals = SMActual GlobalPackage
sma.project
  deps :: Map PackageName DepPackage
deps = SMActual GlobalPackage
sma.deps
  globals :: Map PackageName GlobalPackage
globals = SMActual GlobalPackage
sma.globals
  -- 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 NamedComponent
t2 = case NamedComponent
t2 of
    (CSubLib StackUnqualCompName
t2') -> StackUnqualCompName
t1' StackUnqualCompName -> StackUnqualCompName -> Bool
forall a. Eq a => a -> a -> Bool
== StackUnqualCompName
t2'
    (CExe StackUnqualCompName
t2') -> StackUnqualCompName
t1' StackUnqualCompName -> StackUnqualCompName -> Bool
forall a. Eq a => a -> a -> Bool
== StackUnqualCompName
t2'
    (CFlib StackUnqualCompName
t2') -> StackUnqualCompName
t1' StackUnqualCompName -> StackUnqualCompName -> Bool
forall a. Eq a => a -> a -> Bool
== StackUnqualCompName
t2'
    (CTest StackUnqualCompName
t2') -> StackUnqualCompName
t1' StackUnqualCompName -> StackUnqualCompName -> Bool
forall a. Eq a => a -> a -> Bool
== StackUnqualCompName
t2'
    (CBench StackUnqualCompName
t2') -> StackUnqualCompName
t1' StackUnqualCompName -> StackUnqualCompName -> Bool
forall a. Eq a => a -> a -> Bool
== StackUnqualCompName
t2'
   where
    t1' :: StackUnqualCompName
t1' = Text -> StackUnqualCompName
unqualCompFromText Text
t1

  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 <- (Map PackageName [(PackageName, NamedComponent)]
 -> [(PackageName, NamedComponent)])
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
-> RIO env [(PackageName, NamedComponent)]
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map PackageName [(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (RIO env (Map PackageName [(PackageName, NamedComponent)])
 -> RIO env [(PackageName, NamedComponent)])
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
-> RIO env [(PackageName, NamedComponent)]
forall a b. (a -> b) -> a -> b
$ ((PackageName
  -> ProjectPackage -> RIO env [(PackageName, NamedComponent)])
 -> Map PackageName ProjectPackage
 -> RIO env (Map PackageName [(PackageName, NamedComponent)]))
-> Map PackageName ProjectPackage
-> (PackageName
    -> ProjectPackage -> RIO env [(PackageName, NamedComponent)])
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageName
 -> ProjectPackage -> RIO env [(PackageName, NamedComponent)])
-> Map PackageName ProjectPackage
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Map PackageName ProjectPackage
locals
      ((PackageName
  -> ProjectPackage -> RIO env [(PackageName, NamedComponent)])
 -> RIO env (Map PackageName [(PackageName, NamedComponent)]))
-> (PackageName
    -> ProjectPackage -> RIO env [(PackageName, NamedComponent)])
-> RIO env (Map PackageName [(PackageName, NamedComponent)])
forall a b. (a -> b) -> a -> b
$ \PackageName
name ProjectPackage
pp -> do
          Set NamedComponent
comps <- ProjectPackage -> RIO env (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents ProjectPackage
pp
          [(PackageName, NamedComponent)]
-> RIO env [(PackageName, NamedComponent)]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageName, NamedComponent)]
 -> RIO env [(PackageName, NamedComponent)])
-> [(PackageName, NamedComponent)]
-> RIO env [(PackageName, NamedComponent)]
forall a b. (a -> b) -> a -> b
$ (NamedComponent -> (PackageName, NamedComponent))
-> [NamedComponent] -> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName
name, ) ([NamedComponent] -> [(PackageName, NamedComponent)])
-> [NamedComponent] -> [(PackageName, NamedComponent)]
forall a b. (a -> b) -> a -> b
$ Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList Set NamedComponent
comps
    Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ case ((PackageName, NamedComponent) -> Bool)
-> [(PackageName, NamedComponent)]
-> [(PackageName, NamedComponent)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> NamedComponent -> Bool
isCompNamed Text
cname (NamedComponent -> Bool)
-> ((PackageName, NamedComponent) -> NamedComponent)
-> (PackageName, NamedComponent)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, NamedComponent) -> NamedComponent
forall a b. (a, b) -> b
snd) [(PackageName, NamedComponent)]
allPairs of
      [] -> StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
        [StyleDoc] -> StyleDoc
fillSep
          [ Style -> StyleDoc -> StyleDoc
style Style
Target (StyleDoc -> StyleDoc) -> (Text -> StyleDoc) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> (Text -> String) -> Text -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> StyleDoc) -> Text -> StyleDoc
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 (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
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
component)] -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
        { PackageName
name :: PackageName
name :: PackageName
name
        , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
        , component :: Maybe NamedComponent
component = NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
component
        , addedDep :: Maybe PackageLocationImmutable
addedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
        , packageType :: PackageType
packageType = PackageType
PTProject
        }
      [(PackageName, NamedComponent)]
matches -> StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
           [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Ambiguous component name"
             , Style -> StyleDoc -> StyleDoc
style Style
Target (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
cname) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
             , StyleDoc
"matches:"
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
bulletedList
             ( ((PackageName, NamedComponent) -> StyleDoc)
-> [(PackageName, NamedComponent)] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map
                 ( \(PackageName
pn, NamedComponent
nc) -> [StyleDoc] -> StyleDoc
fillSep
                     [ StyleDoc
"component"
                     , Style -> StyleDoc -> StyleDoc
style
                         Style
PkgComponent
                         (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ NamedComponent -> Text
renderComponent NamedComponent
nc)
                     , String -> StyleDoc
flow String
"of package"
                     , Style -> StyleDoc -> StyleDoc
style Style
PkgComponent (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
pn)
                     ]
                 )
                 [(PackageName, NamedComponent)]
matches
             )

  go (RTPackageComponent PackageName
name UnresolvedComponent
ucomp) =
    case PackageName
-> Map PackageName ProjectPackage -> Maybe ProjectPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName ProjectPackage
locals of
      Maybe ProjectPackage
Nothing -> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
        [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Unknown project package:"
          , Style -> StyleDoc -> StyleDoc
style Style
Target (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
      Just ProjectPackage
pp -> do
        Set NamedComponent
comps <- ProjectPackage -> RIO env (Set NamedComponent)
forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents ProjectPackage
pp
        Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ case UnresolvedComponent
ucomp of
          ResolvedComponent NamedComponent
component
            | NamedComponent
component NamedComponent -> Set NamedComponent -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NamedComponent
comps -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
                { PackageName
name :: PackageName
name :: PackageName
name
                , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
                , component :: Maybe NamedComponent
component = NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
component
                , addedDep :: Maybe PackageLocationImmutable
addedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
                , packageType :: PackageType
packageType = PackageType
PTProject
                }
            | Bool
otherwise -> StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ StyleDoc
"Component"
                  , Style -> StyleDoc -> StyleDoc
style
                      Style
Target
                      (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ NamedComponent -> Text
renderComponent NamedComponent
component)
                  , String -> StyleDoc
flow String
"does not exist in package"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
          UnresolvedComponent Text
comp' ->
            case (NamedComponent -> Bool) -> [NamedComponent] -> [NamedComponent]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> NamedComponent -> Bool
isCompNamed Text
comp') ([NamedComponent] -> [NamedComponent])
-> [NamedComponent] -> [NamedComponent]
forall a b. (a -> b) -> a -> b
$ Set NamedComponent -> [NamedComponent]
forall a. Set a -> [a]
Set.toList Set NamedComponent
comps of
              [] -> StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ StyleDoc
"Component"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
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 (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
              [NamedComponent
component] -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
                { PackageName
name :: PackageName
name :: PackageName
name
                , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
                , component :: Maybe NamedComponent
component = NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
component
                , addedDep :: Maybe PackageLocationImmutable
addedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
                , packageType :: PackageType
packageType = PackageType
PTProject
                }
              [NamedComponent]
matches -> StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"Ambiguous component name"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
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 (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name)
                  , String -> StyleDoc
flow String
"matches components:"
                  , [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                      Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
PkgComponent) Bool
False
                        ((NamedComponent -> StyleDoc) -> [NamedComponent] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map NamedComponent -> StyleDoc
ncToStyleDoc [NamedComponent]
matches)
                  ]
   where
    ncToStyleDoc :: NamedComponent -> StyleDoc
    ncToStyleDoc :: NamedComponent -> StyleDoc
ncToStyleDoc = String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (NamedComponent -> String) -> NamedComponent -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (NamedComponent -> Text) -> NamedComponent -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedComponent -> Text
renderComponent

  go (RTPackage PackageName
name)
    | PackageName -> Map PackageName ProjectPackage -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName ProjectPackage
locals = Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
        { PackageName
name :: PackageName
name :: PackageName
name
        , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
        , component :: Maybe NamedComponent
component = Maybe NamedComponent
forall a. Maybe a
Nothing
        , addedDep :: Maybe PackageLocationImmutable
addedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
        , packageType :: PackageType
packageType = PackageType
PTProject
        }
    | PackageName -> Map PackageName DepPackage -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName DepPackage
deps =
        Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ PackageName -> Either StyleDoc ResolveResult
deferToConstructPlan PackageName
name
    | Just GlobalPackage
gp <- PackageName -> Map PackageName GlobalPackage -> Maybe GlobalPackage
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
_ -> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
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))
    | PackageName -> Map PackageName ProjectPackage -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName ProjectPackage
locals = Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
        [StyleDoc] -> StyleDoc
fillSep
          [ Style -> StyleDoc -> StyleDoc
style Style
Target (PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId PackageIdentifier
ident)
          , String -> StyleDoc
flow String
"is a specific package version, but"
          , Style -> StyleDoc -> StyleDoc
style Style
Target (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name)
          , String -> StyleDoc
flow String
"is the name of a project package. To avoid confusion, Stack \
                 \will not try to build the specified version or the project \
                 \package. To build the project package, specify only"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
          ]
    | Bool
otherwise =
        case PackageName
-> Map PackageName PackageLocation -> Maybe PackageLocation
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 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
versionLoc
                then Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ PackageName -> Either StyleDoc ResolveResult
deferToConstructPlan PackageName
name
                else PackageName
-> Version -> Version -> RIO env (Either StyleDoc ResolveResult)
hackageLatestRevision PackageName
name Version
version Version
versionLoc
          -- The package was coming from something besides the index, so refuse

          -- to do the override

          Just PackageLocation
loc' -> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
            [StyleDoc] -> StyleDoc
fillSep
              [ Style -> StyleDoc -> StyleDoc
style Style
Target (PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId PackageIdentifier
ident)
              , String -> StyleDoc
flow String
"was specified from a non-index location, namely:"
              , String -> StyleDoc
flow (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PackageLocation -> Text
forall a. Display a => a -> Text
textDisplay PackageLocation
loc' Text -> Text -> Text
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 <- RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
            Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ case Maybe (Revision, BlobKey, TreeKey)
mrev of
              Maybe (Revision, BlobKey, TreeKey)
Nothing -> StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
                [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"Stack did not know the location of a package named"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name)
                  , StyleDoc
"and could not find"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId PackageIdentifier
ident)
                  , String -> StyleDoc
flow String
"in the package index."
                  ]
              Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
                { PackageName
name :: PackageName
name :: PackageName
name
                , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
                , component :: Maybe NamedComponent
component = Maybe NamedComponent
forall a. Maybe a
Nothing
                , addedDep :: Maybe PackageLocationImmutable
addedDep = PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (PackageLocationImmutable -> Maybe PackageLocationImmutable)
-> PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$
                    PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
                , packageType :: PackageType
packageType = PackageType
PTDependency
                }

  hackageLatest :: PackageName -> RIO env (Either StyleDoc ResolveResult)
hackageLatest PackageName
name = do
    Maybe PackageLocationImmutable
mloc <-
      RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
YesRequireHackageIndex PackageName
name UsePreferredVersions
UsePreferredVersions
    Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
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 ->
        ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
          { PackageName
name :: PackageName
name :: PackageName
name
          , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
          , component :: Maybe NamedComponent
component = Maybe NamedComponent
forall a. Maybe a
Nothing
          , addedDep :: Maybe PackageLocationImmutable
addedDep = PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just PackageLocationImmutable
loc
          , packageType :: PackageType
packageType = PackageType
PTDependency
          }

  hackageLatestRevision :: PackageName
-> Version -> Version -> RIO env (Either StyleDoc ResolveResult)
hackageLatestRevision PackageName
name Version
version Version
versionLoc = do
    Maybe (Revision, BlobKey, TreeKey)
mrev <- RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
    Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc ResolveResult
 -> RIO env (Either StyleDoc ResolveResult))
-> Either StyleDoc ResolveResult
-> RIO env (Either StyleDoc ResolveResult)
forall a b. (a -> b) -> a -> b
$ case Maybe (Revision, BlobKey, TreeKey)
mrev of
      Maybe (Revision, BlobKey, TreeKey)
Nothing ->  StyleDoc -> Either StyleDoc ResolveResult
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc ResolveResult)
-> StyleDoc -> Either StyleDoc ResolveResult
forall a b. (a -> b) -> a -> b
$
        [StyleDoc] -> StyleDoc
fillSep
          [ String -> StyleDoc
flow String
"Stack knows the location of"
          , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId PackageIdentifier
pkgId')
          , String -> StyleDoc
flow String
"but did not know the location of"
          , Style -> StyleDoc -> StyleDoc
style Style
Target (PackageIdentifier -> StyleDoc
forall a. IsString a => PackageIdentifier -> a
fromPackageId PackageIdentifier
pkgId) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<>StyleDoc
","
          , String -> StyleDoc
flow String
"and did not find it in the package index."
          ]
       where
        pkgId :: PackageIdentifier
pkgId = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version
        pkgId' :: PackageIdentifier
pkgId' = PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
versionLoc
      Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
        { PackageName
name :: PackageName
name :: PackageName
name
        , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
        , component :: Maybe NamedComponent
component = Maybe NamedComponent
forall a. Maybe a
Nothing
        , addedDep :: Maybe PackageLocationImmutable
addedDep =
            PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a. a -> Maybe a
Just (PackageLocationImmutable -> Maybe PackageLocationImmutable)
-> PackageLocationImmutable -> Maybe PackageLocationImmutable
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
        , packageType :: PackageType
packageType = 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 = ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
    { PackageName
name :: PackageName
name :: PackageName
name
    , RawInput
rawInput :: RawInput
rawInput :: RawInput
rawInput
    , component :: Maybe NamedComponent
component = Maybe NamedComponent
forall a. Maybe a
Nothing
    , addedDep :: Maybe PackageLocationImmutable
addedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
    , packageType :: PackageType
packageType = 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 <- ([Map PackageName PackageLocationImmutable]
 -> Map PackageName PackageLocationImmutable)
-> RIO env [Map PackageName PackageLocationImmutable]
-> RIO env (Map PackageName PackageLocationImmutable)
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Map PackageName PackageLocationImmutable]
-> Map PackageName PackageLocationImmutable
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (RIO env [Map PackageName PackageLocationImmutable]
 -> RIO env (Map PackageName PackageLocationImmutable))
-> RIO env [Map PackageName PackageLocationImmutable]
-> RIO env (Map PackageName PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ [ResolveResult]
-> (ResolveResult
    -> RIO env (Map PackageName PackageLocationImmutable))
-> RIO env [Map PackageName PackageLocationImmutable]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ResolveResult]
results ((ResolveResult
  -> RIO env (Map PackageName PackageLocationImmutable))
 -> RIO env [Map PackageName PackageLocationImmutable])
-> (ResolveResult
    -> RIO env (Map PackageName PackageLocationImmutable))
-> RIO env [Map PackageName PackageLocationImmutable]
forall a b. (a -> b) -> a -> b
$ \ResolveResult
result ->
    case ResolveResult
result.addedDep of
      Maybe PackageLocationImmutable
Nothing -> Map PackageName PackageLocationImmutable
-> RIO env (Map PackageName PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PackageName PackageLocationImmutable
forall k a. Map k a
Map.empty
      Just PackageLocationImmutable
pl -> Map PackageName PackageLocationImmutable
-> RIO env (Map PackageName PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map PackageName PackageLocationImmutable
 -> RIO env (Map PackageName PackageLocationImmutable))
-> Map PackageName PackageLocationImmutable
-> RIO env (Map PackageName PackageLocationImmutable)
forall a b. (a -> b) -> a -> b
$ PackageName
-> PackageLocationImmutable
-> Map PackageName PackageLocationImmutable
forall k a. k -> a -> Map k a
Map.singleton ResolveResult
result.name PackageLocationImmutable
pl

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

          -- all rrs are components

          case [ResolveResult]
rrs of
            [] -> Bool
-> Either StyleDoc (Map PackageName Target)
-> Either StyleDoc (Map PackageName Target)
forall a. HasCallStack => Bool -> a -> a
assert Bool
False (Either StyleDoc (Map PackageName Target)
 -> Either StyleDoc (Map PackageName Target))
-> Either StyleDoc (Map PackageName Target)
-> Either StyleDoc (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$
              StyleDoc -> Either StyleDoc (Map PackageName Target)
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc (Map PackageName Target))
-> StyleDoc -> Either StyleDoc (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$
                String -> StyleDoc
flow String
"Somehow got no rrComponent values, that can't happen."
            [ResolveResult
rr] | Maybe NamedComponent -> Bool
forall a. Maybe a -> Bool
isNothing ResolveResult
rr.component ->
              Map PackageName Target -> Either StyleDoc (Map PackageName Target)
forall a b. b -> Either a b
Right (Map PackageName Target
 -> Either StyleDoc (Map PackageName Target))
-> Map PackageName Target
-> Either StyleDoc (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$ PackageName -> Target -> Map PackageName Target
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (Target -> Map PackageName Target)
-> Target -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ PackageType -> Target
TargetAll ResolveResult
rr.packageType
            [ResolveResult]
_
              | (Maybe NamedComponent -> Bool) -> [Maybe NamedComponent] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Maybe NamedComponent -> Bool
forall a. Maybe a -> Bool
isJust [Maybe NamedComponent]
mcomps ->
                  Map PackageName Target -> Either StyleDoc (Map PackageName Target)
forall a b. b -> Either a b
Right (Map PackageName Target
 -> Either StyleDoc (Map PackageName Target))
-> Map PackageName Target
-> Either StyleDoc (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$ PackageName -> Target -> Map PackageName Target
forall k a. k -> a -> Map k a
Map.singleton PackageName
name (Target -> Map PackageName Target)
-> Target -> Map PackageName Target
forall a b. (a -> b) -> a -> b
$ Set NamedComponent -> Target
TargetComps (Set NamedComponent -> Target) -> Set NamedComponent -> Target
forall a b. (a -> b) -> a -> b
$ [NamedComponent] -> Set NamedComponent
forall a. Ord a => [a] -> Set a
Set.fromList ([NamedComponent] -> Set NamedComponent)
-> [NamedComponent] -> Set NamedComponent
forall a b. (a -> b) -> a -> b
$
                    [Maybe NamedComponent] -> [NamedComponent]
forall a. [Maybe a] -> [a]
catMaybes [Maybe NamedComponent]
mcomps
              | Bool
otherwise -> StyleDoc -> Either StyleDoc (Map PackageName Target)
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc (Map PackageName Target))
-> StyleDoc -> Either StyleDoc (Map PackageName Target)
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> StyleDoc
fillSep
                  [ String -> StyleDoc
flow String
"The package"
                  , Style -> StyleDoc -> StyleDoc
style Style
Target (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> StyleDoc
forall a. IsString a => PackageName -> a
fromPackageName PackageName
name
                  , String -> StyleDoc
flow String
"was specified in multiple, incompatible ways:"
                  , [StyleDoc] -> StyleDoc
fillSep ([StyleDoc] -> StyleDoc) -> [StyleDoc] -> StyleDoc
forall a b. (a -> b) -> a -> b
$
                      Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Target) Bool
False
                        ((ResolveResult -> StyleDoc) -> [ResolveResult] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map ResolveResult -> StyleDoc
rrToStyleDoc [ResolveResult]
rrs)
                  ]
  ([StyleDoc], Map PackageName Target,
 Map PackageName PackageLocationImmutable)
-> RIO
     env
     ([StyleDoc], Map PackageName Target,
      Map PackageName PackageLocationImmutable)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([StyleDoc]
errs, [Map PackageName Target] -> Map PackageName Target
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 = String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc)
-> (ResolveResult -> String) -> ResolveResult -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String)
-> (ResolveResult -> Text) -> ResolveResult -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.rawInput.rawInput)

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

-- OK, let's do it!

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


-- | Parse targets and dependencies from the given command line arguments and

-- source map.

parseTargets ::
     HasBuildConfig env
  => NeedTargets
  -> Bool
     -- ^ Should Haddock documentation be built for the package?

  -> 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
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Parsing the targets"
  BuildConfig
bconfig <- Getting BuildConfig env BuildConfig -> RIO env BuildConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildConfig env BuildConfig
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL
  Path Abs Dir
workingDir <- RIO env (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
  Map PackageName ProjectPackage
locals <- Getting
  (Map PackageName ProjectPackage)
  env
  (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName ProjectPackage)
   env
   (Map PackageName ProjectPackage)
 -> RIO env (Map PackageName ProjectPackage))
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
-> RIO env (Map PackageName ProjectPackage)
forall a b. (a -> b) -> a -> b
$ (BuildConfig -> Const (Map PackageName ProjectPackage) BuildConfig)
-> env -> Const (Map PackageName ProjectPackage) env
forall env. HasBuildConfig env => Lens' env BuildConfig
Lens' env BuildConfig
buildConfigL ((BuildConfig
  -> Const (Map PackageName ProjectPackage) BuildConfig)
 -> env -> Const (Map PackageName ProjectPackage) env)
-> ((Map PackageName ProjectPackage
     -> Const
          (Map PackageName ProjectPackage) (Map PackageName ProjectPackage))
    -> BuildConfig
    -> Const (Map PackageName ProjectPackage) BuildConfig)
-> Getting
     (Map PackageName ProjectPackage)
     env
     (Map PackageName ProjectPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildConfig -> Map PackageName ProjectPackage)
-> SimpleGetter BuildConfig (Map PackageName ProjectPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.smWanted.project)
  let ([Text]
textTargets', [RawInput]
rawInput) = BuildOptsCLI
-> Map PackageName ProjectPackage -> ([Text], [RawInput])
getRawInput BuildOptsCLI
boptscli Map PackageName ProjectPackage
locals

  ([StyleDoc]
errs1, [[(RawInput, RawTarget)]] -> [(RawInput, RawTarget)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [(RawInput, RawTarget)]
rawTargets) <- ([Either StyleDoc [(RawInput, RawTarget)]]
 -> ([StyleDoc], [[(RawInput, RawTarget)]]))
-> RIO env [Either StyleDoc [(RawInput, RawTarget)]]
-> RIO env ([StyleDoc], [[(RawInput, RawTarget)]])
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either StyleDoc [(RawInput, RawTarget)]]
-> ([StyleDoc], [[(RawInput, RawTarget)]])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (RIO env [Either StyleDoc [(RawInput, RawTarget)]]
 -> RIO env ([StyleDoc], [[(RawInput, RawTarget)]]))
-> RIO env [Either StyleDoc [(RawInput, RawTarget)]]
-> RIO env ([StyleDoc], [[(RawInput, RawTarget)]])
forall a b. (a -> b) -> a -> b
$ [RawInput]
-> (RawInput -> RIO env (Either StyleDoc [(RawInput, RawTarget)]))
-> RIO env [Either StyleDoc [(RawInput, RawTarget)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawInput]
rawInput ((RawInput -> RIO env (Either StyleDoc [(RawInput, RawTarget)]))
 -> RIO env [Either StyleDoc [(RawInput, RawTarget)]])
-> (RawInput -> RIO env (Either StyleDoc [(RawInput, RawTarget)]))
-> RIO env [Either StyleDoc [(RawInput, RawTarget)]]
forall a b. (a -> b) -> a -> b
$
    Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> RIO env (Either StyleDoc [(RawInput, RawTarget)])
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 = (DepPackage -> PackageLocation)
-> Map PackageName DepPackage -> Map PackageName PackageLocation
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (.location) SMActual GlobalPackage
smActual.deps

  ([StyleDoc]
errs2, [ResolveResult]
resolveResults) <- ([Either StyleDoc ResolveResult] -> ([StyleDoc], [ResolveResult]))
-> RIO env [Either StyleDoc ResolveResult]
-> RIO env ([StyleDoc], [ResolveResult])
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either StyleDoc ResolveResult] -> ([StyleDoc], [ResolveResult])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (RIO env [Either StyleDoc ResolveResult]
 -> RIO env ([StyleDoc], [ResolveResult]))
-> RIO env [Either StyleDoc ResolveResult]
-> RIO env ([StyleDoc], [ResolveResult])
forall a b. (a -> b) -> a -> b
$ [(RawInput, RawTarget)]
-> ((RawInput, RawTarget)
    -> RIO env (Either StyleDoc ResolveResult))
-> RIO env [Either StyleDoc ResolveResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RawInput, RawTarget)]
rawTargets (((RawInput, RawTarget) -> RIO env (Either StyleDoc ResolveResult))
 -> RIO env [Either StyleDoc ResolveResult])
-> ((RawInput, RawTarget)
    -> RIO env (Either StyleDoc ResolveResult))
-> RIO env [Either StyleDoc ResolveResult]
forall a b. (a -> b) -> a -> b
$
    SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either StyleDoc ResolveResult)
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) <- [ResolveResult]
-> RIO
     env
     ([StyleDoc], Map PackageName Target,
      Map PackageName PackageLocationImmutable)
forall env.
HasLogFunc env =>
[ResolveResult]
-> RIO
     env
     ([StyleDoc], Map PackageName Target,
      Map PackageName PackageLocationImmutable)
combineResolveResults [ResolveResult]
resolveResults

  case [[StyleDoc]] -> [StyleDoc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[StyleDoc]
errs1, [StyleDoc]
errs2, [StyleDoc]
errs3] of
    [] -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [StyleDoc]
errs -> BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException [StyleDoc]
errs

  case (Map PackageName Target -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName Target
targets, NeedTargets
needTargets) of
    (Bool
False, NeedTargets
_) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Bool
True, NeedTargets
AllowNoTargets) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Bool
True, NeedTargets
NeedTargets)
      | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets' Bool -> Bool -> Bool
&& BuildConfig -> Bool
forall {r} {r} {a}.
(HasField "config" r r, HasField "project" r (ProjectConfig a)) =>
r -> Bool
bcImplicitGlobal BuildConfig
bconfig ->
          BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
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") StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"?"
                ]
            ]
      | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets' Bool -> Bool -> Bool
&& Map PackageName ProjectPackage -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName ProjectPackage
locals ->
          BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException
            [ String -> StyleDoc
flow String
"The project contains no project packages (packages other \
                   \than extra-deps)."
            ]
      | Bool
otherwise -> BuildPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (BuildPrettyException -> RIO env ())
-> BuildPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [StyleDoc] -> BuildPrettyException
TargetParseException
          [ String -> StyleDoc
flow String
"The specified targets matched no packages." ]

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

  SMTargets -> RIO env SMTargets
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMTargets
    { targets :: Map PackageName Target
targets = Map PackageName Target
targets
    , deps :: Map PackageName DepPackage
deps = Map PackageName DepPackage
addedDeps'
    }
 where
  bcImplicitGlobal :: r -> Bool
bcImplicitGlobal r
bconfig =
    case r
bconfig.config.project of
      PCProject a
_ -> Bool
False
      ProjectConfig a
PCGlobalProject -> Bool
True
      PCNoProject [RawPackageLocationImmutable]
_ -> Bool
False