{-# 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 [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 package directory and it is not a \
                       \parent directory of any local package 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 Text -> NamedComponent
CExe
      a
"test" -> (Text -> NamedComponent) -> Maybe (Text -> NamedComponent)
forall a. a -> Maybe a
Just Text -> NamedComponent
CTest
      a
"bench" -> (Text -> NamedComponent) -> Maybe (Text -> NamedComponent)
forall a. a -> Maybe a
Just Text -> NamedComponent
CBench
      a
_ -> Maybe (Text -> NamedComponent)
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 = SMActual GlobalPackage -> Map PackageName ProjectPackage
forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual GlobalPackage
sma
  deps :: Map PackageName DepPackage
deps = SMActual GlobalPackage -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackage
sma
  globals :: Map PackageName GlobalPackage
globals = SMActual GlobalPackage -> Map PackageName GlobalPackage
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t2
  isCompNamed Text
t1 (CExe Text
t2) = Text
t1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t2
  isCompNamed Text
t1 (CTest Text
t2) = Text
t1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t2
  isCompNamed Text
t1 (CBench Text
t2) = Text
t1 Text -> Text -> Bool
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 <- (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
comp)] -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
        { rrName :: PackageName
rrName = PackageName
name
        , rrRaw :: RawInput
rrRaw = RawInput
ri
        , rrComponent :: Maybe NamedComponent
rrComponent = NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
comp
        , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
        , rrPackageType :: PackageType
rrPackageType = 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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString 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 local package:"
          , 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
$ PackageName -> String
packageNameString 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
comp
            | NamedComponent
comp 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
                { rrName :: PackageName
rrName = PackageName
name
                , rrRaw :: RawInput
rrRaw = RawInput
ri
                , rrComponent :: Maybe NamedComponent
rrComponent = NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
comp
                , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
                , rrPackageType :: PackageType
rrPackageType = 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
comp)
                  , String -> StyleDoc
flow String
"does not exist in package"
                  , 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
$ PackageName -> String
packageNameString 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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
                  ]
              [NamedComponent
x] -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
                { rrName :: PackageName
rrName = PackageName
name
                , rrRaw :: RawInput
rrRaw = RawInput
ri
                , rrComponent :: Maybe NamedComponent
rrComponent = NamedComponent -> Maybe NamedComponent
forall a. a -> Maybe a
Just NamedComponent
x
                , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
                , rrPackageType :: PackageType
rrPackageType = 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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString 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
        { rrName :: PackageName
rrName = PackageName
name
        , rrRaw :: RawInput
rrRaw = RawInput
ri
        , rrComponent :: Maybe NamedComponent
rrComponent = Maybe NamedComponent
forall a. Maybe a
Nothing
        , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = Maybe PackageLocationImmutable
forall a. Maybe a
Nothing
        , rrPackageType :: PackageType
rrPackageType = 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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
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 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 -> 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' -> 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
"Package with identifier was targeted on the command \
                     \line:"
              , 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
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
","
              , String -> StyleDoc
flow String
"but it was specified from a non-index location:"
              , 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 -> PackageName -> Either StyleDoc ResolveResult
deferToConstructPlan PackageName
name
              Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
                { rrName :: PackageName
rrName = PackageName
name
                , rrRaw :: RawInput
rrRaw = RawInput
ri
                , rrComponent :: Maybe NamedComponent
rrComponent = Maybe NamedComponent
forall a. Maybe a
Nothing
                , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = 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
                , rrPackageType :: PackageType
rrPackageType = 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
          { rrName :: PackageName
rrName = PackageName
name
          , rrRaw :: RawInput
rrRaw = RawInput
ri
          , rrComponent :: Maybe NamedComponent
rrComponent = Maybe NamedComponent
forall a. Maybe a
Nothing
          , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = PackageLocationImmutable -> Maybe PackageLocationImmutable
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 <- 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 -> PackageName -> Either StyleDoc ResolveResult
deferToConstructPlan PackageName
name
      Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
        { rrName :: PackageName
rrName = PackageName
name
        , rrRaw :: RawInput
rrRaw = RawInput
ri
        , rrComponent :: Maybe NamedComponent
rrComponent = Maybe NamedComponent
forall a. Maybe a
Nothing
        , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep =
            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
        , 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 = ResolveResult -> Either StyleDoc ResolveResult
forall a b. b -> Either a b
Right ResolveResult
    { rrName :: PackageName
rrName = PackageName
name
    , rrRaw :: RawInput
rrRaw = RawInput
ri
    , rrComponent :: Maybe NamedComponent
rrComponent = Maybe NamedComponent
forall a. Maybe a
Nothing
    , rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = Maybe PackageLocationImmutable
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 <- ([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 -> Maybe PackageLocationImmutable
rrAddedDep ResolveResult
result 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 -> PackageName
rrName ResolveResult
result) 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 -> PackageName
rrName ResolveResult
rr) [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 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
            [] -> 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 -> Maybe NamedComponent
rrComponent ResolveResult
rr) ->
              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 (PackageType -> Target) -> PackageType -> Target
forall a b. (a -> b) -> a -> b
$ ResolveResult -> PackageType
rrPackageType ResolveResult
rr
            [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
$ String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
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 ([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 -> Text
unRawInput (RawInput -> Text)
-> (ResolveResult -> RawInput) -> ResolveResult -> Text
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
  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 -> Map PackageName ProjectPackage
smwProject (SMWanted -> Map PackageName ProjectPackage)
-> (BuildConfig -> SMWanted)
-> BuildConfig
-> Map PackageName ProjectPackage
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, [[(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 DepPackage -> PackageLocation
dpLocation (Map PackageName DepPackage -> Map PackageName PackageLocation)
-> Map PackageName DepPackage -> Map PackageName PackageLocation
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackage -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackage
smActual

  ([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
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 local packages (packages not \
                   \marked with 'extra-dep')."
            ]
      | 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
    { 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 (Config -> ProjectConfig (Project, Path Abs File))
-> Config -> ProjectConfig (Project, Path Abs File)
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