{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Stack.Build.Target
(
Target (..)
, NeedTargets (..)
, PackageType (..)
, parseTargets
, gpdVersion
, parseRawTarget
, RawTarget (..)
, UnresolvedComponent (..)
) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Path
import Path.Extra ( rejectMissingDir )
import Path.IO
import RIO.Process ( HasProcessContext )
import Stack.SourceMap
import Stack.Prelude
import Stack.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Build
import Stack.Types.SourceMap
data NeedTargets = NeedTargets | AllowNoTargets
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 =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets'
then forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
packageNameString) (forall k a. Map k a -> [k]
Map.keys Map PackageName ProjectPackage
locals)
else [Text]
textTargets'
in ([Text]
textTargets', forall a b. (a -> b) -> [a] -> [b]
map Text -> RawInput
RawInput [Text]
textTargets)
type ComponentName = Text
data UnresolvedComponent
= ResolvedComponent !NamedComponent
| UnresolvedComponent !ComponentName
deriving (Int -> UnresolvedComponent -> ShowS
[UnresolvedComponent] -> ShowS
UnresolvedComponent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnresolvedComponent] -> ShowS
$cshowList :: [UnresolvedComponent] -> ShowS
show :: UnresolvedComponent -> String
$cshow :: UnresolvedComponent -> String
showsPrec :: Int -> UnresolvedComponent -> ShowS
$cshowsPrec :: Int -> UnresolvedComponent -> ShowS
Show, UnresolvedComponent -> UnresolvedComponent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c/= :: UnresolvedComponent -> UnresolvedComponent -> Bool
== :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c== :: UnresolvedComponent -> UnresolvedComponent -> Bool
Eq, Eq UnresolvedComponent
UnresolvedComponent -> UnresolvedComponent -> Bool
UnresolvedComponent -> UnresolvedComponent -> Ordering
UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
$cmin :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
max :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
$cmax :: UnresolvedComponent -> UnresolvedComponent -> UnresolvedComponent
>= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c>= :: UnresolvedComponent -> UnresolvedComponent -> Bool
> :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c> :: UnresolvedComponent -> UnresolvedComponent -> Bool
<= :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c<= :: UnresolvedComponent -> UnresolvedComponent -> Bool
< :: UnresolvedComponent -> UnresolvedComponent -> Bool
$c< :: UnresolvedComponent -> UnresolvedComponent -> Bool
compare :: UnresolvedComponent -> UnresolvedComponent -> Ordering
$ccompare :: UnresolvedComponent -> UnresolvedComponent -> Ordering
Ord)
data RawTarget
= RTPackageComponent !PackageName !UnresolvedComponent
| RTComponent !ComponentName
| RTPackage !PackageName
| RTPackageIdentifier !PackageIdentifier
deriving (Int -> RawTarget -> ShowS
[RawTarget] -> ShowS
RawTarget -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawTarget] -> ShowS
$cshowList :: [RawTarget] -> ShowS
show :: RawTarget -> String
$cshow :: RawTarget -> String
showsPrec :: Int -> RawTarget -> ShowS
$cshowsPrec :: Int -> RawTarget -> ShowS
Show, RawTarget -> RawTarget -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawTarget -> RawTarget -> Bool
$c/= :: RawTarget -> RawTarget -> Bool
== :: RawTarget -> RawTarget -> Bool
$c== :: RawTarget -> RawTarget -> Bool
Eq)
parseRawTargetDirs :: MonadIO m
=> Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs :: forall (m :: * -> *).
MonadIO m =>
Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs Path Abs Dir
root Map PackageName ProjectPackage
locals RawInput
ri =
case Text -> Maybe RawTarget
parseRawTarget Text
t of
Just RawTarget
rt -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right [(RawInput
ri, RawTarget
rt)]
Maybe RawTarget
Nothing -> do
Maybe (Path Abs Dir)
mdir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m (Maybe a)
forgivingAbsence (forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs Dir)
resolveDir Path Abs Dir
root (Text -> String
T.unpack Text
t))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *).
MonadIO m =>
Maybe (Path Abs Dir) -> m (Maybe (Path Abs Dir))
rejectMissingDir
case Maybe (Path Abs Dir)
mdir of
Maybe (Path Abs Dir)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Directory not found: " Text -> Text -> Text
`T.append` Text
t
Just Path Abs Dir
dir ->
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {a}. Path Abs Dir -> (a, ProjectPackage) -> Maybe a
childOf Path Abs Dir
dir) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName ProjectPackage
locals of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
Text
"No local directories found as children of " Text -> Text -> Text
`T.append`
Text
t
[PackageName]
names -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((RawInput
ri, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> RawTarget
RTPackage) [PackageName]
names
where
childOf :: Path Abs Dir -> (a, ProjectPackage) -> Maybe a
childOf Path Abs Dir
dir (a
name, ProjectPackage
pp) =
if Path Abs Dir
dir forall a. Eq a => a -> a -> Bool
== ProjectPackage -> Path Abs Dir
ppRoot ProjectPackage
pp Bool -> Bool -> Bool
|| forall b t. Path b Dir -> Path b t -> Bool
isProperPrefixOf Path Abs Dir
dir (ProjectPackage -> Path Abs Dir
ppRoot ProjectPackage
pp)
then forall a. a -> Maybe a
Just a
name
else forall a. Maybe a
Nothing
RawInput Text
t = RawInput
ri
parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget Text
t =
(PackageIdentifier -> RawTarget
RTPackageIdentifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageIdentifier
parsePackageIdentifier String
s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (PackageName -> RawTarget
RTPackage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe PackageName
parsePackageName String
s)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> RawTarget
RTComponent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe RawTarget
parsePackageComponent
where
s :: String
s = Text -> String
T.unpack Text
t
parsePackageComponent :: Maybe RawTarget
parsePackageComponent =
case Text -> Text -> [Text]
T.splitOn Text
":" Text
t of
[Text
pname, Text
"lib"]
| Just PackageName
pname' <- String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
pname) ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' forall a b. (a -> b) -> a -> b
$ NamedComponent -> UnresolvedComponent
ResolvedComponent NamedComponent
CLib
[Text
pname, Text
cname]
| Just PackageName
pname' <- String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
pname) ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' forall a b. (a -> b) -> a -> b
$ Text -> UnresolvedComponent
UnresolvedComponent Text
cname
[Text
pname, Text
typ, Text
cname]
| Just PackageName
pname' <- String -> Maybe PackageName
parsePackageName (Text -> String
T.unpack Text
pname)
, Just Text -> NamedComponent
wrapper <- forall {a}.
(Eq a, IsString a) =>
a -> Maybe (Text -> NamedComponent)
parseCompType Text
typ ->
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageName -> UnresolvedComponent -> RawTarget
RTPackageComponent PackageName
pname' forall a b. (a -> b) -> a -> b
$ NamedComponent -> UnresolvedComponent
ResolvedComponent forall a b. (a -> b) -> a -> b
$ Text -> NamedComponent
wrapper Text
cname
[Text]
_ -> forall a. Maybe a
Nothing
parseCompType :: a -> Maybe (Text -> NamedComponent)
parseCompType a
t' =
case a
t' of
a
"exe" -> forall a. a -> Maybe a
Just Text -> NamedComponent
CExe
a
"test" -> forall a. a -> Maybe a
Just Text -> NamedComponent
CTest
a
"bench" -> forall a. a -> Maybe a
Just Text -> NamedComponent
CBench
a
_ -> forall a. Maybe a
Nothing
data ResolveResult = ResolveResult
{ ResolveResult -> PackageName
rrName :: !PackageName
, ResolveResult -> RawInput
rrRaw :: !RawInput
, ResolveResult -> Maybe NamedComponent
rrComponent :: !(Maybe NamedComponent)
, ResolveResult -> Maybe PackageLocationImmutable
rrAddedDep :: !(Maybe PackageLocationImmutable)
, ResolveResult -> PackageType
rrPackageType :: !PackageType
}
resolveRawTarget ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget :: forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget SMActual GlobalPackage
sma Map PackageName PackageLocation
allLocs (RawInput
ri, RawTarget
rt) =
RawTarget -> RIO env (Either Text ResolveResult)
go RawTarget
rt
where
locals :: Map PackageName ProjectPackage
locals = forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual GlobalPackage
sma
deps :: Map PackageName DepPackage
deps = forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackage
sma
globals :: Map PackageName GlobalPackage
globals = forall global. SMActual global -> Map PackageName global
smaGlobal SMActual GlobalPackage
sma
isCompNamed :: ComponentName -> NamedComponent -> Bool
isCompNamed :: Text -> NamedComponent -> Bool
isCompNamed Text
_ NamedComponent
CLib = Bool
False
isCompNamed Text
t1 (CInternalLib Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
isCompNamed Text
t1 (CExe Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
isCompNamed Text
t1 (CTest Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
isCompNamed Text
t1 (CBench Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
go :: RawTarget -> RIO env (Either Text ResolveResult)
go (RTComponent Text
cname) = do
[(PackageName, NamedComponent)]
allPairs <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Map PackageName ProjectPackage
locals
forall a b. (a -> b) -> a -> b
$ \PackageName
name ProjectPackage
pp -> do
Set NamedComponent
comps <- forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents ProjectPackage
pp
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageName
name, ) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set NamedComponent
comps
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> NamedComponent -> Bool
isCompNamed Text
cname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(PackageName, NamedComponent)]
allPairs of
[] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
cname Text -> Text -> Text
`T.append` Text
" doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets"
[(PackageName
name, NamedComponent
comp)] -> forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. a -> Maybe a
Just NamedComponent
comp
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
, rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
}
[(PackageName, NamedComponent)]
matches -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Ambiguous component name "
, Text
cname
, Text
", matches: "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [(PackageName, NamedComponent)]
matches
]
go (RTPackageComponent PackageName
name UnresolvedComponent
ucomp) =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName ProjectPackage
locals of
Maybe ProjectPackage
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ String
"Unknown local package: " forall a. [a] -> [a] -> [a]
++ PackageName -> String
packageNameString PackageName
name
Just ProjectPackage
pp -> do
Set NamedComponent
comps <- forall (m :: * -> *).
MonadIO m =>
ProjectPackage -> m (Set NamedComponent)
ppComponents ProjectPackage
pp
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case UnresolvedComponent
ucomp of
ResolvedComponent NamedComponent
comp
| NamedComponent
comp forall a. Ord a => a -> Set a -> Bool
`Set.member` Set NamedComponent
comps -> forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. a -> Maybe a
Just NamedComponent
comp
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
, rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
}
| Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Component "
, forall a. Show a => a -> String
show NamedComponent
comp
, String
" does not exist in package "
, PackageName -> String
packageNameString PackageName
name
]
UnresolvedComponent Text
comp ->
case forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> NamedComponent -> Bool
isCompNamed Text
comp) forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set NamedComponent
comps of
[] -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Component "
, Text
comp
, Text
" does not exist in package "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
]
[NamedComponent
x] -> forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. a -> Maybe a
Just NamedComponent
x
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
, rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
}
[NamedComponent]
matches -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Ambiguous component name "
, Text
comp
, Text
" for package "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
, Text
": "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show [NamedComponent]
matches
]
go (RTPackage PackageName
name)
| forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName ProjectPackage
locals = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
, rrPackageType :: PackageType
rrPackageType = PackageType
PTProject
}
| forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName DepPackage
deps =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
| Just GlobalPackage
gp <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName GlobalPackage
globals =
case GlobalPackage
gp of
GlobalPackage Version
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
ReplacedGlobalPackage [PackageName]
_ -> PackageName -> RIO env (Either Text ResolveResult)
hackageLatest PackageName
name
| Bool
otherwise = PackageName -> RIO env (Either Text ResolveResult)
hackageLatest PackageName
name
go (RTPackageIdentifier ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
name Version
version))
| forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
name Map PackageName ProjectPackage
locals = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ forall a. Show a => a -> Text
tshow (PackageName -> String
packageNameString PackageName
name)
, Text
" target has a specific version number, but it is a local package."
, Text
"\nTo avoid confusion, we will not install the specified version or build the local one."
, Text
"\nTo build the local package, specify the target without an explicit version."
]
| Bool
otherwise =
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName PackageLocation
allLocs of
Just (PLImmutable (PLIHackage (PackageIdentifier PackageName
_name Version
versionLoc) BlobKey
_cfKey TreeKey
_treeKey)) ->
if Version
version forall a. Eq a => a -> a -> Bool
== Version
versionLoc
then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
else PackageName -> Version -> RIO env (Either Text ResolveResult)
hackageLatestRevision PackageName
name Version
version
Just PackageLocation
loc' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Package with identifier was targeted on the command line: "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident
, Text
", but it was specified from a non-index location: "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show PackageLocation
loc'
, Text
".\nRecommendation: add the correctly desired version to extra-deps."
]
Maybe PackageLocation
Nothing -> do
Maybe (Revision, BlobKey, TreeKey)
mrev <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Revision, BlobKey, TreeKey)
mrev of
Maybe (Revision, BlobKey, TreeKey)
Nothing -> PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
, rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
}
hackageLatest :: PackageName -> RIO env (Either Text ResolveResult)
hackageLatest PackageName
name = do
Maybe PackageLocationImmutable
mloc <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageLocationImmutable)
getLatestHackageLocation RequireHackageIndex
YesRequireHackageIndex PackageName
name UsePreferredVersions
UsePreferredVersions
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe PackageLocationImmutable
mloc of
Maybe PackageLocationImmutable
Nothing -> PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
Just PackageLocationImmutable
loc -> do
forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. a -> Maybe a
Just PackageLocationImmutable
loc
, rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
}
hackageLatestRevision :: PackageName -> Version -> RIO env (Either Text ResolveResult)
hackageLatestRevision PackageName
name Version
version = do
Maybe (Revision, BlobKey, TreeKey)
mrev <- forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
RequireHackageIndex
-> PackageName
-> Version
-> RIO env (Maybe (Revision, BlobKey, TreeKey))
getLatestHackageRevision RequireHackageIndex
YesRequireHackageIndex PackageName
name Version
version
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Revision, BlobKey, TreeKey)
mrev of
Maybe (Revision, BlobKey, TreeKey)
Nothing -> PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name
Just (Revision
_rev, BlobKey
cfKey, TreeKey
treeKey) -> forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version) BlobKey
cfKey TreeKey
treeKey
, rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
}
deferToConstructPlan :: PackageName -> Either Text ResolveResult
deferToConstructPlan PackageName
name = forall a b. b -> Either a b
Right ResolveResult
{ rrName :: PackageName
rrName = PackageName
name
, rrRaw :: RawInput
rrRaw = RawInput
ri
, rrComponent :: Maybe NamedComponent
rrComponent = forall a. Maybe a
Nothing
, rrAddedDep :: Maybe PackageLocationImmutable
rrAddedDep = forall a. Maybe a
Nothing
, rrPackageType :: PackageType
rrPackageType = PackageType
PTDependency
}
combineResolveResults
:: forall env. HasLogFunc env
=> [ResolveResult]
-> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocationImmutable)
combineResolveResults :: forall env.
HasLogFunc env =>
[ResolveResult]
-> RIO
env
([Text], Map PackageName Target,
Map PackageName PackageLocationImmutable)
combineResolveResults [ResolveResult]
results = do
Map PackageName PackageLocationImmutable
addedDeps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ResolveResult]
results forall a b. (a -> b) -> a -> b
$ \ResolveResult
result ->
case ResolveResult -> Maybe PackageLocationImmutable
rrAddedDep ResolveResult
result of
Maybe PackageLocationImmutable
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k a. Map k a
Map.empty
Just PackageLocationImmutable
pl -> do
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton (ResolveResult -> PackageName
rrName ResolveResult
result) PackageLocationImmutable
pl
let m0 :: Map PackageName [ResolveResult]
m0 = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\ResolveResult
rr -> forall k a. k -> a -> Map k a
Map.singleton (ResolveResult -> PackageName
rrName ResolveResult
rr) [ResolveResult
rr]) [ResolveResult]
results
([Text]
errs, [Map PackageName Target]
ms) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName [ResolveResult]
m0) forall a b. (a -> b) -> a -> b
$ \(PackageName
name, [ResolveResult]
rrs) ->
let mcomps :: [Maybe NamedComponent]
mcomps = forall a b. (a -> b) -> [a] -> [b]
map ResolveResult -> Maybe NamedComponent
rrComponent [ResolveResult]
rrs in
case [ResolveResult]
rrs of
[] -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
"Somehow got no rrComponent values, that can't happen"
[ResolveResult
rr] | forall a. Maybe a -> Bool
isNothing (ResolveResult -> Maybe NamedComponent
rrComponent ResolveResult
rr) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton PackageName
name forall a b. (a -> b) -> a -> b
$ PackageType -> Target
TargetAll forall a b. (a -> b) -> a -> b
$ ResolveResult -> PackageType
rrPackageType ResolveResult
rr
[ResolveResult]
_
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. Maybe a -> Bool
isJust [Maybe NamedComponent]
mcomps -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton PackageName
name forall a b. (a -> b) -> a -> b
$ Set NamedComponent -> Target
TargetComps forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe NamedComponent]
mcomps
| Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"The package "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
name
, Text
" was specified in multiple, incompatible ways: "
, [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (RawInput -> Text
unRawInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolveResult -> RawInput
rrRaw) [ResolveResult]
rrs
]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text]
errs, forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map PackageName Target]
ms, Map PackageName PackageLocationImmutable
addedDeps)
parseTargets :: HasBuildConfig env
=> NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets :: forall env.
HasBuildConfig env =>
NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets NeedTargets
needTargets Bool
haddockDeps BuildOptsCLI
boptscli SMActual GlobalPackage
smActual = do
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logDebug Utf8Builder
"Parsing the targets"
BuildConfig
bconfig <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigL
Path Abs Dir
workingDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
Map PackageName ProjectPackage
locals <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasBuildConfig env => Lens' env BuildConfig
buildConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to (SMWanted -> Map PackageName ProjectPackage
smwProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildConfig -> SMWanted
bcSMWanted)
let ([Text]
textTargets', [RawInput]
rawInput) = BuildOptsCLI
-> Map PackageName ProjectPackage -> ([Text], [RawInput])
getRawInput BuildOptsCLI
boptscli Map PackageName ProjectPackage
locals
([Text]
errs1, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> [(RawInput, RawTarget)]
rawTargets) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RawInput]
rawInput forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir
-> Map PackageName ProjectPackage
-> RawInput
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs Path Abs Dir
workingDir Map PackageName ProjectPackage
locals
let depLocs :: Map PackageName PackageLocation
depLocs = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map DepPackage -> PackageLocation
dpLocation forall a b. (a -> b) -> a -> b
$ forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackage
smActual
([Text]
errs2, [ResolveResult]
resolveResults) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(RawInput, RawTarget)]
rawTargets forall a b. (a -> b) -> a -> b
$
forall env.
(HasLogFunc env, HasPantryConfig env, HasProcessContext env) =>
SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget SMActual GlobalPackage
smActual Map PackageName PackageLocation
depLocs
([Text]
errs3, Map PackageName Target
targets, Map PackageName PackageLocationImmutable
addedDeps) <- forall env.
HasLogFunc env =>
[ResolveResult]
-> RIO
env
([Text], Map PackageName Target,
Map PackageName PackageLocationImmutable)
combineResolveResults [ResolveResult]
resolveResults
case forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]
errs1, [Text]
errs2, [Text]
errs3] of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
[Text]
errs -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException [Text]
errs
case (forall k a. Map k a -> Bool
Map.null Map PackageName Target
targets, NeedTargets
needTargets) of
(Bool
False, NeedTargets
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Bool
True, NeedTargets
AllowNoTargets) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Bool
True, NeedTargets
NeedTargets)
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets' Bool -> Bool -> Bool
&& BuildConfig -> Bool
bcImplicitGlobal BuildConfig
bconfig -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException
[Text
"The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
textTargets' Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
Map.null Map PackageName ProjectPackage
locals -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException
[Text
"The project contains no local packages (packages not marked with 'extra-dep')"]
| Bool
otherwise -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ [Text] -> BuildException
TargetParseException
[Text
"The specified targets matched no packages"]
Map PackageName DepPackage
addedDeps' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Bool -> PackageLocation -> RIO env DepPackage
additionalDepPackage Bool
haddockDeps forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> PackageLocation
PLImmutable) Map PackageName PackageLocationImmutable
addedDeps
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMTargets
{ smtTargets :: Map PackageName Target
smtTargets = Map PackageName Target
targets
, smtDeps :: Map PackageName DepPackage
smtDeps = Map PackageName DepPackage
addedDeps'
}
where
bcImplicitGlobal :: BuildConfig -> Bool
bcImplicitGlobal BuildConfig
bconfig =
case Config -> ProjectConfig (Project, Path Abs File)
configProject forall a b. (a -> b) -> a -> b
$ BuildConfig -> Config
bcConfig BuildConfig
bconfig of
PCProject (Project, Path Abs File)
_ -> Bool
False
ProjectConfig (Project, Path Abs File)
PCGlobalProject -> Bool
True
PCNoProject [PackageIdentifierRevision]
_ -> Bool
False