{-# 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 Stack.Prelude
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.Types.Config
import Stack.Types.NamedComponent
import Stack.Types.Build
import Stack.Types.SourceMap
data NeedTargets = NeedTargets | AllowNoTargets
newtype RawInput = RawInput { unRawInput :: Text }
getRawInput :: BuildOptsCLI -> Map PackageName ProjectPackage -> ([Text], [RawInput])
getRawInput boptscli locals =
let textTargets' = boptsCLITargets boptscli
textTargets =
if null textTargets'
then map (T.pack . packageNameString) (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 ProjectPackage
-> 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, pp) =
if dir == ppRoot pp || isProperPrefixOf dir (ppRoot pp)
then Just name
else Nothing
RawInput t = ri
parseRawTarget :: Text -> Maybe RawTarget
parseRawTarget t =
(RTPackageIdentifier <$> parsePackageIdentifier s)
<|> (RTPackage <$> parsePackageName s)
<|> (RTComponent <$> T.stripPrefix ":" t)
<|> parsePackageComponent
where
s = T.unpack t
parsePackageComponent =
case T.splitOn ":" t of
[pname, "lib"]
| Just pname' <- parsePackageName (T.unpack pname) ->
Just $ RTPackageComponent pname' $ ResolvedComponent CLib
[pname, cname]
| Just pname' <- parsePackageName (T.unpack pname) ->
Just $ RTPackageComponent pname' $ UnresolvedComponent cname
[pname, typ, cname]
| Just pname' <- parsePackageName (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 PackageLocationImmutable)
, rrPackageType :: !PackageType
}
resolveRawTarget ::
(HasLogFunc env, HasPantryConfig env, HasProcessContext env)
=> SMActual GlobalPackage
-> Map PackageName PackageLocation
-> (RawInput, RawTarget)
-> RIO env (Either Text ResolveResult)
resolveRawTarget sma allLocs (ri, rt) =
go rt
where
locals = smaProject sma
deps = smaDeps sma
globals = smaGlobal sma
isCompNamed :: ComponentName -> NamedComponent -> Bool
isCompNamed _ CLib = False
isCompNamed t1 (CInternalLib t2) = t1 == t2
isCompNamed t1 (CExe t2) = t1 == t2
isCompNamed t1 (CTest t2) = t1 == t2
isCompNamed t1 (CBench t2) = t1 == t2
go (RTComponent cname) = do
allPairs <- fmap concat $ flip Map.traverseWithKey locals
$ \name pp -> do
comps <- ppComponents pp
pure $ map (name, ) $ Set.toList comps
pure $ 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 = PTProject
}
matches -> Left $ T.concat
[ "Ambiugous component name "
, cname
, ", matches: "
, T.pack $ show matches
]
go (RTPackageComponent name ucomp) =
case Map.lookup name locals of
Nothing -> pure $ Left $ T.pack $ "Unknown local package: " ++ packageNameString name
Just pp -> do
comps <- ppComponents pp
pure $ case ucomp of
ResolvedComponent comp
| comp `Set.member` comps -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Just comp
, rrAddedDep = Nothing
, rrPackageType = PTProject
}
| otherwise -> Left $ T.pack $ concat
[ "Component "
, show comp
, " does not exist in package "
, packageNameString name
]
UnresolvedComponent comp ->
case filter (isCompNamed comp) $ Set.toList comps 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 = PTProject
}
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 = PTProject
}
| Map.member name deps =
pure $ deferToConstructPlan name
| Just gp <- Map.lookup name globals =
case gp of
GlobalPackage _ -> pure $ deferToConstructPlan name
ReplacedGlobalPackage _ -> hackageLatest name
| otherwise = hackageLatest name
go (RTPackageIdentifier ident@(PackageIdentifier name version))
| Map.member name locals = return $ Left $ T.concat
[ tshow (packageNameString 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 =
case Map.lookup name allLocs of
Just (PLImmutable (PLIHackage (PackageIdentifier _name versionLoc) _cfKey _treeKey)) ->
if version == versionLoc
then pure $ deferToConstructPlan name
else hackageLatestRevision name version
Just loc' -> pure $ Left $ T.concat
[ "Package with identifier was targeted on the command line: "
, T.pack $ packageIdentifierString ident
, ", but it was specified from a non-index location: "
, T.pack $ show loc'
, ".\nRecommendation: add the correctly desired version to extra-deps."
]
Nothing -> do
mrev <- getLatestHackageRevision YesRequireHackageIndex name version
pure $ case mrev of
Nothing -> deferToConstructPlan name
Just (_rev, cfKey, treeKey) -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey
, rrPackageType = PTDependency
}
hackageLatest name = do
mloc <- getLatestHackageLocation YesRequireHackageIndex name UsePreferredVersions
pure $ case mloc of
Nothing -> deferToConstructPlan name
Just loc -> do
Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Just loc
, rrPackageType = PTDependency
}
hackageLatestRevision name version = do
mrev <- getLatestHackageRevision YesRequireHackageIndex name version
pure $ case mrev of
Nothing -> deferToConstructPlan name
Just (_rev, cfKey, treeKey) -> Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Just $ PLIHackage (PackageIdentifier name version) cfKey treeKey
, rrPackageType = PTDependency
}
deferToConstructPlan name = Right ResolveResult
{ rrName = name
, rrRaw = ri
, rrComponent = Nothing
, rrAddedDep = Nothing
, rrPackageType = PTDependency
}
combineResolveResults
:: forall env. HasLogFunc env
=> [ResolveResult]
-> RIO env ([Text], Map PackageName Target, Map PackageName PackageLocationImmutable)
combineResolveResults results = do
addedDeps <- fmap Map.unions $ forM results $ \result ->
case rrAddedDep result of
Nothing -> return Map.empty
Just pl -> do
return $ Map.singleton (rrName result) pl
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 "
, T.pack $ packageNameString name
, " was specified in multiple, incompatible ways: "
, T.unwords $ map (unRawInput . rrRaw) rrs
]
return (errs, Map.unions ms, addedDeps)
parseTargets :: HasBuildConfig env
=> NeedTargets
-> Bool
-> BuildOptsCLI
-> SMActual GlobalPackage
-> RIO env SMTargets
parseTargets needTargets haddockDeps boptscli smActual = do
logDebug "Parsing the targets"
bconfig <- view buildConfigL
workingDir <- getCurrentDir
locals <- view $ buildConfigL.to (smwProject . bcSMWanted)
let (textTargets', rawInput) = getRawInput boptscli locals
(errs1, concat -> rawTargets) <- fmap partitionEithers $ forM rawInput $
parseRawTargetDirs workingDir locals
let depLocs = Map.map dpLocation $ smaDeps smActual
(errs2, resolveResults) <- fmap partitionEithers $ forM rawTargets $
resolveRawTarget smActual depLocs
(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"]
addedDeps' <- mapM (additionalDepPackage haddockDeps . PLImmutable) addedDeps
return SMTargets
{ smtTargets = targets
, smtDeps = addedDeps'
}
where
bcImplicitGlobal bconfig =
case configProject $ bcConfig bconfig of
PCProject _ -> False
PCGlobalProject -> True
PCNoProject _ -> False