module Stack.Build.Target
(
Target (..)
, NeedTargets (..)
, PackageType (..)
, parseTargets
, gpdVersion
, parseRawTarget
, RawTarget (..)
, UnresolvedComponent (..)
) where
import Stack.Prelude
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription)
import Path
import Path.Extra (rejectMissingDir)
import Path.IO
import Stack.Config (getLocalPackages)
import Stack.Fetch (withCabalLoader)
import Stack.PackageIndex
import Stack.PackageLocation
import Stack.Snapshot (calculatePackagePromotion)
import Stack.Types.Config
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import Stack.Types.Build
import Stack.Types.BuildPlan
import Stack.Types.GhcPkgId
data NeedTargets = NeedTargets | AllowNoTargets
newtype RawInput = RawInput { unRawInput :: Text }
getRawInput :: BuildOptsCLI -> Map PackageName LocalPackageView -> ([Text], [RawInput])
getRawInput boptscli locals =
let textTargets' = boptsCLITargets boptscli
textTargets =
if null textTargets'
then map packageNameText (Map.keys locals)
else textTargets'
in (textTargets', map RawInput textTargets)
type ComponentName = Text
data UnresolvedComponent
= ResolvedComponent !NamedComponent
| UnresolvedComponent !ComponentName
deriving (Show, Eq, Ord)
data RawTarget
= RTPackageComponent !PackageName !UnresolvedComponent
| RTComponent !ComponentName
| RTPackage !PackageName
| RTPackageIdentifier !PackageIdentifier
deriving (Show, Eq)
parseRawTargetDirs :: MonadIO m
=> Path Abs Dir
-> Map PackageName LocalPackageView
-> RawInput
-> m (Either Text [(RawInput, RawTarget)])
parseRawTargetDirs root locals ri =
case parseRawTarget t of
Just rt -> return $ Right [(ri, rt)]
Nothing -> do
mdir <- liftIO $ forgivingAbsence (resolveDir root (T.unpack t))
>>= rejectMissingDir
case mdir of
Nothing -> return $ Left $ "Directory not found: " `T.append` t
Just dir ->
case mapMaybe (childOf dir) $ Map.toList locals of
[] -> return $ Left $
"No local directories found as children of " `T.append`
t
names -> return $ Right $ map ((ri, ) . RTPackage) names
where
childOf dir (name, lpv) =
if dir == lpvRoot lpv || isProperPrefixOf dir (lpvRoot lpv)
then Just name
else Nothing
RawInput t = ri
parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget t =
(RTPackageIdentifier <$> parsePackageIdentifier t)
<|> (RTPackage <$> parsePackageNameFromString s)
<|> (RTComponent <$> T.stripPrefix ":" t)
<|> parsePackageComponent
where
s = T.unpack t
parsePackageComponent =
case T.splitOn ":" t of
[pname, "lib"]
| Just pname' <- parsePackageNameFromString (T.unpack pname) ->
Just $ RTPackageComponent pname' $ ResolvedComponent CLib
[pname, cname]
| Just pname' <- parsePackageNameFromString (T.unpack pname) ->
Just $ RTPackageComponent pname' $ UnresolvedComponent cname
[pname, typ, cname]
| Just pname' <- parsePackageNameFromString (T.unpack pname)
, Just wrapper <- parseCompType typ ->
Just $ RTPackageComponent pname' $ ResolvedComponent $ wrapper cname
_ -> Nothing
parseCompType t' =
case t' of
"exe" -> Just CExe
"test" -> Just CTest
"bench" -> Just CBench
_ -> Nothing
data ResolveResult = ResolveResult
{ rrName :: !PackageName
, rrRaw :: !RawInput
, rrComponent :: !(Maybe NamedComponent)
, rrAddedDep :: !(Maybe Version)
, rrPackageType :: !PackageType
}
resolveRawTarget
:: forall env. HasConfig env
=> Map PackageName (LoadedPackageInfo GhcPkgId)
-> Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath))
-> Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath)
-> Map PackageName LocalPackageView
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget globals snap deps locals (ri, rt) =
go rt
where
isCompNamed :: ComponentName -> NamedComponent -> Bool
isCompNamed _ CLib = False
isCompNamed t1 (CExe t2) = t1 == t2
isCompNamed t1 (CTest t2) = t1 == t2
isCompNamed t1 (CBench t2) = t1 == t2
go (RTComponent cname) = return $
let allPairs = concatMap
(\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)
(Map.toList locals)
in case filter (isCompNamed cname . snd) allPairs of
[] -> Left $ cname `T.append` " doesn't seem to be a local target. Run 'stack ide targets' for a list of available targets"
[(name, comp)] -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Just comp
, rrAddedDep = Nothing
, rrPackageType = ProjectPackage
}
matches -> Left $ T.concat
[ "Ambiugous component name "
, cname
, ", matches: "
, T.pack $ show matches
]
go (RTPackageComponent name ucomp) = return $
case Map.lookup name locals of
Nothing -> Left $ T.pack $ "Unknown local package: " ++ packageNameString name
Just lpv ->
case ucomp of
ResolvedComponent comp
| comp `Set.member` lpvComponents lpv -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Just comp
, rrAddedDep = Nothing
, rrPackageType = ProjectPackage
}
| otherwise -> Left $ T.pack $ concat
[ "Component "
, show comp
, " does not exist in package "
, packageNameString name
]
UnresolvedComponent comp ->
case filter (isCompNamed comp) $ Set.toList $ lpvComponents lpv of
[] -> Left $ T.concat
[ "Component "
, comp
, " does not exist in package "
, T.pack $ packageNameString name
]
[x] -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Just x
, rrAddedDep = Nothing
, rrPackageType = ProjectPackage
}
matches -> Left $ T.concat
[ "Ambiguous component name "
, comp
, " for package "
, T.pack $ packageNameString name
, ": "
, T.pack $ show matches
]
go (RTPackage name)
| Map.member name locals = return $ Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Nothing
, rrPackageType = ProjectPackage
}
| Map.member name deps ||
Map.member name snap ||
Map.member name globals = return $ Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Nothing
, rrPackageType = Dependency
}
| otherwise = do
mversion <- getLatestVersion name
return $ case mversion of
Nothing -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Nothing
, rrPackageType = Dependency
}
Just version -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Just version
, rrPackageType = Dependency
}
where
getLatestVersion pn = do
vs <- getPackageVersions pn
return (fmap fst (Set.maxView vs))
go (RTPackageIdentifier ident@(PackageIdentifier name version))
| Map.member name locals = return $ Left $ T.concat
[ packageNameText name
, " target has a specific version number, but it is a local package."
, "\nTo avoid confusion, we will not install the specified version or build the local one."
, "\nTo build the local package, specify the target without an explicit version."
]
| otherwise = return $
case Map.lookup name allLocs of
Just (PLIndex (PackageIdentifierRevision (PackageIdentifier _name versionLoc) _mcfi)) -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep =
if version == versionLoc
then Nothing
else Just version
, rrPackageType = Dependency
}
Just (PLOther loc') -> Left $ T.concat
[ "Package with identifier was targeted on the command line: "
, packageIdentifierText ident
, ", but it was specified from a non-index location: "
, T.pack $ show loc'
, ".\nRecommendation: add the correctly desired version to extra-deps."
]
Nothing -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Just version
, rrPackageType = Dependency
}
where
allLocs :: Map PackageName (PackageLocationIndex FilePath)
allLocs = Map.unions
[ Map.mapWithKey
(\name' lpi -> PLIndex $ PackageIdentifierRevision
(PackageIdentifier name' (lpiVersion lpi))
CFILatest)
globals
, Map.map lpiLocation snap
, Map.map snd deps
]
data Target
= TargetAll !PackageType
| TargetComps !(Set NamedComponent)
data PackageType = ProjectPackage | Dependency
deriving (Eq, Show)
combineResolveResults
:: forall m. MonadLogger m
=> [ResolveResult]
-> m ([Text], Map PackageName Target, Map PackageName (PackageLocationIndex FilePath))
combineResolveResults results = do
addedDeps <- fmap Map.unions $ forM results $ \result ->
case rrAddedDep result of
Nothing -> return Map.empty
Just version -> do
let ident = PackageIdentifier (rrName result) version
return $ Map.singleton (rrName result) $ PLIndex $ PackageIdentifierRevision ident CFILatest
let m0 = Map.unionsWith (++) $ map (\rr -> Map.singleton (rrName rr) [rr]) results
(errs, ms) = partitionEithers $ flip map (Map.toList m0) $ \(name, rrs) ->
let mcomps = map rrComponent rrs in
case rrs of
[] -> assert False $ Left "Somehow got no rrComponent values, that can't happen"
[rr] | isNothing (rrComponent rr) -> Right $ Map.singleton name $ TargetAll $ rrPackageType rr
_
| all isJust mcomps -> Right $ Map.singleton name $ TargetComps $ Set.fromList $ catMaybes mcomps
| otherwise -> Left $ T.concat
[ "The package "
, packageNameText name
, " was specified in multiple, incompatible ways: "
, T.unwords $ map (unRawInput . rrRaw) rrs
]
return (errs, Map.unions ms, addedDeps)
parseTargets
:: HasEnvConfig env
=> NeedTargets
-> BuildOptsCLI
-> RIO env
( LoadedSnapshot
, Map PackageName (LoadedPackageInfo (PackageLocationIndex FilePath))
, Map PackageName Target
)
parseTargets needTargets boptscli = do
logDebug "Parsing the targets"
bconfig <- view buildConfigL
ls0 <- view loadedSnapshotL
workingDir <- getCurrentDir
lp <- getLocalPackages
let locals = lpProject lp
deps = lpDependencies lp
globals = lsGlobals ls0
snap = lsPackages ls0
(textTargets', rawInput) = getRawInput boptscli locals
(errs1, concat -> rawTargets) <- fmap partitionEithers $ forM rawInput $
parseRawTargetDirs workingDir (lpProject lp)
(errs2, resolveResults) <- fmap partitionEithers $ forM rawTargets $
resolveRawTarget globals snap deps locals
(errs3, targets, addedDeps) <- combineResolveResults resolveResults
case concat [errs1, errs2, errs3] of
[] -> return ()
errs -> throwIO $ TargetParseException errs
case (Map.null targets, needTargets) of
(False, _) -> return ()
(True, AllowNoTargets) -> return ()
(True, NeedTargets)
| null textTargets' && bcImplicitGlobal bconfig -> throwIO $ TargetParseException
["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
| null textTargets' && Map.null locals -> throwIO $ TargetParseException
["The project contains no local packages (packages not marked with 'extra-dep')"]
| otherwise -> throwIO $ TargetParseException
["The specified targets matched no packages"]
root <- view projectRootL
let dropMaybeKey (Nothing, _) = Map.empty
dropMaybeKey (Just key, value) = Map.singleton key value
flags = Map.unionWith Map.union
(Map.unions (map dropMaybeKey (Map.toList (boptsCLIFlags boptscli))))
(bcFlags bconfig)
hides = Map.empty
options = configGhcOptionsByName (bcConfig bconfig)
drops = Set.empty
(globals', snapshots, locals') <- withCabalLoader $ \loadFromIndex -> do
addedDeps' <- fmap Map.fromList $ forM (Map.toList addedDeps) $ \(name, loc) -> do
gpd <- parseSingleCabalFileIndex loadFromIndex root loc
return (name, (gpd, loc, Nothing))
let allLocals :: Map PackageName (GenericPackageDescription, PackageLocationIndex FilePath, Maybe LocalPackageView)
allLocals = Map.unions
[
Map.map
(\lpv -> (lpvGPD lpv, PLOther $ lpvLoc lpv, Just lpv))
(lpProject lp)
,
addedDeps'
,
Map.map
(\(gpd, loc) -> (gpd, loc, Nothing))
(lpDependencies lp)
]
calculatePackagePromotion
loadFromIndex root ls0 (Map.elems allLocals)
flags hides options drops
let ls = LoadedSnapshot
{ lsCompilerVersion = lsCompilerVersion ls0
, lsGlobals = globals'
, lsPackages = snapshots
}
localDeps = Map.fromList $ flip mapMaybe (Map.toList locals') $ \(name, lpi) ->
case lpiLocation lpi of
(_, Just (Just _localPackageView)) -> Nothing
(loc, _) -> Just (name, lpi { lpiLocation = loc })
return (ls, localDeps, targets)
gpdVersion :: GenericPackageDescription -> Version
gpdVersion gpd =
version
where
PackageIdentifier _ version = fromCabalPackageIdentifier $ package $ packageDescription gpd