module Stack.Build.Target
(
ComponentName
, UnresolvedComponent (..)
, RawTarget (..)
, LocalPackageView (..)
, SimpleTarget (..)
, NeedTargets (..)
, parseRawTarget
, parseTargets
) where
import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Catch (MonadCatch, throwM)
import Control.Monad.IO.Class
import Data.Either (partitionEithers)
import Data.Foldable
import Data.List.Extra (groupSort)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Path
import Path.Extra (rejectMissingDir)
import Path.IO
import Prelude hiding (concat, concatMap)
import Stack.Types
type ComponentName = Text
newtype RawInput = RawInput { unRawInput :: Text }
data UnresolvedComponent
= ResolvedComponent !NamedComponent
| UnresolvedComponent !ComponentName
deriving (Show, Eq, Ord)
data RawTarget (a :: RawTargetType) where
RTPackageComponent :: !PackageName -> !UnresolvedComponent -> RawTarget a
RTComponent :: !ComponentName -> RawTarget a
RTPackage :: !PackageName -> RawTarget a
RTPackageIdentifier :: !PackageIdentifier -> RawTarget 'HasIdents
deriving instance Show (RawTarget a)
deriving instance Eq (RawTarget a)
deriving instance Ord (RawTarget a)
data RawTargetType = HasIdents | NoIdents
parseRawTarget :: Text -> Maybe (RawTarget 'HasIdents)
parseRawTarget t =
(RTPackageIdentifier <$> parsePackageIdentifierFromString s)
<|> (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 LocalPackageView = LocalPackageView
{ lpvVersion :: !Version
, lpvRoot :: !(Path Abs Dir)
, lpvCabalFP :: !(Path Abs File)
, lpvComponents :: !(Set NamedComponent)
, lpvExtraDep :: !TreatLikeExtraDep
}
parseRawTargetDirs :: (MonadIO m, MonadCatch m)
=> Path Abs Dir
-> Map PackageName LocalPackageView
-> Text
-> m (Either Text [(RawInput, RawTarget 'HasIdents)])
parseRawTargetDirs root locals t =
case parseRawTarget t of
Just rt -> return $ Right [(ri, rt)]
Nothing -> do
mdir <- 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
ri = RawInput t
childOf dir (name, lpv) =
if (dir == lpvRoot lpv || isParentOf dir (lpvRoot lpv)) && not (lpvExtraDep lpv)
then Just name
else Nothing
data SimpleTarget
= STUnknown
| STNonLocal
| STLocalComps !(Set NamedComponent)
| STLocalAll
deriving (Show, Eq, Ord)
resolveIdents :: Map PackageName Version
-> Map PackageName Version
-> Map PackageName LocalPackageView
-> (RawInput, RawTarget 'HasIdents)
-> Either Text ((RawInput, RawTarget 'NoIdents), Map PackageName Version)
resolveIdents _ _ _ (ri, RTPackageComponent x y) = Right ((ri, RTPackageComponent x y), Map.empty)
resolveIdents _ _ _ (ri, RTComponent x) = Right ((ri, RTComponent x), Map.empty)
resolveIdents _ _ _ (ri, RTPackage x) = Right ((ri, RTPackage x), Map.empty)
resolveIdents snap extras locals (ri, RTPackageIdentifier (PackageIdentifier name version)) =
fmap ((ri, RTPackage name), ) newExtras
where
newExtras =
case (Map.lookup name locals, mfound) of
(Just _, _) -> 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."
]
(_, Just foundVersion) | foundVersion == version -> Right Map.empty
_ -> Right $ Map.singleton name version
mfound = asum (map (Map.lookup name) [extras, snap])
resolveRawTarget :: Map PackageName Version
-> Map PackageName Version
-> Map PackageName LocalPackageView
-> (RawInput, RawTarget 'NoIdents)
-> Either Text (PackageName, (RawInput, SimpleTarget))
resolveRawTarget snap extras locals (ri, rt) =
go rt
where
go (RTPackageComponent name ucomp) =
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 (name, (ri, STLocalComps $ Set.singleton comp))
| 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 (name, (ri, STLocalComps $ Set.singleton x))
matches -> Left $ T.concat
[ "Ambiguous component name "
, comp
, " for package "
, T.pack $ packageNameString name
, ": "
, T.pack $ show matches
]
go (RTComponent cname) =
let allPairs = concatMap
(\(name, lpv) -> map (name,) $ Set.toList $ lpvComponents lpv)
(Map.toList locals)
in case filter (isCompNamed cname . snd) allPairs of
[] -> Left $ "Could not find a component named " `T.append` cname
[(name, comp)] ->
Right (name, (ri, STLocalComps $ Set.singleton comp))
matches -> Left $ T.concat
[ "Ambiugous component name "
, cname
, ", matches: "
, T.pack $ show matches
]
go (RTPackage name) =
case Map.lookup name locals of
Just _lpv -> Right (name, (ri, STLocalAll))
Nothing ->
case Map.lookup name extras of
Just _ -> Right (name, (ri, STNonLocal))
Nothing ->
case Map.lookup name snap of
Just _ -> Right (name, (ri, STNonLocal))
Nothing -> Right (name, (ri, STUnknown))
isCompNamed :: Text -> NamedComponent -> Bool
isCompNamed _ CLib = False
isCompNamed t1 (CExe t2) = t1 == t2
isCompNamed t1 (CTest t2) = t1 == t2
isCompNamed t1 (CBench t2) = t1 == t2
simplifyTargets :: [(PackageName, (RawInput, SimpleTarget))]
-> ([Text], Map PackageName SimpleTarget)
simplifyTargets =
foldMap go . collect
where
go :: (PackageName, NonEmpty (RawInput, SimpleTarget))
-> ([Text], Map PackageName SimpleTarget)
go (name, (_, st) :| []) = ([], Map.singleton name st)
go (name, pairs) =
case partitionEithers $ map (getLocalComp . snd) (NonEmpty.toList pairs) of
([], comps) -> ([], Map.singleton name $ STLocalComps $ Set.unions comps)
_ ->
let err = T.pack $ concat
[ "Overlapping targets provided for package "
, packageNameString name
, ": "
, show $ map (unRawInput . fst) (NonEmpty.toList pairs)
]
in ([err], Map.empty)
collect :: Ord a => [(a, b)] -> [(a, NonEmpty b)]
collect = map (second NonEmpty.fromList) . groupSort
getLocalComp (STLocalComps comps) = Right comps
getLocalComp _ = Left ()
data NeedTargets
= NeedTargets
| AllowNoTargets
parseTargets :: (MonadCatch m, MonadIO m)
=> NeedTargets
-> Bool
-> Map PackageName Version
-> Map PackageName Version
-> Map PackageName LocalPackageView
-> Path Abs Dir
-> [Text]
-> m (Map PackageName Version, Map PackageName SimpleTarget)
parseTargets needTargets implicitGlobal snap extras locals currDir textTargets' = do
let nonExtraDeps = Map.keys $ Map.filter (not . lpvExtraDep) locals
textTargets =
if null textTargets'
then map (T.pack . packageNameString) nonExtraDeps
else textTargets'
erawTargets <- mapM (parseRawTargetDirs currDir locals) textTargets
let (errs1, rawTargets) = partitionEithers erawTargets
(errs2, unzip -> (rawTargets', newExtras)) = partitionEithers $
map (resolveIdents snap extras locals) $ concat rawTargets
(errs3, targetTypes) = partitionEithers $
map (resolveRawTarget snap extras locals) rawTargets'
(errs4, targets) = simplifyTargets targetTypes
errs = concat [errs1, errs2, errs3, errs4]
if null errs
then if Map.null targets
then case needTargets of
AllowNoTargets ->
return (Map.empty, Map.empty)
NeedTargets
| null textTargets' && implicitGlobal -> throwM $ TargetParseException
["The specified targets matched no packages.\nPerhaps you need to run 'stack init'?"]
| null textTargets' && null nonExtraDeps -> throwM $ TargetParseException
["The project contains no local packages (packages not marked with 'extra-dep')"]
| otherwise -> throwM $ TargetParseException
["The specified targets matched no packages"]
else return (Map.unions newExtras, targets)
else throwM $ TargetParseException errs