From a51f565b01018ebce6d7dcdfaa1aaa286d5afd1d Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sun, 3 Sep 2017 17:51:41 +0100 Subject: [PATCH 01/18] Refactor the Match monad somewhat Instead of two constructors MatchExact and MatchInexact we now have one Match constructor with a field of data MatchClass = Inexact | Exact. This factoring helps simplify several other functions where we treat them uniformly or according to the Ord instance. The real ulterior motive however is that we'd like to introduce a third Match class value between Inexact and Exact. This refactoring is a prerequisite to that, to avoid a combinatorial explosion of cases. --- .../Distribution/Client/TargetSelector.hs | 124 +++++++++--------- 1 file changed, 63 insertions(+), 61 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 14117c845c2..3f39c4edece 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -580,7 +580,7 @@ data QualLevel = QL1 | QL2 | QL3 | QLFull disambiguateTargetSelectors :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo)) - -> TargetStringFileStatus -> Bool + -> TargetStringFileStatus -> MatchClass -> [TargetSelector PackageInfo] -> Either [(TargetSelector PackageInfo, [(TargetString, [TargetSelector PackageInfo])])] @@ -613,8 +613,9 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = (Match (TargetSelector PackageInfo)) memoisedMatches = -- avoid recomputing the main one if it was an exact match - (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) - else id) + (if exactMatch == Exact + then Map.insert matchInput (Match Exact 0 matchResults) + else id) $ Map.Lazy.fromList [ (rendering, matcher rendering) | rendering <- concatMap snd matchResultsRenderings ] @@ -637,7 +638,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = Left ( originalMatch , [ (forgetFileStatus rendering, matches) | rendering <- matchRenderings - , let (ExactMatch _ matches) = + , let (Match Exact _ matches) = memoisedMatches Map.! rendering ] ) @@ -649,11 +650,11 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = findUnambiguous _ [] = Nothing findUnambiguous t (r:rs) = case memoisedMatches Map.! r of - ExactMatch _ [t'] | fmap packageName t == fmap packageName t' - -> Just r - ExactMatch _ _ -> findUnambiguous t rs - InexactMatch _ _ -> internalError "InexactMatch" - NoMatch _ _ -> internalError "NoMatch" + Match Exact _ [t'] | fmap packageName t == fmap packageName t' + -> Just r + Match Exact _ _ -> findUnambiguous t rs + Match Inexact _ _ -> internalError "Match Inexact" + NoMatch _ _ -> internalError "NoMatch" internalError :: String -> a internalError msg = @@ -1988,11 +1989,20 @@ matchDirectoryPrefix dirs filepath = -- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we -- can run a matcher against an input using 'findMatch'. -- -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] +data Match a = NoMatch !Confidence [MatchError] + | Match !MatchClass !Confidence [a] deriving Show +-- | The kind of match, inexact or exact. We keep track of this so we can +-- prefer exact over inexact matches. The 'Ord' here is important: we try +-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. +-- +data MatchClass = Inexact -- ^ Matches a known thing inexactly + -- e.g. matches a known package case insensitively + | Exact -- ^ Exactly matches a known thing, + -- e.g. matches a known package case sensitively + deriving (Show, Eq, Ord) + type Confidence = Int data MatchError = MatchErrorExpected String String -- thing got @@ -2002,12 +2012,11 @@ data MatchError = MatchErrorExpected String String -- thing got instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (Match m d xs) = Match m d (fmap f xs) instance Applicative Match where - pure a = ExactMatch 0 [a] + pure a = Match Exact 0 [a] (<*>) = ap instance Alternative Match where @@ -2015,12 +2024,19 @@ instance Alternative Match where (<|>) = matchPlus instance Monad Match where - return = pure - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ msum (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ msum (map f xs) + return = pure + NoMatch d ms >>= _ = NoMatch d ms + Match m d xs >>= f = + -- To understand this, it needs to be read in context with the + -- implementation of 'matchPlus' below + case msum (map f xs) of + Match m' d' xs' -> Match (min m m') (d + d') xs' + -- The minimum match class is the one we keep. The match depth is + -- tracked but not used in the Match case. + + NoMatch d' ms -> NoMatch (d + d') ms + -- Here is where we transfer the depth we were keeping track of in + -- the Match case over to the NoMatch case where it finally gets used. instance MonadPlus Match where mzero = empty @@ -2031,15 +2047,6 @@ instance MonadPlus Match where infixl 3 -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - -- | Combine two matchers. Exact matches are used over inexact matches -- but if we have multiple exact, or inexact then the we collect all the -- ambiguous matches. @@ -2047,20 +2054,16 @@ forceInexact m = m -- This operator is associative, has unit 'mzero' and is also commutative. -- matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') +matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a +matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b +matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) + | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. + | d_a < d_b = b + | otherwise = NoMatch d_a (ms_a ++ ms_b) +matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) + | m_a > m_b = a -- exact over inexact + | m_a < m_b = b -- exact over inexact + | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) -- | Combine two matchers. This is similar to 'matchPlus' with the -- difference that an exact match from the left matcher shadows any exact @@ -2069,7 +2072,7 @@ matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') -- This operator is associative, has unit 'mzero' and is not commutative. -- matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) _ = a +matchPlusShadowing a@(Match Exact _ _) _ = a matchPlusShadowing a b = matchPlus a b @@ -2097,25 +2100,24 @@ orNoThingIn kind name (NoMatch n ms) = orNoThingIn _ _ m = m increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] +increaseConfidence = Match Exact 1 [()] increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a -nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs -nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) -nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) +nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs +nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) -- | Lift a list of matches to an exact match. -- exactMatches, inexactMatches :: [a] -> Match a exactMatches [] = mzero -exactMatches xs = ExactMatch 0 xs +exactMatches xs = Match Exact 0 xs inexactMatches [] = mzero -inexactMatches xs = InexactMatch 0 xs +inexactMatches xs = Match Inexact 0 xs tryEach :: [a] -> Match a tryEach = exactMatches @@ -2131,15 +2133,15 @@ tryEach = exactMatches -- findMatch :: Match a -> MaybeAmbiguous a findMatch match = case match of - NoMatch _ msgs -> None msgs - ExactMatch _ [x] -> Unambiguous x - InexactMatch _ [x] -> Unambiguous x - ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" - InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" - ExactMatch _ xs -> Ambiguous True xs - InexactMatch _ xs -> Ambiguous False xs - -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] + NoMatch _ msgs -> None msgs + Match _ _ [x] -> Unambiguous x + Match m d [] -> error $ "findMatch: impossible: " ++ show match' + where match' = Match m d [] :: Match () + Match m _ xs -> Ambiguous m xs + +data MaybeAmbiguous a = None [MatchError] + | Unambiguous a + | Ambiguous MatchClass [a] deriving Show From 271d3ab918e4cc98f309ea59689b55d2b05a129d Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Fri, 8 Sep 2017 00:28:51 +0100 Subject: [PATCH 02/18] Refactor: add KnownTargets type to target selection code Bundle up what we had been passing as separate args into a single KnownTargets type, and separate out some utils for constructing it. --- .../Distribution/Client/TargetSelector.hs | 119 +++++++++++------- 1 file changed, 74 insertions(+), 45 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 3f39c4edece..5970f9caca1 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -215,27 +215,14 @@ readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m [TargetSelector PackageId]) readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs = case parseTargetStrings targetStrs of - ([], utargets) -> do - utargets' <- mapM (getTargetStringFileStatus dirActions) utargets - pkgs' <- sequence [ selectPackageInfo dirActions pkg - | SpecificSourcePackage pkg <- pkgs ] - cwd <- getCurrentDirectory - let (cwdPkg, otherPkgs) = selectCwdPackage cwd pkgs' - case resolveTargetSelectors cwdPkg otherPkgs utargets' of + ([], usertargets) -> do + usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets + knowntargets <- getKnownTargets dirActions pkgs + case resolveTargetSelectors knowntargets usertargets' of ([], btargets) -> return (Right (map (fmap packageId) btargets)) (problems, _) -> return (Left problems) (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) - where - selectCwdPackage :: FilePath - -> [PackageInfo] - -> ([PackageInfo], [PackageInfo]) - selectCwdPackage cwd pkgs' = - let (cwdpkg, others) = partition isPkgDirCwd pkgs' - in (cwdpkg, others) - where - isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) } - | dir == cwd = True - isPkgDirCwd _ = False + data DirActions m = DirActions { doesFileExist :: FilePath -> m Bool, @@ -446,43 +433,42 @@ forgetFileStatus t = case t of -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. -- -resolveTargetSelectors :: [PackageInfo] -- any pkg in the cur dir - -> [PackageInfo] -- all the other local packages +resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] -> ([TargetSelectorProblem], [TargetSelector PackageInfo]) -- default local dir target if there's no given target: -resolveTargetSelectors [] [] [] = +resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = ([TargetSelectorNoTargetsInProject], []) -resolveTargetSelectors [] _opinfo [] = +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] = ([TargetSelectorNoTargetsInCwd], []) -resolveTargetSelectors ppinfo _opinfo [] = - ([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing]) +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = (pkg:_)}) [] = + ([], [TargetPackage TargetImplicitCwd pkg Nothing]) --TODO: in future allow multiple packages in the same dir -resolveTargetSelectors ppinfo opinfo targetStrs = +resolveTargetSelectors knowntargets targetStrs = partitionEithers - . map (resolveTargetSelector ppinfo opinfo) + . map (resolveTargetSelector knowntargets) $ targetStrs -resolveTargetSelector :: [PackageInfo] -> [PackageInfo] +resolveTargetSelector :: KnownTargets -> TargetStringFileStatus -> Either TargetSelectorProblem (TargetSelector PackageInfo) -resolveTargetSelector ppinfo opinfo targetStrStatus = +resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = case findMatch (matcher targetStrStatus) of Unambiguous _ | projectIsEmpty -> Left TargetSelectorNoTargetsInProject Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter) - | null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr) - | otherwise -> Right (TargetPackage TargetImplicitCwd - (head ppinfo) mkfilter) + | (pkg:_) <- knownPackagesPrimary --TODO: in future allow multiple packages in the same dir + -> Right (TargetPackage TargetImplicitCwd pkg mkfilter) + | otherwise -> Left (TargetSelectorNoCurrentPackage targetStr) Unambiguous target -> Right target @@ -503,11 +489,11 @@ resolveTargetSelector ppinfo opinfo targetStrStatus = (map (fmap (map (fmap packageId))) ms)) Left [] -> internalError "resolveTargetSelector" where - matcher = matchTargetSelector ppinfo opinfo + matcher = matchTargetSelector knowntargets targetStr = forgetFileStatus targetStrStatus - projectIsEmpty = null ppinfo && null opinfo + projectIsEmpty = null knownPackagesAll classifyMatchErrors errs | not (null expected) @@ -819,21 +805,22 @@ renderTargetSelector ql ts = (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts)) syntax where - syntax = syntaxForms [] [] -- don't need pinfo for rendering + syntax = syntaxForms emptyKnownTargets + -- don't need known targets for rendering -matchTargetSelector :: [PackageInfo] -> [PackageInfo] +matchTargetSelector :: KnownTargets -> TargetStringFileStatus -> Match (TargetSelector PackageInfo) -matchTargetSelector ppinfo opinfo = \utarget -> +matchTargetSelector knowntargets = \usertarget -> nubMatchesBy ((==) `on` (fmap packageName)) $ - let ql = targetQualLevel utarget in + let ql = targetQualLevel usertarget in foldSyntax (<|>) () - (\ql' match _ -> guard (ql == ql') >> match utarget) + (\ql' match _ -> guard (ql == ql') >> match usertarget) syntax where - syntax = syntaxForms ppinfo opinfo + syntax = syntaxForms knowntargets targetQualLevel TargetStringFileStatus1{} = QL1 targetQualLevel TargetStringFileStatus2{} = QL2 @@ -849,8 +836,13 @@ matchTargetSelector ppinfo opinfo = \utarget -> -- | All the forms of syntax for 'TargetSelector'. -- -syntaxForms :: [PackageInfo] -> [PackageInfo] -> Syntax -syntaxForms ppinfo opinfo = +syntaxForms :: KnownTargets -> Syntax +syntaxForms KnownTargets { + knownPackagesAll = pinfo, + knownComponentsAll = cinfo, + knownComponentsPrimary = pcinfo, + knownComponentsOther = ocinfo + } = -- The various forms of syntax here are ambiguous in many cases. -- Our policy is by default we expose that ambiguity and report -- ambiguous matches. In certain cases we override the ambiguity @@ -922,10 +914,6 @@ syntaxForms ppinfo opinfo = where ambiguousAlternatives = foldr1 AmbiguousAlternatives shadowingAlternatives = foldr1 ShadowingAlternatives - pinfo = ppinfo ++ opinfo - cinfo = concatMap pinfoComponents pinfo - pcinfo = concatMap pinfoComponents ppinfo - ocinfo = concatMap pinfoComponents opinfo -- | Syntax: "all" to select all packages in the project @@ -1560,6 +1548,15 @@ dispM = display -- Package and component info -- +data KnownTargets = KnownTargets { + knownPackagesAll :: [PackageInfo], + knownPackagesPrimary :: [PackageInfo], + knownPackagesOther :: [PackageInfo], + knownComponentsAll :: [ComponentInfo], + knownComponentsPrimary :: [ComponentInfo], + knownComponentsOther :: [ComponentInfo] + } + data PackageInfo = PackageInfo { pinfoId :: PackageId, pinfoDirectory :: Maybe (FilePath, FilePath), @@ -1585,6 +1582,38 @@ type ComponentStringName = String instance Package PackageInfo where packageId = pinfoId + +emptyKnownTargets :: KnownTargets +emptyKnownTargets = KnownTargets [] [] [] [] [] [] + +getKnownTargets :: (Applicative m, Monad m) + => DirActions m + -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> m KnownTargets +getKnownTargets dirActions@DirActions{..} pkgs = do + pinfo <- sequence [ selectPackageInfo dirActions pkg + | SpecificSourcePackage pkg <- pkgs ] + cwd <- getCurrentDirectory + let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo + return KnownTargets { + knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, + knownPackagesOther = opinfo, + knownComponentsAll = concatMap pinfoComponents pinfo, + knownComponentsPrimary = concatMap pinfoComponents ppinfo, + knownComponentsOther = concatMap pinfoComponents opinfo + } + where + selectPrimaryPackage :: FilePath + -> [PackageInfo] + -> ([PackageInfo], [PackageInfo]) + selectPrimaryPackage cwd = partition isPkgDirCwd + where + isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) } + | dir == cwd = True + isPkgDirCwd _ = False + + selectPackageInfo :: (Applicative m, Monad m) => DirActions m -> SourcePackage (PackageLocation a) -> m PackageInfo selectPackageInfo dirActions@DirActions{..} From 9724c46c424e9a6a12d62cbe66f549ec3e8cd6b5 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Fri, 8 Sep 2017 00:47:14 +0100 Subject: [PATCH 03/18] Rename PackageInfo and ComponentInfo To KnownPackage and KnownComponent. This is in preparation for extending KnownPackage by adding more constructors for known package names. --- .../Distribution/Client/TargetSelector.hs | 201 +++++++++--------- 1 file changed, 101 insertions(+), 100 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 5970f9caca1..c4efb653c3c 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -436,7 +436,7 @@ forgetFileStatus t = case t of resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] -> ([TargetSelectorProblem], - [TargetSelector PackageInfo]) + [TargetSelector KnownPackage]) -- default local dir target if there's no given target: resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = @@ -457,7 +457,7 @@ resolveTargetSelectors knowntargets targetStrs = resolveTargetSelector :: KnownTargets -> TargetStringFileStatus -> Either TargetSelectorProblem - (TargetSelector PackageInfo) + (TargetSelector KnownPackage) resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = case findMatch (matcher targetStrStatus) of @@ -565,12 +565,12 @@ data QualLevel = QL1 | QL2 | QL3 | QLFull deriving (Eq, Enum, Show) disambiguateTargetSelectors - :: (TargetStringFileStatus -> Match (TargetSelector PackageInfo)) + :: (TargetStringFileStatus -> Match (TargetSelector KnownPackage)) -> TargetStringFileStatus -> MatchClass - -> [TargetSelector PackageInfo] - -> Either [(TargetSelector PackageInfo, - [(TargetString, [TargetSelector PackageInfo])])] - [(TargetString, TargetSelector PackageInfo)] + -> [TargetSelector KnownPackage] + -> Either [(TargetSelector KnownPackage, + [(TargetString, [TargetSelector KnownPackage])])] + [(TargetString, TargetSelector KnownPackage)] disambiguateTargetSelectors matcher matchInput exactMatch matchResults = case partitionEithers results of (errs@(_:_), _) -> Left errs @@ -579,7 +579,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = -- So, here's the strategy. We take the original match results, and make a -- table of all their renderings at all qualification levels. -- Note there can be multiple renderings at each qualification level. - matchResultsRenderings :: [(TargetSelector PackageInfo, + matchResultsRenderings :: [(TargetSelector KnownPackage, [TargetStringFileStatus])] matchResultsRenderings = [ (matchResult, matchRenderings) @@ -596,7 +596,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = -- if we've got an unambiguous match. memoisedMatches :: Map TargetStringFileStatus - (Match (TargetSelector PackageInfo)) + (Match (TargetSelector KnownPackage)) memoisedMatches = -- avoid recomputing the main one if it was an exact match (if exactMatch == Exact @@ -610,9 +610,9 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = -- possible renderings (in order of qualification level, though remember -- there can be multiple renderings per level), and find the first one -- that has an unambiguous match. - results :: [Either (TargetSelector PackageInfo, - [(TargetString, [TargetSelector PackageInfo])]) - (TargetString, TargetSelector PackageInfo)] + results :: [Either (TargetSelector KnownPackage, + [(TargetString, [TargetSelector KnownPackage])]) + (TargetString, TargetSelector KnownPackage)] results = [ case findUnambiguous originalMatch matchRenderings of Just unambiguousRendering -> @@ -630,7 +630,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = | (originalMatch, matchRenderings) <- matchResultsRenderings ] - findUnambiguous :: TargetSelector PackageInfo + findUnambiguous :: TargetSelector KnownPackage -> [TargetStringFileStatus] -> Maybe TargetStringFileStatus findUnambiguous _ [] = Nothing @@ -780,7 +780,7 @@ data Syntax = Syntax QualLevel Matcher Renderer | AmbiguousAlternatives Syntax Syntax | ShadowingAlternatives Syntax Syntax -type Matcher = TargetStringFileStatus -> Match (TargetSelector PackageInfo) +type Matcher = TargetStringFileStatus -> Match (TargetSelector KnownPackage) type Renderer = TargetSelector PackageId -> [TargetStringFileStatus] foldSyntax :: (a -> a -> a) -> (a -> a -> a) @@ -810,7 +810,7 @@ renderTargetSelector ql ts = matchTargetSelector :: KnownTargets -> TargetStringFileStatus - -> Match (TargetSelector PackageInfo) + -> Match (TargetSelector KnownPackage) matchTargetSelector knowntargets = \usertarget -> nubMatchesBy ((==) `on` (fmap packageName)) $ @@ -938,32 +938,32 @@ syntaxForm1Filter :: Syntax syntaxForm1Filter = syntaxForm1 render $ \str1 _fstatus1 -> do kfilter <- matchComponentKindFilter str1 - return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + return (TargetPackage TargetImplicitCwd dummyKnownPackage (Just kfilter)) where render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus1 (dispF kfilter) noFileStatus] render _ = [] -- Only used for TargetPackage TargetImplicitCwd -dummyPackageInfo :: PackageInfo -dummyPackageInfo = - PackageInfo { +dummyKnownPackage :: KnownPackage +dummyKnownPackage = + KnownPackage { pinfoId = PackageIdentifier - (mkPackageName "dummyPackageInfo") + (mkPackageName "dummyKnownPackage") (mkVersion []), pinfoDirectory = unused, pinfoPackageFile = unused, pinfoComponents = unused } where - unused = error "dummyPackageInfo" + unused = error "dummyKnownPackage" -- | Syntax: package (name, dir or file) -- -- > cabal build foo -- > cabal build ../bar ../bar/bar.cabal -- -syntaxForm1Package :: [PackageInfo] -> Syntax +syntaxForm1Package :: [KnownPackage] -> Syntax syntaxForm1Package pinfo = syntaxForm1 render $ \str1 fstatus1 -> do guardPackage str1 fstatus1 @@ -978,7 +978,7 @@ syntaxForm1Package pinfo = -- -- > cabal build foo -- -syntaxForm1Component :: [ComponentInfo] -> Syntax +syntaxForm1Component :: [KnownComponent] -> Syntax syntaxForm1Component cs = syntaxForm1 render $ \str1 _fstatus1 -> do guardComponentName str1 @@ -993,7 +993,7 @@ syntaxForm1Component cs = -- -- > cabal build Data.Foo -- -syntaxForm1Module :: [ComponentInfo] -> Syntax +syntaxForm1Module :: [KnownComponent] -> Syntax syntaxForm1Module cs = syntaxForm1 render $ \str1 _fstatus1 -> do guardModuleName str1 @@ -1009,7 +1009,7 @@ syntaxForm1Module cs = -- -- > cabal build Data/Foo.hs bar/Main.hsc -- -syntaxForm1File :: [PackageInfo] -> Syntax +syntaxForm1File :: [KnownPackage] -> Syntax syntaxForm1File ps = -- Note there's a bit of an inconsistency here vs the other syntax forms -- for files. For the single-part syntax the target has to point to a file @@ -1062,7 +1062,7 @@ syntaxForm2AllFilter = -- -- > cabal build foo:tests -- -syntaxForm2PackageFilter :: [PackageInfo] -> Syntax +syntaxForm2PackageFilter :: [KnownPackage] -> Syntax syntaxForm2PackageFilter ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 @@ -1078,7 +1078,7 @@ syntaxForm2PackageFilter ps = -- -- > cabal build pkg:foo -- -syntaxForm2NamespacePackage :: [PackageInfo] -> Syntax +syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax syntaxForm2NamespacePackage pinfo = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardNamespacePackage str1 @@ -1096,7 +1096,7 @@ syntaxForm2NamespacePackage pinfo = -- > cabal build ./foo:foo -- > cabal build ./foo.cabal:foo -- -syntaxForm2PackageComponent :: [PackageInfo] -> Syntax +syntaxForm2PackageComponent :: [KnownPackage] -> Syntax syntaxForm2PackageComponent ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 @@ -1116,7 +1116,7 @@ syntaxForm2PackageComponent ps = -- -- > cabal build lib:foo exe:foo -- -syntaxForm2KindComponent :: [ComponentInfo] -> Syntax +syntaxForm2KindComponent :: [KnownComponent] -> Syntax syntaxForm2KindComponent cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do ckind <- matchComponentKind str1 @@ -1134,7 +1134,7 @@ syntaxForm2KindComponent cs = -- > cabal build ./foo:Data.Foo -- > cabal build ./foo.cabal:Data.Foo -- -syntaxForm2PackageModule :: [PackageInfo] -> Syntax +syntaxForm2PackageModule :: [KnownPackage] -> Syntax syntaxForm2PackageModule ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 @@ -1153,7 +1153,7 @@ syntaxForm2PackageModule ps = -- -- > cabal build foo:Data.Foo -- -syntaxForm2ComponentModule :: [ComponentInfo] -> Syntax +syntaxForm2ComponentModule :: [KnownComponent] -> Syntax syntaxForm2ComponentModule cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardComponentName str1 @@ -1175,7 +1175,7 @@ syntaxForm2ComponentModule cs = -- > cabal build ./foo:Data/Foo.hs -- > cabal build ./foo.cabal:Data/Foo.hs -- -syntaxForm2PackageFile :: [PackageInfo] -> Syntax +syntaxForm2PackageFile :: [KnownPackage] -> Syntax syntaxForm2PackageFile ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 @@ -1192,7 +1192,7 @@ syntaxForm2PackageFile ps = -- -- > cabal build foo:Data/Foo.hs -- -syntaxForm2ComponentFile :: [ComponentInfo] -> Syntax +syntaxForm2ComponentFile :: [KnownComponent] -> Syntax syntaxForm2ComponentFile cs = syntaxForm2 render $ \str1 _fstatus1 str2 -> do guardComponentName str1 @@ -1230,7 +1230,7 @@ syntaxForm3MetaCwdFilter = guardNamespaceMeta str1 guardNamespaceCwd str2 kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter)) + return (TargetPackage TargetImplicitCwd dummyKnownPackage (Just kfilter)) where render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] @@ -1240,7 +1240,7 @@ syntaxForm3MetaCwdFilter = -- -- > cabal build :pkg:foo -- -syntaxForm3MetaNamespacePackage :: [PackageInfo] -> Syntax +syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax syntaxForm3MetaNamespacePackage pinfo = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespaceMeta str1 @@ -1259,7 +1259,7 @@ syntaxForm3MetaNamespacePackage pinfo = -- > cabal build foo/:lib:foo -- > cabal build foo.cabal:lib:foo -- -syntaxForm3PackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax syntaxForm3PackageKindComponent ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 @@ -1280,7 +1280,7 @@ syntaxForm3PackageKindComponent ps = -- > cabal build foo/:foo:Data.Foo -- > cabal build foo.cabal:foo:Data.Foo -- -syntaxForm3PackageComponentModule :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax syntaxForm3PackageComponentModule ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 @@ -1302,7 +1302,7 @@ syntaxForm3PackageComponentModule ps = -- -- > cabal build lib:foo:Data.Foo -- -syntaxForm3KindComponentModule :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax syntaxForm3KindComponentModule cs = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do ckind <- matchComponentKind str1 @@ -1325,7 +1325,7 @@ syntaxForm3KindComponentModule cs = -- > cabal build foo/:foo:Data/Foo.hs -- > cabal build foo.cabal:foo:Data/Foo.hs -- -syntaxForm3PackageComponentFile :: [PackageInfo] -> Syntax +syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax syntaxForm3PackageComponentFile ps = syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 @@ -1345,7 +1345,7 @@ syntaxForm3PackageComponentFile ps = -- -- > cabal build lib:foo:Data/Foo.hs -- -syntaxForm3KindComponentFile :: [ComponentInfo] -> Syntax +syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax syntaxForm3KindComponentFile cs = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do ckind <- matchComponentKind str1 @@ -1360,7 +1360,7 @@ syntaxForm3KindComponentFile cs = [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f] render _ = [] -syntaxForm3NamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm3NamespacePackageFilter ps = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespacePackage str1 @@ -1375,7 +1375,7 @@ syntaxForm3NamespacePackageFilter ps = -- -syntaxForm4MetaNamespacePackageFilter :: [PackageInfo] -> Syntax +syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax syntaxForm4MetaNamespacePackageFilter ps = syntaxForm4 render $ \str1 str2 str3 str4 -> do guardNamespaceMeta str1 @@ -1393,7 +1393,7 @@ syntaxForm4MetaNamespacePackageFilter ps = -- -- > cabal build :pkg:foo:lib:foo -- -syntaxForm5MetaNamespacePackageKindComponent :: [PackageInfo] -> Syntax +syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax syntaxForm5MetaNamespacePackageKindComponent ps = syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do guardNamespaceMeta str1 @@ -1415,7 +1415,7 @@ syntaxForm5MetaNamespacePackageKindComponent ps = -- > cabal build :pkg:foo:lib:foo:module:Data.Foo -- syntaxForm7MetaNamespacePackageKindComponentNamespaceModule - :: [PackageInfo] -> Syntax + :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do guardNamespaceMeta str1 @@ -1443,7 +1443,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = -- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs -- syntaxForm7MetaNamespacePackageKindComponentNamespaceFile - :: [PackageInfo] -> Syntax + :: [KnownPackage] -> Syntax syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do guardNamespaceMeta str1 @@ -1470,17 +1470,17 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = -- Syntax utils -- -type Match1 = String -> FileStatus -> Match (TargetSelector PackageInfo) +type Match1 = String -> FileStatus -> Match (TargetSelector KnownPackage) type Match2 = String -> FileStatus -> String - -> Match (TargetSelector PackageInfo) + -> Match (TargetSelector KnownPackage) type Match3 = String -> FileStatus -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match (TargetSelector KnownPackage) type Match4 = String -> String -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match (TargetSelector KnownPackage) type Match5 = String -> String -> String -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match (TargetSelector KnownPackage) type Match7 = String -> String -> String -> String -> String -> String -> String - -> Match (TargetSelector PackageInfo) + -> Match (TargetSelector KnownPackage) syntaxForm1 :: Renderer -> Match1 -> Syntax syntaxForm2 :: Renderer -> Match2 -> Syntax @@ -1549,26 +1549,26 @@ dispM = display -- data KnownTargets = KnownTargets { - knownPackagesAll :: [PackageInfo], - knownPackagesPrimary :: [PackageInfo], - knownPackagesOther :: [PackageInfo], - knownComponentsAll :: [ComponentInfo], - knownComponentsPrimary :: [ComponentInfo], - knownComponentsOther :: [ComponentInfo] + knownPackagesAll :: [KnownPackage], + knownPackagesPrimary :: [KnownPackage], + knownPackagesOther :: [KnownPackage], + knownComponentsAll :: [KnownComponent], + knownComponentsPrimary :: [KnownComponent], + knownComponentsOther :: [KnownComponent] } -data PackageInfo = PackageInfo { +data KnownPackage = KnownPackage { pinfoId :: PackageId, pinfoDirectory :: Maybe (FilePath, FilePath), pinfoPackageFile :: Maybe (FilePath, FilePath), - pinfoComponents :: [ComponentInfo] + pinfoComponents :: [KnownComponent] } -- not instance of Show due to recursive construction -data ComponentInfo = ComponentInfo { +data KnownComponent = KnownComponent { cinfoName :: ComponentName, cinfoStrName :: ComponentStringName, - cinfoPackage :: PackageInfo, + cinfoPackage :: KnownPackage, cinfoSrcDirs :: [FilePath], cinfoModules :: [ModuleName], cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) @@ -1579,7 +1579,7 @@ data ComponentInfo = ComponentInfo { type ComponentStringName = String -instance Package PackageInfo where +instance Package KnownPackage where packageId = pinfoId @@ -1591,7 +1591,7 @@ getKnownTargets :: (Applicative m, Monad m) -> [PackageSpecifier (SourcePackage (PackageLocation a))] -> m KnownTargets getKnownTargets dirActions@DirActions{..} pkgs = do - pinfo <- sequence [ selectPackageInfo dirActions pkg + pinfo <- sequence [ collectKnownPackageInfo dirActions pkg | SpecificSourcePackage pkg <- pkgs ] cwd <- getCurrentDirectory let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo @@ -1605,18 +1605,19 @@ getKnownTargets dirActions@DirActions{..} pkgs = do } where selectPrimaryPackage :: FilePath - -> [PackageInfo] - -> ([PackageInfo], [PackageInfo]) + -> [KnownPackage] + -> ([KnownPackage], [KnownPackage]) selectPrimaryPackage cwd = partition isPkgDirCwd where - isPkgDirCwd PackageInfo { pinfoDirectory = Just (dir,_) } + isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } | dir == cwd = True isPkgDirCwd _ = False -selectPackageInfo :: (Applicative m, Monad m) => DirActions m - -> SourcePackage (PackageLocation a) -> m PackageInfo -selectPackageInfo dirActions@DirActions{..} +collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m + -> SourcePackage (PackageLocation a) + -> m KnownPackage +collectKnownPackageInfo dirActions@DirActions{..} SourcePackage { packageDescription = pkg, packageSource = loc @@ -1636,19 +1637,19 @@ selectPackageInfo dirActions@DirActions{..} ) _ -> return (Nothing, Nothing) let pinfo = - PackageInfo { + KnownPackage { pinfoId = packageId pkg, pinfoDirectory = pkgdir, pinfoPackageFile = pkgfile, - pinfoComponents = selectComponentInfo pinfo + pinfoComponents = collectKnownComponentInfo pinfo (flattenPackageDescription pkg) } return pinfo -selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] -selectComponentInfo pinfo pkg = - [ ComponentInfo { +collectKnownComponentInfo :: KnownPackage -> PackageDescription -> [KnownComponent] +collectKnownComponentInfo pinfo pkg = + [ KnownComponent { cinfoName = componentName c, cinfoStrName = componentStringName pkg (componentName c), cinfoPackage = pinfo, @@ -1733,7 +1734,7 @@ componentKind (CExeName _) = ExeKind componentKind (CTestName _) = TestKind componentKind (CBenchName _) = BenchKind -cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind :: KnownComponent -> ComponentKind cinfoKind = componentKind . cinfoName matchComponentKind :: String -> Match ComponentKind @@ -1826,7 +1827,7 @@ guardPackageFile _ (FileStatusExistsFile file) guardPackageFile str _ = matchErrorExpected "package .cabal file" str -matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackage pinfo = \str fstatus -> orNoThingIn "project" "" $ matchPackageName pinfo str @@ -1834,7 +1835,7 @@ matchPackage pinfo = \str fstatus -> <|> matchPackageFile pinfo str fstatus) -matchPackageName :: [PackageInfo] -> String -> Match PackageInfo +matchPackageName :: [KnownPackage] -> String -> Match KnownPackage matchPackageName ps = \str -> do guard (validPackageName str) orNoSuchThing "package" str @@ -1843,8 +1844,8 @@ matchPackageName ps = \str -> do matchInexactly caseFold (display . packageName) ps str -matchPackageDir :: [PackageInfo] - -> String -> FileStatus -> Match PackageInfo +matchPackageDir :: [KnownPackage] + -> String -> FileStatus -> Match KnownPackage matchPackageDir ps = \str fstatus -> case fstatus of FileStatusExistsDir canondir -> @@ -1854,10 +1855,10 @@ matchPackageDir ps = \str fstatus -> _ -> mzero where dirs = [ ((dabs,drel),p) - | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] + | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] -matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo +matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackageFile ps = \str fstatus -> do case fstatus of FileStatusExistsFile canonfile -> @@ -1867,7 +1868,7 @@ matchPackageFile ps = \str fstatus -> do _ -> mzero where files = [ ((fabs,frel),p) - | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] + | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] --TODO: test outcome when dir exists but doesn't match any known one @@ -1890,15 +1891,15 @@ guardComponentName s || c == '_' || c == '-' || c == '\'' -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName :: [KnownComponent] -> String -> Match KnownComponent matchComponentName cs str = orNoSuchThing "component" str (map cinfoStrName cs) $ increaseConfidenceFor $ matchInexactly caseFold cinfoStrName cs str -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo +matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String + -> Match KnownComponent matchComponentKindAndName cs ckind str = orNoSuchThing (showComponentKind ckind ++ " component") str (map render cs) @@ -1944,27 +1945,27 @@ matchModuleNameAnd ms str = -- Matching file targets -- -matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus - -> Match (FilePath, PackageInfo) +matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus + -> Match (FilePath, KnownPackage) matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = increaseConfidenceFor $ matchDirectoryPrefix pkgdirs filepath where pkgdirs = [ (dir, p) - | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] + | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] matchPackageDirectoryPrefix _ _ = mzero -matchComponentFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) +matchComponentFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) matchComponentFile cs str = orNoSuchThing "file" str [] $ matchComponentModuleFile cs str <|> matchComponentOtherFile cs str -matchComponentOtherFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) +matchComponentOtherFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) matchComponentOtherFile cs = matchFile [ (file, c) @@ -1975,8 +1976,8 @@ matchComponentOtherFile cs = ] -matchComponentModuleFile :: [ComponentInfo] -> String - -> Match (FilePath, ComponentInfo) +matchComponentModuleFile :: [KnownComponent] -> String + -> Match (FilePath, KnownComponent) matchComponentModuleFile cs str = do matchFile [ (normalise (d toFilePath m), c) @@ -2226,16 +2227,16 @@ caseFold = lowercase -- {- -ex1pinfo :: [PackageInfo] +ex1pinfo :: [KnownPackage] ex1pinfo = [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ - PackageInfo { + KnownPackage { pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), pinfoDirectory = Just ("/the/foo", "foo"), pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), pinfoComponents = [] } - , PackageInfo { + , KnownPackage { pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), pinfoDirectory = Just ("/the/bar", "bar"), pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), @@ -2246,7 +2247,7 @@ ex1pinfo = addComponent n ds ms p = p { pinfoComponents = - ComponentInfo n (componentStringName (pinfoId p) n) + KnownComponent n (componentStringName (pinfoId p) n) p ds (map mkMn ms) [] [] [] : pinfoComponents p @@ -2270,13 +2271,13 @@ Just ex_pkgid = simpleParse "thelib" -} {- -ex_cs :: [ComponentInfo] +ex_cs :: [KnownComponent] ex_cs = [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) ] where - mkC n ds ms = ComponentInfo n (componentStringName n) ds (map mkMn ms) + mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) mkMn :: String -> ModuleName mkMn = fromJust . simpleParse pkgid :: PackageIdentifier From 11872e57f6c05ffc7254bc1c3301b96444c0c41f Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 26 Oct 2017 23:24:26 +0100 Subject: [PATCH 04/18] Don't paramaterise the TargetSelector type Previously the TargetSelector type had a type param for the type of the package that it referred to. In particular we used it with types like: type Matcher = ... -> Match (TargetSelector KnownPackage) type Renderer = TargetSelector PackageId -> ... However we are about to extend the TargetSelector so that it does not just refer to one form of package (e.g. KnownPackage) but can refer to packages via various different forms and partial information. So it no longer makes sense to have TargetSelector be paramaterised by the different states of the one kind of package it refers to, as there are now many kinds. So in preparation for that we simplify it so that it is equivalent to always using TargetSelector PackageId, and we remove the type paramater. --- cabal-install/Distribution/Client/CmdBench.hs | 8 +- cabal-install/Distribution/Client/CmdBuild.hs | 6 +- .../Distribution/Client/CmdErrorMessages.hs | 12 +- .../Distribution/Client/CmdHaddock.hs | 6 +- .../Distribution/Client/CmdInstall.hs | 8 +- cabal-install/Distribution/Client/CmdRepl.hs | 8 +- cabal-install/Distribution/Client/CmdRun.hs | 10 +- cabal-install/Distribution/Client/CmdTest.hs | 8 +- .../Client/ProjectOrchestration.hs | 9 +- .../Distribution/Client/TargetSelector.hs | 160 ++++++++---------- cabal-install/tests/IntegrationTests2.hs | 34 ++-- 11 files changed, 126 insertions(+), 143 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdBench.hs b/cabal-install/Distribution/Client/CmdBench.hs index 2ed14f28f80..f408323cf29 100644 --- a/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal-install/Distribution/Client/CmdBench.hs @@ -127,7 +127,7 @@ benchAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, had -- For the @bench@ command we select all buildable benchmarks, -- or fail if there are no benchmarks or no buildable benchmarks. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -181,13 +181,13 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches benchmarks but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | The 'TargetSelector' matches targets but no benchmarks - | TargetProblemNoBenchmarks (TargetSelector PackageId) + | TargetProblemNoBenchmarks TargetSelector -- | The 'TargetSelector' refers to a component that is not a benchmark | TargetProblemComponentNotBenchmark PackageId ComponentName diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index db348354398..d907d4d4338 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -126,7 +126,7 @@ buildAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, had -- For the @build@ command select all components except non-buildable and disabled -- tests\/benchmarks, fail if there are no such components -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -173,10 +173,10 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a diff --git a/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal-install/Distribution/Client/CmdErrorMessages.hs index 78030b7033a..412bbcd79f4 100644 --- a/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -84,7 +84,7 @@ sortGroupOn key = map (\xs@(x:_) -> (key x, xs)) -- Renderering for a few project and package types -- -renderTargetSelector :: TargetSelector PackageId -> String +renderTargetSelector :: TargetSelector -> String renderTargetSelector (TargetPackage _ pkgid Nothing) = "the package " ++ display pkgid @@ -129,20 +129,20 @@ optionalStanza _ = Nothing -- | Does the 'TargetSelector' potentially refer to one package or many? -- -targetSelectorPluralPkgs :: TargetSelector a -> Plural +targetSelectorPluralPkgs :: TargetSelector -> Plural targetSelectorPluralPkgs (TargetAllPackages _) = Plural targetSelectorPluralPkgs (TargetPackage _ _ _) = Singular targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular targetSelectorPluralPkgs (TargetPackageName _) = Singular -- | Does the 'TargetSelector' refer to -targetSelectorRefersToPkgs :: TargetSelector a -> Bool +targetSelectorRefersToPkgs :: TargetSelector -> Bool targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs (TargetComponent _ _ _) = False targetSelectorRefersToPkgs (TargetPackageName _) = True -targetSelectorFilter :: TargetSelector a -> Maybe ComponentKindFilter +targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter targetSelectorFilter (TargetComponent _ _ _) = Nothing @@ -238,7 +238,7 @@ renderTargetProblemCommon verb (TargetProblemNoSuchComponent pkgid cname) = -- This renders an error message for those cases. -- renderTargetProblemNoneEnabled :: String - -> TargetSelector PackageId + -> TargetSelector -> [AvailableTarget ()] -> String renderTargetProblemNoneEnabled verb targetSelector targets = @@ -300,7 +300,7 @@ renderTargetProblemNoneEnabled verb targetSelector targets = -- | Several commands have a @TargetProblemNoTargets@ problem constructor. -- This renders an error message for those cases. -- -renderTargetProblemNoTargets :: String -> TargetSelector PackageId -> String +renderTargetProblemNoTargets :: String -> TargetSelector -> String renderTargetProblemNoTargets verb targetSelector = "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector ++ " because " ++ reason targetSelector ++ ". " diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index 8a997e8ed0c..4e7dcb94401 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -122,7 +122,7 @@ haddockAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, h -- depending on the @--executables@ flag we also select all the buildable exes. -- We do similarly for test-suites, benchmarks and foreign libs. -- -selectPackageTargets :: HaddockFlags -> TargetSelector PackageId +selectPackageTargets :: HaddockFlags -> TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets haddockFlags targetSelector targets @@ -179,10 +179,10 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index f8e49b8b971..9df46a1c564 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -191,7 +191,7 @@ symlinkBuiltPackage :: (UnitId -> FilePath) -- ^ A function to get an UnitId's -- store directory -> FilePath -- ^ Where to put the symlink -> ( UnitId - , [(ComponentTarget, [TargetSelector PackageId])] ) + , [(ComponentTarget, [TargetSelector])] ) -> IO () symlinkBuiltPackage mkSourceBinDir destDir (pkg, components) = traverse_ (symlinkBuiltExe (mkSourceBinDir pkg) destDir) exes @@ -265,7 +265,7 @@ establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do -- For the @build@ command select all components except non-buildable and disabled -- tests\/benchmarks, fail if there are no such components -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -312,10 +312,10 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector deriving (Eq, Show) reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index 3c3f7781c69..ca11df9ebb2 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -153,7 +153,7 @@ replAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, hadd -- Fail if there are no buildable lib\/exe components, or if there are -- multiple libs or exes. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -229,13 +229,13 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] -- | Multiple 'TargetSelector's match multiple targets | TargetProblemMultipleTargets TargetsMap diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 32129363bbb..df92e61f186 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -283,7 +283,7 @@ matchingPackagesByUnitId uid = -- For the @run@ command we select the exe if there is only one and it's -- buildable. Fail if there are no or multiple buildable exe components. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -341,16 +341,16 @@ selectComponentTarget pkgid cname subtarget _ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | The 'TargetSelector' matches targets but no executables - | TargetProblemNoExes (TargetSelector PackageId) + | TargetProblemNoExes TargetSelector -- | A single 'TargetSelector' matches multiple targets - | TargetProblemMatchesMultiple (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()] -- | Multiple 'TargetSelector's match multiple targets | TargetProblemMultipleTargets TargetsMap diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index c4c070bb960..78730f567eb 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -130,7 +130,7 @@ testAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, hadd -- For the @test@ command we select all buildable test-suites, -- or fail if there are no test-suites or no buildable test-suites. -- -selectPackageTargets :: TargetSelector PackageId +selectPackageTargets :: TargetSelector -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets @@ -184,13 +184,13 @@ data TargetProblem = TargetProblemCommon TargetProblemCommon -- | The 'TargetSelector' matches targets but none are buildable - | TargetProblemNoneEnabled (TargetSelector PackageId) [AvailableTarget ()] + | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()] -- | There are no targets at all - | TargetProblemNoTargets (TargetSelector PackageId) + | TargetProblemNoTargets TargetSelector -- | The 'TargetSelector' matches targets but no test-suites - | TargetProblemNoTests (TargetSelector PackageId) + | TargetProblemNoTests TargetSelector -- | The 'TargetSelector' refers to a component that is not a test-suite | TargetProblemComponentNotTest PackageId ComponentName diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 212b3a4bb46..705080b737e 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -393,7 +393,7 @@ runProjectPostBuildPhase verbosity -- possible to for different selectors to match the same target. This extra -- information is primarily to help make helpful error messages. -- -type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])] +type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector])] -- | Given a set of 'TargetSelector's, resolve which 'UnitId's and -- 'ComponentTarget's they ought to refer to. @@ -428,7 +428,7 @@ type TargetsMap = Map UnitId [(ComponentTarget, [TargetSelector PackageId])] -- a basis for their own @selectComponentTarget@ implementation. -- resolveTargets :: forall err. - (forall k. TargetSelector PackageId + (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) -> (forall k. PackageId -> ComponentName -> SubComponentTarget @@ -436,7 +436,7 @@ resolveTargets :: forall err. -> Either err k ) -> (TargetProblemCommon -> err) -> ElaboratedInstallPlan - -> [TargetSelector PackageId] + -> [TargetSelector] -> Either [err] TargetsMap resolveTargets selectPackageTargets selectComponentTarget liftProblem installPlan targetSelectors = @@ -462,8 +462,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem -- TODO [required eventually] currently all build targets refer to packages -- inside the project. Ultimately this has to be generalised to allow -- referring to other packages and targets. - checkTarget :: TargetSelector PackageId - -> Either err [(UnitId, ComponentTarget)] + checkTarget :: TargetSelector -> Either err [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency checkTarget bt@(TargetPackage _ pkgid mkfilter) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index c4efb653c3c..a4d761aa541 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards #-} +{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, + RecordWildCards, NamedFieldPuns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.TargetSelector @@ -140,12 +141,12 @@ import Text.EditDistance -- > [ [lib:|exe:] component name ] -- > [ module name | source file ] -- -data TargetSelector pkg = +data TargetSelector = -- | A package as a whole: the default components for the package or all -- components of a particular kind. -- - TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter) + TargetPackage TargetImplicitCwd PackageId (Maybe ComponentKindFilter) -- | All packages, or all components of a particular kind in all packages. -- @@ -153,14 +154,14 @@ data TargetSelector pkg = -- | A specific component in a package. -- - | TargetComponent pkg ComponentName SubComponentTarget + | TargetComponent PackageId ComponentName SubComponentTarget -- | A named package, but not a known local package. It could for example -- resolve to a dependency of a local package or to a package from -- hackage. Either way, it requires further processing to resolve. -- | TargetPackageName PackageName - deriving (Eq, Ord, Functor, Show, Generic) + deriving (Eq, Ord, Show, Generic) -- | Does this 'TargetPackage' selector arise from syntax referring to a -- package in the current directory (e.g. @tests@ or no giving no explicit @@ -204,22 +205,20 @@ instance Binary SubComponentTarget -- readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] -> [String] - -> IO (Either [TargetSelectorProblem] - [TargetSelector PackageId]) + -> IO (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectors = readTargetSelectorsWith defaultDirActions readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m -> [PackageSpecifier (SourcePackage (PackageLocation a))] -> [String] - -> m (Either [TargetSelectorProblem] - [TargetSelector PackageId]) + -> m (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs = case parseTargetStrings targetStrs of ([], usertargets) -> do usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets knowntargets <- getKnownTargets dirActions pkgs case resolveTargetSelectors knowntargets usertargets' of - ([], btargets) -> return (Right (map (fmap packageId) btargets)) + ([], btargets) -> return (Right btargets) (problems, _) -> return (Left problems) (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) @@ -345,14 +344,14 @@ showTargetString = intercalate ":" . components components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] -showTargetSelector :: Package p => TargetSelector p -> String +showTargetSelector :: TargetSelector -> String showTargetSelector ts = case [ t | ql <- [QL1 .. QLFull] , t <- renderTargetSelector ql ts ] of (t':_) -> showTargetString (forgetFileStatus t') [] -> "" -showTargetSelectorKind :: TargetSelector a -> String +showTargetSelectorKind :: TargetSelector -> String showTargetSelectorKind bt = case bt of TargetPackage TargetExplicitNamed _ Nothing -> "package" TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" @@ -436,8 +435,7 @@ forgetFileStatus t = case t of resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] -> ([TargetSelectorProblem], - [TargetSelector KnownPackage]) - + [TargetSelector]) -- default local dir target if there's no given target: resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = ([TargetSelectorNoTargetsInProject], []) @@ -446,7 +444,7 @@ resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] = ([TargetSelectorNoTargetsInCwd], []) resolveTargetSelectors (KnownTargets{knownPackagesPrimary = (pkg:_)}) [] = - ([], [TargetPackage TargetImplicitCwd pkg Nothing]) + ([], [TargetPackage TargetImplicitCwd (packageId pkg) Nothing]) --TODO: in future allow multiple packages in the same dir resolveTargetSelectors knowntargets targetStrs = @@ -456,8 +454,7 @@ resolveTargetSelectors knowntargets targetStrs = resolveTargetSelector :: KnownTargets -> TargetStringFileStatus - -> Either TargetSelectorProblem - (TargetSelector KnownPackage) + -> Either TargetSelectorProblem TargetSelector resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = case findMatch (matcher targetStrStatus) of @@ -467,7 +464,7 @@ resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter) | (pkg:_) <- knownPackagesPrimary --TODO: in future allow multiple packages in the same dir - -> Right (TargetPackage TargetImplicitCwd pkg mkfilter) + -> Right (TargetPackage TargetImplicitCwd (packageId pkg) mkfilter) | otherwise -> Left (TargetSelectorNoCurrentPackage targetStr) Unambiguous target -> Right target @@ -482,11 +479,8 @@ resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = case disambiguateTargetSelectors matcher targetStrStatus exactMatch targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr - (map (fmap (fmap packageId)) targets')) - Left ((m, ms):_) -> Left (MatchingInternalError targetStr - (fmap packageId m) - (map (fmap (map (fmap packageId))) ms)) + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) Left [] -> internalError "resolveTargetSelector" where matcher = matchTargetSelector knowntargets @@ -550,10 +544,10 @@ data TargetSelectorProblem [(Maybe (String, String), String, String, [String])] -- ^ [([in thing], no such thing, actually got, alternatives)] | TargetSelectorAmbiguous TargetString - [(TargetString, TargetSelector PackageId)] + [(TargetString, TargetSelector)] - | MatchingInternalError TargetString (TargetSelector PackageId) - [(TargetString, [TargetSelector PackageId])] + | MatchingInternalError TargetString TargetSelector + [(TargetString, [TargetSelector])] | TargetSelectorUnrecognised String -- ^ Syntax error when trying to parse a target string. | TargetSelectorNoCurrentPackage TargetString @@ -565,12 +559,11 @@ data QualLevel = QL1 | QL2 | QL3 | QLFull deriving (Eq, Enum, Show) disambiguateTargetSelectors - :: (TargetStringFileStatus -> Match (TargetSelector KnownPackage)) + :: (TargetStringFileStatus -> Match TargetSelector) -> TargetStringFileStatus -> MatchClass - -> [TargetSelector KnownPackage] - -> Either [(TargetSelector KnownPackage, - [(TargetString, [TargetSelector KnownPackage])])] - [(TargetString, TargetSelector KnownPackage)] + -> [TargetSelector] + -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] + [(TargetString, TargetSelector)] disambiguateTargetSelectors matcher matchInput exactMatch matchResults = case partitionEithers results of (errs@(_:_), _) -> Left errs @@ -579,8 +572,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = -- So, here's the strategy. We take the original match results, and make a -- table of all their renderings at all qualification levels. -- Note there can be multiple renderings at each qualification level. - matchResultsRenderings :: [(TargetSelector KnownPackage, - [TargetStringFileStatus])] + matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] matchResultsRenderings = [ (matchResult, matchRenderings) | matchResult <- matchResults @@ -595,8 +587,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = -- for all of those renderings. So by looking up in this table we can see -- if we've got an unambiguous match. - memoisedMatches :: Map TargetStringFileStatus - (Match (TargetSelector KnownPackage)) + memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) memoisedMatches = -- avoid recomputing the main one if it was an exact match (if exactMatch == Exact @@ -610,9 +601,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = -- possible renderings (in order of qualification level, though remember -- there can be multiple renderings per level), and find the first one -- that has an unambiguous match. - results :: [Either (TargetSelector KnownPackage, - [(TargetString, [TargetSelector KnownPackage])]) - (TargetString, TargetSelector KnownPackage)] + results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) + (TargetString, TargetSelector)] results = [ case findUnambiguous originalMatch matchRenderings of Just unambiguousRendering -> @@ -630,13 +620,13 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = | (originalMatch, matchRenderings) <- matchResultsRenderings ] - findUnambiguous :: TargetSelector KnownPackage + findUnambiguous :: TargetSelector -> [TargetStringFileStatus] -> Maybe TargetStringFileStatus findUnambiguous _ [] = Nothing findUnambiguous t (r:rs) = case memoisedMatches Map.! r of - Match Exact _ [t'] | fmap packageName t == fmap packageName t' + Match Exact _ [t'] | t == t' -> Just r Match Exact _ _ -> findUnambiguous t rs Match Inexact _ _ -> internalError "Match Inexact" @@ -780,8 +770,8 @@ data Syntax = Syntax QualLevel Matcher Renderer | AmbiguousAlternatives Syntax Syntax | ShadowingAlternatives Syntax Syntax -type Matcher = TargetStringFileStatus -> Match (TargetSelector KnownPackage) -type Renderer = TargetSelector PackageId -> [TargetStringFileStatus] +type Matcher = TargetStringFileStatus -> Match TargetSelector +type Renderer = TargetSelector -> [TargetStringFileStatus] foldSyntax :: (a -> a -> a) -> (a -> a -> a) -> (QualLevel -> Matcher -> Renderer -> a) @@ -797,12 +787,12 @@ foldSyntax ambiguous unambiguous syntax = go -- Top level renderer and matcher -- -renderTargetSelector :: Package p => QualLevel -> TargetSelector p +renderTargetSelector :: QualLevel -> TargetSelector -> [TargetStringFileStatus] renderTargetSelector ql ts = foldSyntax (++) (++) - (\ql' _ render -> guard (ql == ql') >> render (fmap packageId ts)) + (\ql' _ render -> guard (ql == ql') >> render ts) syntax where syntax = syntaxForms emptyKnownTargets @@ -810,9 +800,9 @@ renderTargetSelector ql ts = matchTargetSelector :: KnownTargets -> TargetStringFileStatus - -> Match (TargetSelector KnownPackage) + -> Match TargetSelector matchTargetSelector knowntargets = \usertarget -> - nubMatchesBy ((==) `on` (fmap packageName)) $ + nubMatchesBy (==) $ let ql = targetQualLevel usertarget in foldSyntax @@ -938,25 +928,17 @@ syntaxForm1Filter :: Syntax syntaxForm1Filter = syntaxForm1 render $ \str1 _fstatus1 -> do kfilter <- matchComponentKindFilter str1 - return (TargetPackage TargetImplicitCwd dummyKnownPackage (Just kfilter)) + return (TargetPackage TargetImplicitCwd dummyKnownPackageId (Just kfilter)) where render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus1 (dispF kfilter) noFileStatus] render _ = [] -- Only used for TargetPackage TargetImplicitCwd -dummyKnownPackage :: KnownPackage -dummyKnownPackage = - KnownPackage { - pinfoId = PackageIdentifier +dummyKnownPackageId :: PackageId +dummyKnownPackageId = PackageIdentifier (mkPackageName "dummyKnownPackage") - (mkVersion []), - pinfoDirectory = unused, - pinfoPackageFile = unused, - pinfoComponents = unused - } - where - unused = error "dummyKnownPackage" + (mkVersion []) -- | Syntax: package (name, dir or file) -- @@ -968,7 +950,7 @@ syntaxForm1Package pinfo = syntaxForm1 render $ \str1 fstatus1 -> do guardPackage str1 fstatus1 p <- matchPackage pinfo str1 fstatus1 - return (TargetPackage TargetExplicitNamed p Nothing) + return (TargetPackage TargetExplicitNamed (packageId p) Nothing) where render (TargetPackage TargetExplicitNamed p Nothing) = [TargetStringFileStatus1 (dispP p) noFileStatus] @@ -983,7 +965,7 @@ syntaxForm1Component cs = syntaxForm1 render $ \str1 _fstatus1 -> do guardComponentName str1 c <- matchComponentName cs str1 - return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus1 (dispC p c) noFileStatus] @@ -999,7 +981,7 @@ syntaxForm1Module cs = guardModuleName str1 let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str1 - return (TargetComponent (cinfoPackage c) (cinfoName c) (ModuleTarget m)) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent _p _c (ModuleTarget m)) = [TargetStringFileStatus1 (dispM m) noFileStatus] @@ -1020,7 +1002,7 @@ syntaxForm1File ps = (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 orNoThingIn "package" (display (packageName p)) $ do (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) where render (TargetComponent _p _c (FileTarget f)) = [TargetStringFileStatus1 f noFileStatus] @@ -1068,7 +1050,7 @@ syntaxForm2PackageFilter ps = guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 kfilter <- matchComponentKindFilter str2 - return (TargetPackage TargetExplicitNamed p (Just kfilter)) + return (TargetPackage TargetExplicitNamed (packageId p) (Just kfilter)) where render (TargetPackage TargetExplicitNamed p (Just kfilter)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] @@ -1084,7 +1066,7 @@ syntaxForm2NamespacePackage pinfo = guardNamespacePackage str1 guardPackageName str2 p <- matchPackage pinfo str2 noFileStatus - return (TargetPackage TargetExplicitNamed p Nothing) + return (TargetPackage TargetExplicitNamed (packageId p) Nothing) where render (TargetPackage TargetExplicitNamed p Nothing) = [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] @@ -1104,7 +1086,7 @@ syntaxForm2PackageComponent ps = p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentName (pinfoComponents p) str2 - return (TargetComponent p (cinfoName c) WholeComponent) + return (TargetComponent (packageId p) (cinfoName c) WholeComponent) --TODO: the error here ought to say there's no component by that name in -- this package, and name the package where @@ -1122,7 +1104,7 @@ syntaxForm2KindComponent cs = ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 - return (TargetComponent (cinfoPackage c) (cinfoName c) WholeComponent) + return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus2 (dispK c) noFileStatus (dispC p c)] @@ -1143,7 +1125,7 @@ syntaxForm2PackageModule ps = orNoThingIn "package" (display (packageName p)) $ do let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str2 - return (TargetComponent p (cinfoName c) (ModuleTarget m)) + return (TargetComponent (packageId p) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p _c (ModuleTarget m)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] @@ -1162,7 +1144,7 @@ syntaxForm2ComponentModule cs = orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str2 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = @@ -1182,7 +1164,7 @@ syntaxForm2PackageFile ps = p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do (filepath, c) <- matchComponentFile (pinfoComponents p) str2 - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1199,7 +1181,7 @@ syntaxForm2ComponentFile cs = c <- matchComponentName cs str1 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str2 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = @@ -1230,7 +1212,7 @@ syntaxForm3MetaCwdFilter = guardNamespaceMeta str1 guardNamespaceCwd str2 kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetImplicitCwd dummyKnownPackage (Just kfilter)) + return (TargetPackage TargetImplicitCwd dummyKnownPackageId (Just kfilter)) where render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] @@ -1247,7 +1229,7 @@ syntaxForm3MetaNamespacePackage pinfo = guardNamespacePackage str2 guardPackageName str3 p <- matchPackage pinfo str3 noFileStatus - return (TargetPackage TargetExplicitNamed p Nothing) + return (TargetPackage TargetExplicitNamed (packageId p) Nothing) where render (TargetPackage TargetExplicitNamed p Nothing) = [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] @@ -1268,7 +1250,7 @@ syntaxForm3PackageKindComponent ps = p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - return (TargetComponent p (cinfoName c) WholeComponent) + return (TargetComponent (packageId p) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)] @@ -1292,7 +1274,7 @@ syntaxForm3PackageComponentModule ps = orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str3 - return (TargetComponent p (cinfoName c) (ModuleTarget m)) + return (TargetComponent (packageId p) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] @@ -1312,7 +1294,7 @@ syntaxForm3KindComponentModule cs = orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str3 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = @@ -1335,7 +1317,7 @@ syntaxForm3PackageComponentFile ps = c <- matchComponentName (pinfoComponents p) str2 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] @@ -1353,7 +1335,7 @@ syntaxForm3KindComponentFile cs = c <- matchComponentKindAndName cs ckind str2 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent (cinfoPackage c) (cinfoName c) + return (TargetComponent (cinfoPackageId c) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = @@ -1367,7 +1349,7 @@ syntaxForm3NamespacePackageFilter ps = guardPackageName str2 p <- matchPackage ps str2 noFileStatus kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetExplicitNamed p (Just kfilter)) + return (TargetPackage TargetExplicitNamed (packageId p) (Just kfilter)) where render (TargetPackage TargetExplicitNamed p (Just kfilter)) = [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] @@ -1383,7 +1365,7 @@ syntaxForm4MetaNamespacePackageFilter ps = guardPackageName str3 p <- matchPackage ps str3 noFileStatus kfilter <- matchComponentKindFilter str4 - return (TargetPackage TargetExplicitNamed p (Just kfilter)) + return (TargetPackage TargetExplicitNamed (packageId p) (Just kfilter)) where render (TargetPackage TargetExplicitNamed p (Just kfilter)) = [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] @@ -1404,7 +1386,7 @@ syntaxForm5MetaNamespacePackageKindComponent ps = p <- matchPackage ps str3 noFileStatus orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - return (TargetComponent p (cinfoName c) WholeComponent) + return (TargetComponent (packageId p) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)] @@ -1430,7 +1412,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str7 - return (TargetComponent p (cinfoName c) (ModuleTarget m)) + return (TargetComponent (packageId p) (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus7 "" "pkg" (dispP p) @@ -1457,7 +1439,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = c <- matchComponentKindAndName (pinfoComponents p) ckind str5 orNoThingIn "component" (cinfoStrName c) $ do (filepath,_) <- matchComponentFile [c] str7 - return (TargetComponent p (cinfoName c) (FileTarget filepath)) + return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus7 "" "pkg" (dispP p) @@ -1470,17 +1452,17 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = -- Syntax utils -- -type Match1 = String -> FileStatus -> Match (TargetSelector KnownPackage) +type Match1 = String -> FileStatus -> Match TargetSelector type Match2 = String -> FileStatus -> String - -> Match (TargetSelector KnownPackage) + -> Match TargetSelector type Match3 = String -> FileStatus -> String -> String - -> Match (TargetSelector KnownPackage) + -> Match TargetSelector type Match4 = String -> String -> String -> String - -> Match (TargetSelector KnownPackage) + -> Match TargetSelector type Match5 = String -> String -> String -> String -> String - -> Match (TargetSelector KnownPackage) + -> Match TargetSelector type Match7 = String -> String -> String -> String -> String -> String -> String - -> Match (TargetSelector KnownPackage) + -> Match TargetSelector syntaxForm1 :: Renderer -> Match1 -> Syntax syntaxForm2 :: Renderer -> Match2 -> Syntax @@ -1582,6 +1564,8 @@ type ComponentStringName = String instance Package KnownPackage where packageId = pinfoId +cinfoPackageId :: KnownComponent -> PackageId +cinfoPackageId = packageId . cinfoPackage emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets [] [] [] [] [] [] diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 9f9b9e8ac36..7b8abb55f7b 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -289,13 +289,13 @@ testTargetSelectorAmbiguous reportSubCase = do reportSubCase "ambiguous: cwd-pkg filter vs pkg" assertAmbiguous "libs" [ mkTargetPackage "libs" - , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just LibKind) ] + , TargetPackage TargetImplicitCwd "dummyKnownPackage" (Just LibKind) ] [mkpkg "libs" []] reportSubCase "ambiguous: filter vs cwd component" assertAmbiguous "exes" [ mkTargetComponent "other" (CExeName "exes") - , TargetPackage TargetImplicitCwd "dummyPackageInfo" (Just ExeKind) ] + , TargetPackage TargetImplicitCwd "dummyKnownPackage" (Just ExeKind) ] [mkpkg "other" [mkexe "exes"]] -- but filters are not ambiguous with non-cwd components, modules or files @@ -367,7 +367,7 @@ testTargetSelectorAmbiguous reportSubCase = do ] where assertAmbiguous :: String - -> [TargetSelector PackageId] + -> [TargetSelector] -> [SourcePackage (PackageLocation a)] -> Assertion assertAmbiguous str tss pkgs = do @@ -382,7 +382,7 @@ testTargetSelectorAmbiguous reportSubCase = do ++ "got " ++ show res assertUnambiguous :: String - -> TargetSelector PackageId + -> TargetSelector -> [SourcePackage (PackageLocation a)] -> Assertion assertUnambiguous str ts pkgs = do @@ -439,23 +439,23 @@ testTargetSelectorAmbiguous reportSubCase = do exe { buildInfo = (buildInfo exe) { cSources = files } } -mkTargetPackage :: PackageId -> TargetSelector PackageId +mkTargetPackage :: PackageId -> TargetSelector mkTargetPackage pkgid = TargetPackage TargetExplicitNamed pkgid Nothing -mkTargetComponent :: PackageId -> ComponentName -> TargetSelector PackageId +mkTargetComponent :: PackageId -> ComponentName -> TargetSelector mkTargetComponent pkgid cname = TargetComponent pkgid cname WholeComponent -mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector PackageId +mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector mkTargetModule pkgid cname mname = TargetComponent pkgid cname (ModuleTarget mname) -mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector PackageId +mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector mkTargetFile pkgid cname fname = TargetComponent pkgid cname (FileTarget fname) -mkTargetAllPackages :: TargetSelector PackageId +mkTargetAllPackages :: TargetSelector mkTargetAllPackages = TargetAllPackages Nothing instance IsString PackageIdentifier where @@ -516,8 +516,8 @@ testTargetProblemsCommon config0 = do [ (packageName p, packageId p) | p <- InstallPlan.toList elaboratedPlan ] - cases :: [( TargetSelector PackageId -> CmdBuild.TargetProblem - , TargetSelector PackageId + cases :: [( TargetSelector -> CmdBuild.TargetProblem + , TargetSelector )] cases = [ -- Cannot resolve packages outside of the project @@ -1217,10 +1217,10 @@ testTargetProblemsHaddock config reportSubCase = do assertProjectDistinctTargets :: forall err. (Eq err, Show err) => ElaboratedInstallPlan - -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) + -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) - -> [TargetSelector PackageId] + -> [TargetSelector] -> [(UnitId, ComponentName)] -> Assertion assertProjectDistinctTargets elaboratedPlan @@ -1247,14 +1247,14 @@ assertProjectDistinctTargets elaboratedPlan assertProjectTargetProblems :: forall err. (Eq err, Show err) => FilePath -> ProjectConfig - -> (forall k. TargetSelector PackageId + -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) - -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> [(TargetSelector -> err, TargetSelector)] -> Assertion assertProjectTargetProblems testdir config selectPackageTargets @@ -1273,10 +1273,10 @@ assertProjectTargetProblems testdir config assertTargetProblems :: forall err. (Eq err, Show err) => ElaboratedInstallPlan - -> (forall k. TargetSelector PackageId -> [AvailableTarget k] -> Either err [k]) + -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) - -> [(TargetSelector PackageId -> err, TargetSelector PackageId)] + -> [(TargetSelector -> err, TargetSelector)] -> Assertion assertTargetProblems elaboratedPlan selectPackageTargets From 0cdaeaa967c24489e290a2b39bfcc59b2885948d Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Fri, 27 Oct 2017 01:27:17 +0100 Subject: [PATCH 05/18] Make the KnownPackage/KnownComponent construction non-recursive It is unnecessary now that we do not put the whole KnownPackage into the TargetSelector. It not being recursive also makes it possible to have a Show instance, which is handy. --- .../Distribution/Client/TargetSelector.hs | 49 +++++++++---------- 1 file changed, 22 insertions(+), 27 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index a4d761aa541..fc3942da6ce 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -1538,6 +1538,7 @@ data KnownTargets = KnownTargets { knownComponentsPrimary :: [KnownComponent], knownComponentsOther :: [KnownComponent] } + deriving Show data KnownPackage = KnownPackage { pinfoId :: PackageId, @@ -1545,28 +1546,25 @@ data KnownPackage = KnownPackage { pinfoPackageFile :: Maybe (FilePath, FilePath), pinfoComponents :: [KnownComponent] } - -- not instance of Show due to recursive construction + deriving Show data KnownComponent = KnownComponent { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoPackage :: KnownPackage, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoCFiles :: [FilePath], - cinfoJsFiles :: [FilePath] + cinfoName :: ComponentName, + cinfoStrName :: ComponentStringName, + cinfoPackageId :: PackageId, + cinfoSrcDirs :: [FilePath], + cinfoModules :: [ModuleName], + cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) + cinfoCFiles :: [FilePath], + cinfoJsFiles :: [FilePath] } - -- not instance of Show due to recursive construction + deriving Show type ComponentStringName = String instance Package KnownPackage where packageId = pinfoId -cinfoPackageId :: KnownComponent -> PackageId -cinfoPackageId = packageId . cinfoPackage - emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets [] [] [] [] [] [] @@ -1625,26 +1623,23 @@ collectKnownPackageInfo dirActions@DirActions{..} pinfoId = packageId pkg, pinfoDirectory = pkgdir, pinfoPackageFile = pkgfile, - pinfoComponents = collectKnownComponentInfo pinfo + pinfoComponents = collectKnownComponentInfo (flattenPackageDescription pkg) } return pinfo -collectKnownComponentInfo :: KnownPackage -> PackageDescription -> [KnownComponent] -collectKnownComponentInfo pinfo pkg = +collectKnownComponentInfo :: PackageDescription -> [KnownComponent] +collectKnownComponentInfo pkg = [ KnownComponent { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoPackage = pinfo, - cinfoSrcDirs = ordNub (hsSourceDirs bi), --- [ pkgroot srcdir --- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) --- , srcdir <- hsSourceDirs bi ], - cinfoModules = ordNub (componentModules c), - cinfoHsFiles = ordNub (componentHsFiles c), - cinfoCFiles = ordNub (cSources bi), - cinfoJsFiles = ordNub (jsSources bi) + cinfoName = componentName c, + cinfoStrName = componentStringName pkg (componentName c), + cinfoPackageId = packageId pkg, + cinfoSrcDirs = ordNub (hsSourceDirs bi), + cinfoModules = ordNub (componentModules c), + cinfoHsFiles = ordNub (componentHsFiles c), + cinfoCFiles = ordNub (cSources bi), + cinfoJsFiles = ordNub (jsSources bi) } | c <- pkgComponents pkg , let bi = componentBuildInfo c ] From 1fb248617486df26b68b84634e3234a787c53765 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 31 Oct 2017 08:48:34 +0000 Subject: [PATCH 06/18] TargetPackage TargetSelector allows multiple package ids That is, the TargetPackage instead of having a single PackageId contains a [PackageId]. Ultimately this will allow us to support multiple .cabal files in a single directory. But the real reason to do this generalisation now is that it helps with the TargetImplicitCwd case. For the implicit CWD case we need to be able to parse the target whether or not there is a package in the CWD. So the simplest solution is to pass in all the local CWD packages (though typically only 0 or 1) and put all of them in. Then at the end we can check if in fact there were 0 and fail. When we do want to support multiple .cabal files in a dir, we'll also need to adjust the project config code, and extend the syntax slightly so that we render as the package location for the case of multiple packages. --- .../Distribution/Client/CmdErrorMessages.hs | 14 ++-- .../Client/ProjectOrchestration.hs | 8 +- .../Distribution/Client/TargetSelector.hs | 73 +++++++++---------- cabal-install/tests/IntegrationTests2.hs | 36 ++++----- 4 files changed, 67 insertions(+), 64 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal-install/Distribution/Client/CmdErrorMessages.hs index 412bbcd79f4..2929eb6a1f5 100644 --- a/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -85,12 +85,14 @@ sortGroupOn key = map (\xs@(x:_) -> (key x, xs)) -- renderTargetSelector :: TargetSelector -> String -renderTargetSelector (TargetPackage _ pkgid Nothing) = - "the package " ++ display pkgid +renderTargetSelector (TargetPackage _ pkgids Nothing) = + "the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map display pkgids) -renderTargetSelector (TargetPackage _ pkgid (Just kfilter)) = +renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = "the " ++ renderComponentKind Plural kfilter - ++ " in the package " ++ display pkgid + ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " + ++ renderListCommaAnd (map display pkgids) renderTargetSelector (TargetAllPackages Nothing) = "all the packages in the project" @@ -131,11 +133,11 @@ optionalStanza _ = Nothing -- targetSelectorPluralPkgs :: TargetSelector -> Plural targetSelectorPluralPkgs (TargetAllPackages _) = Plural -targetSelectorPluralPkgs (TargetPackage _ _ _) = Singular +targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular targetSelectorPluralPkgs (TargetPackageName _) = Singular --- | Does the 'TargetSelector' refer to +-- | Does the 'TargetSelector' refer to packages or to components? targetSelectorRefersToPkgs :: TargetSelector -> Bool targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 705080b737e..275cd398414 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -465,7 +465,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem checkTarget :: TargetSelector -> Either err [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ pkgid mkfilter) + checkTarget bt@(TargetPackage _ [pkgid] mkfilter) | Just ats <- fmap (maybe id filterTargetsKind mkfilter) $ Map.lookup pkgid availableTargetsByPackage = case selectPackageTargets bt ats of @@ -476,6 +476,12 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem | otherwise = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) + checkTarget (TargetPackage _ _ _) + = error "TODO: add support for multiple packages in a directory" + -- For the moment this error cannot happen here, because it gets + -- detected when the package config is being constructed. This case + -- will need handling properly when we do add support. + checkTarget bt@(TargetAllPackages mkfilter) = let ats = maybe id filterTargetsKind mkfilter $ filter availableTargetLocalToProject diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index fc3942da6ce..7d3ebc434c4 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -37,10 +37,8 @@ module Distribution.Client.TargetSelector ( ) where import Distribution.Package - ( Package(..), PackageId, PackageIdentifier(..) + ( Package(..), PackageId , PackageName, packageName, mkPackageName ) -import Distribution.Version - ( mkVersion ) import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..) ) @@ -143,10 +141,13 @@ import Text.EditDistance -- data TargetSelector = - -- | A package as a whole: the default components for the package or all - -- components of a particular kind. + -- | One (or more) packages as a whole, or all the components of a + -- particular kind within the package(s). -- - TargetPackage TargetImplicitCwd PackageId (Maybe ComponentKindFilter) + -- These are always packages that are local to the project. In the case + -- that there is more than one, they all share the same directory location. + -- + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) -- | All packages, or all components of a particular kind in all packages. -- @@ -443,9 +444,8 @@ resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] = ([TargetSelectorNoTargetsInCwd], []) -resolveTargetSelectors (KnownTargets{knownPackagesPrimary = (pkg:_)}) [] = - ([], [TargetPackage TargetImplicitCwd (packageId pkg) Nothing]) - --TODO: in future allow multiple packages in the same dir +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = pkgs}) [] = + ([], [TargetPackage TargetImplicitCwd (map packageId pkgs) Nothing]) resolveTargetSelectors knowntargets targetStrs = partitionEithers @@ -461,11 +461,8 @@ resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = Unambiguous _ | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter) - | (pkg:_) <- knownPackagesPrimary - --TODO: in future allow multiple packages in the same dir - -> Right (TargetPackage TargetImplicitCwd (packageId pkg) mkfilter) - | otherwise -> Left (TargetSelectorNoCurrentPackage targetStr) + Unambiguous (TargetPackage TargetImplicitCwd [] _) + -> Left (TargetSelectorNoCurrentPackage targetStr) Unambiguous target -> Right target @@ -829,6 +826,7 @@ matchTargetSelector knowntargets = \usertarget -> syntaxForms :: KnownTargets -> Syntax syntaxForms KnownTargets { knownPackagesAll = pinfo, + knownPackagesPrimary = ppinfo, knownComponentsAll = cinfo, knownComponentsPrimary = pcinfo, knownComponentsOther = ocinfo @@ -848,7 +846,7 @@ syntaxForms KnownTargets { [ shadowingAlternatives [ ambiguousAlternatives [ syntaxForm1All - , syntaxForm1Filter + , syntaxForm1Filter ppinfo , shadowingAlternatives [ syntaxForm1Component pcinfo , syntaxForm1Package pinfo @@ -890,7 +888,7 @@ syntaxForms KnownTargets { -- fully-qualified forms for all and cwd with filter , syntaxForm3MetaAllFilter - , syntaxForm3MetaCwdFilter + , syntaxForm3MetaCwdFilter ppinfo -- fully-qualified form for package and package with filter , syntaxForm3MetaNamespacePackage pinfo @@ -924,21 +922,17 @@ syntaxForm1All = -- -- > cabal build tests -- -syntaxForm1Filter :: Syntax -syntaxForm1Filter = +syntaxForm1Filter :: [KnownPackage] -> Syntax +syntaxForm1Filter ps = syntaxForm1 render $ \str1 _fstatus1 -> do kfilter <- matchComponentKindFilter str1 - return (TargetPackage TargetImplicitCwd dummyKnownPackageId (Just kfilter)) + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus1 (dispF kfilter) noFileStatus] render _ = [] --- Only used for TargetPackage TargetImplicitCwd -dummyKnownPackageId :: PackageId -dummyKnownPackageId = PackageIdentifier - (mkPackageName "dummyKnownPackage") - (mkVersion []) -- | Syntax: package (name, dir or file) -- @@ -950,9 +944,9 @@ syntaxForm1Package pinfo = syntaxForm1 render $ \str1 fstatus1 -> do guardPackage str1 fstatus1 p <- matchPackage pinfo str1 fstatus1 - return (TargetPackage TargetExplicitNamed (packageId p) Nothing) + return (TargetPackage TargetExplicitNamed [packageId p] Nothing) where - render (TargetPackage TargetExplicitNamed p Nothing) = + render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus1 (dispP p) noFileStatus] render _ = [] @@ -1050,9 +1044,9 @@ syntaxForm2PackageFilter ps = guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 kfilter <- matchComponentKindFilter str2 - return (TargetPackage TargetExplicitNamed (packageId p) (Just kfilter)) + return (TargetPackage TargetExplicitNamed [packageId p] (Just kfilter)) where - render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] render _ = [] @@ -1066,9 +1060,9 @@ syntaxForm2NamespacePackage pinfo = guardNamespacePackage str1 guardPackageName str2 p <- matchPackage pinfo str2 noFileStatus - return (TargetPackage TargetExplicitNamed (packageId p) Nothing) + return (TargetPackage TargetExplicitNamed [packageId p] Nothing) where - render (TargetPackage TargetExplicitNamed p Nothing) = + render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] render _ = [] @@ -1206,14 +1200,15 @@ syntaxForm3MetaAllFilter = [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] render _ = [] -syntaxForm3MetaCwdFilter :: Syntax -syntaxForm3MetaCwdFilter = +syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax +syntaxForm3MetaCwdFilter ps = syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do guardNamespaceMeta str1 guardNamespaceCwd str2 kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetImplicitCwd dummyKnownPackageId (Just kfilter)) + return (TargetPackage TargetImplicitCwd pids (Just kfilter)) where + pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] render _ = [] @@ -1229,9 +1224,9 @@ syntaxForm3MetaNamespacePackage pinfo = guardNamespacePackage str2 guardPackageName str3 p <- matchPackage pinfo str3 noFileStatus - return (TargetPackage TargetExplicitNamed (packageId p) Nothing) + return (TargetPackage TargetExplicitNamed [packageId p] Nothing) where - render (TargetPackage TargetExplicitNamed p Nothing) = + render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] render _ = [] @@ -1349,9 +1344,9 @@ syntaxForm3NamespacePackageFilter ps = guardPackageName str2 p <- matchPackage ps str2 noFileStatus kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetExplicitNamed (packageId p) (Just kfilter)) + return (TargetPackage TargetExplicitNamed [packageId p] (Just kfilter)) where - render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] render _ = [] @@ -1365,9 +1360,9 @@ syntaxForm4MetaNamespacePackageFilter ps = guardPackageName str3 p <- matchPackage ps str3 noFileStatus kfilter <- matchComponentKindFilter str4 - return (TargetPackage TargetExplicitNamed (packageId p) (Just kfilter)) + return (TargetPackage TargetExplicitNamed [packageId p] (Just kfilter)) where - render (TargetPackage TargetExplicitNamed p (Just kfilter)) = + render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] render _ = [] diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 7b8abb55f7b..d5caa118451 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -149,7 +149,7 @@ testTargetSelectors reportSubCase = do reportSubCase "cwd" do Right ts <- readTargetSelectors' [] - ts @?= [TargetPackage TargetImplicitCwd "p-0.1" Nothing] + ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] reportSubCase "all" do Right ts <- readTargetSelectors' @@ -164,7 +164,7 @@ testTargetSelectors reportSubCase = do , "tests", ":cwd:tests" , "benchmarks", ":cwd:benchmarks"] zipWithM_ (@?=) ts - [ TargetPackage TargetImplicitCwd "p-0.1" (Just kind) + [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind) | kind <- concatMap (replicate 2) [LibKind .. ] ] @@ -200,10 +200,10 @@ testTargetSelectors reportSubCase = do , "q:tests", "q/:tests", ":pkg:q:tests" , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"] zipWithM_ (@?=) ts $ - [ TargetPackage TargetExplicitNamed "p-0.1" (Just kind) + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind) | kind <- concatMap (replicate 3) [LibKind .. ] ] ++ - [ TargetPackage TargetExplicitNamed "q-0.1" (Just kind) + [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind) | kind <- concatMap (replicate 3) [LibKind .. ] ] @@ -289,19 +289,19 @@ testTargetSelectorAmbiguous reportSubCase = do reportSubCase "ambiguous: cwd-pkg filter vs pkg" assertAmbiguous "libs" [ mkTargetPackage "libs" - , TargetPackage TargetImplicitCwd "dummyKnownPackage" (Just LibKind) ] + , TargetPackage TargetImplicitCwd ["libs"] (Just LibKind) ] [mkpkg "libs" []] reportSubCase "ambiguous: filter vs cwd component" assertAmbiguous "exes" [ mkTargetComponent "other" (CExeName "exes") - , TargetPackage TargetImplicitCwd "dummyKnownPackage" (Just ExeKind) ] + , TargetPackage TargetImplicitCwd ["other"] (Just ExeKind) ] [mkpkg "other" [mkexe "exes"]] -- but filters are not ambiguous with non-cwd components, modules or files reportSubCase "unambiguous: filter vs non-cwd comp, mod, file" assertUnambiguous "Libs" - (TargetPackage TargetImplicitCwd "bar" (Just LibKind)) + (TargetPackage TargetImplicitCwd ["bar"] (Just LibKind)) [ mkpkgAt "foo" [mkexe "Libs"] "foo" , mkpkg "bar" [ mkexe "bar" `withModules` ["Libs"] , mkexe "baz" `withCFiles` ["Libs"] ] @@ -441,7 +441,7 @@ testTargetSelectorAmbiguous reportSubCase = do mkTargetPackage :: PackageId -> TargetSelector mkTargetPackage pkgid = - TargetPackage TargetExplicitNamed pkgid Nothing + TargetPackage TargetExplicitNamed [pkgid] Nothing mkTargetComponent :: PackageId -> ComponentName -> TargetSelector mkTargetComponent pkgid cname = @@ -673,8 +673,8 @@ testTargetProblemsBuild config reportSubCase = do CmdBuild.selectPackageTargets CmdBuild.selectComponentTarget CmdBuild.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") @@ -726,7 +726,7 @@ testTargetProblemsRepl config reportSubCase = do , AvailableTarget "p-0.1" (CTestName "p1") (TargetBuildable () TargetNotRequestedByDefault) True ] - , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ) ] reportSubCase "multiple targets" @@ -796,7 +796,7 @@ testTargetProblemsRepl config reportSubCase = do CmdRepl.selectPackageTargets CmdRepl.selectComponentTarget CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" Nothing ] + [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] [ ("p-0.1-inplace", CLibName) ] -- When we select the package with an explicit filter then we get those -- components even though we did not explicitly enable tests/benchmarks @@ -805,14 +805,14 @@ testTargetProblemsRepl config reportSubCase = do CmdRepl.selectPackageTargets CmdRepl.selectComponentTarget CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) ] + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ] [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] assertProjectDistinctTargets elaboratedPlan CmdRepl.selectPackageTargets CmdRepl.selectComponentTarget CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) ] + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] @@ -1195,10 +1195,10 @@ testTargetProblemsHaddock config reportSubCase = do (CmdHaddock.selectPackageTargets haddockFlags) CmdHaddock.selectComponentTarget CmdHaddock.TargetProblemCommon - [ TargetPackage TargetExplicitNamed "p-0.1" (Just FLibKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just ExeKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just TestKind) - , TargetPackage TargetExplicitNamed "p-0.1" (Just BenchKind) + [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just FLibKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just ExeKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) + , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") From 9bca00af8a5580d040d1333739f6b0985976e676 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 31 Oct 2017 09:15:39 +0000 Subject: [PATCH 07/18] Drop instance Package KnownPackage and fix consequences We are about to generalise KnownPackage in such a way that it can no longer be an instance of Package. The extra constructor will only hold a PackageName, not a full PackageId. In addition, whenever we get a KnownPackage, we do case analysis and record pattern matching to select the bits we need. This is in preparation for adding the second constructor. We switch to record pattern matching rather than field names as functions since those functions will become partial once we add the second constructor. --- .../Distribution/Client/TargetSelector.hs | 145 +++++++++++------- 1 file changed, 89 insertions(+), 56 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 7d3ebc434c4..64ec41f7bd4 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -444,8 +444,10 @@ resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] = ([TargetSelectorNoTargetsInCwd], []) -resolveTargetSelectors (KnownTargets{knownPackagesPrimary = pkgs}) [] = - ([], [TargetPackage TargetImplicitCwd (map packageId pkgs) Nothing]) +resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] = + ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + where + pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] resolveTargetSelectors knowntargets targetStrs = partitionEithers @@ -944,7 +946,9 @@ syntaxForm1Package pinfo = syntaxForm1 render $ \str1 fstatus1 -> do guardPackage str1 fstatus1 p <- matchPackage pinfo str1 fstatus1 - return (TargetPackage TargetExplicitNamed [packageId p] Nothing) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) where render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus1 (dispP p) noFileStatus] @@ -993,10 +997,11 @@ syntaxForm1File ps = -- all the other forms we don't require that. syntaxForm1 render $ \str1 fstatus1 -> expecting "file" str1 $ do - (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile - return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) + (pkgfile, KnownPackage{pinfoId, pinfoComponents}) + <- matchPackageDirectoryPrefix ps fstatus1 + orNoThingIn "package" (display (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents pkgfile + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) where render (TargetComponent _p _c (FileTarget f)) = [TargetStringFileStatus1 f noFileStatus] @@ -1044,7 +1049,9 @@ syntaxForm2PackageFilter ps = guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 kfilter <- matchComponentKindFilter str2 - return (TargetPackage TargetExplicitNamed [packageId p] (Just kfilter)) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) where render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] @@ -1060,7 +1067,9 @@ syntaxForm2NamespacePackage pinfo = guardNamespacePackage str1 guardPackageName str2 p <- matchPackage pinfo str2 noFileStatus - return (TargetPackage TargetExplicitNamed [packageId p] Nothing) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) where render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] @@ -1078,11 +1087,13 @@ syntaxForm2PackageComponent ps = guardPackage str1 fstatus1 guardComponentName str2 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - return (TargetComponent (packageId p) (cinfoName c) WholeComponent) - --TODO: the error here ought to say there's no component by that name in - -- this package, and name the package + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) + --TODO: the error here ought to say there's no component by that name in + -- this package, and name the package where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] @@ -1116,10 +1127,12 @@ syntaxForm2PackageModule ps = guardPackage str1 fstatus1 guardModuleName str2 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] - (m,c) <- matchModuleNameAnd ms str2 - return (TargetComponent (packageId p) (cinfoName c) (ModuleTarget m)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] + (m,c) <- matchModuleNameAnd ms str2 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) where render (TargetComponent p _c (ModuleTarget m)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] @@ -1156,9 +1169,11 @@ syntaxForm2PackageFile ps = syntaxForm2 render $ \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - (filepath, c) <- matchComponentFile (pinfoComponents p) str2 - return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + (filepath, c) <- matchComponentFile pinfoComponents str2 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1224,7 +1239,9 @@ syntaxForm3MetaNamespacePackage pinfo = guardNamespacePackage str2 guardPackageName str3 p <- matchPackage pinfo str3 noFileStatus - return (TargetPackage TargetExplicitNamed [packageId p] Nothing) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) where render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] @@ -1243,9 +1260,11 @@ syntaxForm3PackageKindComponent ps = ckind <- matchComponentKind str2 guardComponentName str3 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str3 - return (TargetComponent (packageId p) (cinfoName c) WholeComponent) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str3 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)] @@ -1264,12 +1283,14 @@ syntaxForm3PackageComponentModule ps = guardComponentName str2 guardModuleName str3 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (TargetComponent (packageId p) (cinfoName c) (ModuleTarget m)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] @@ -1308,11 +1329,13 @@ syntaxForm3PackageComponentFile ps = guardPackage str1 fstatus1 guardComponentName str2 p <- matchPackage ps str1 fstatus1 - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentName (pinfoComponents p) str2 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath, _) <- matchComponentFile [c] str3 - return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentName pinfoComponents str2 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath, _) <- matchComponentFile [c] str3 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] @@ -1344,7 +1367,9 @@ syntaxForm3NamespacePackageFilter ps = guardPackageName str2 p <- matchPackage ps str2 noFileStatus kfilter <- matchComponentKindFilter str3 - return (TargetPackage TargetExplicitNamed [packageId p] (Just kfilter)) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) where render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] @@ -1360,7 +1385,9 @@ syntaxForm4MetaNamespacePackageFilter ps = guardPackageName str3 p <- matchPackage ps str3 noFileStatus kfilter <- matchComponentKindFilter str4 - return (TargetPackage TargetExplicitNamed [packageId p] (Just kfilter)) + case p of + KnownPackage{pinfoId} -> + return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) where render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] @@ -1379,9 +1406,11 @@ syntaxForm5MetaNamespacePackageKindComponent ps = ckind <- matchComponentKind str4 guardComponentName str5 p <- matchPackage ps str3 noFileStatus - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - return (TargetComponent (packageId p) (cinfoName c) WholeComponent) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + return (TargetComponent pinfoId (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)] @@ -1402,12 +1431,14 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = guardComponentName str5 guardNamespaceModule str6 p <- matchPackage ps str3 noFileStatus - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - let ms = cinfoModules c - m <- matchModuleName ms str7 - return (TargetComponent (packageId p) (cinfoName c) (ModuleTarget m)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + let ms = cinfoModules c + m <- matchModuleName ms str7 + return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus7 "" "pkg" (dispP p) @@ -1430,11 +1461,13 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = guardComponentName str5 guardNamespaceFile str6 p <- matchPackage ps str3 noFileStatus - orNoThingIn "package" (display (packageName p)) $ do - c <- matchComponentKindAndName (pinfoComponents p) ckind str5 - orNoThingIn "component" (cinfoStrName c) $ do - (filepath,_) <- matchComponentFile [c] str7 - return (TargetComponent (packageId p) (cinfoName c) (FileTarget filepath)) + case p of + KnownPackage{pinfoId, pinfoComponents} -> + orNoThingIn "package" (display (packageName pinfoId)) $ do + c <- matchComponentKindAndName pinfoComponents ckind str5 + orNoThingIn "component" (cinfoStrName c) $ do + (filepath,_) <- matchComponentFile [c] str7 + return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus7 "" "pkg" (dispP p) @@ -1557,8 +1590,8 @@ data KnownComponent = KnownComponent { type ComponentStringName = String -instance Package KnownPackage where - packageId = pinfoId +knownPackageName :: KnownPackage -> PackageName +knownPackageName KnownPackage{pinfoId} = packageName pinfoId emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets [] [] [] [] [] [] @@ -1813,9 +1846,9 @@ matchPackageName :: [KnownPackage] -> String -> Match KnownPackage matchPackageName ps = \str -> do guard (validPackageName str) orNoSuchThing "package" str - (map (display . packageName) ps) $ + (map (display . knownPackageName) ps) $ increaseConfidenceFor $ - matchInexactly caseFold (display . packageName) ps str + matchInexactly caseFold (display . knownPackageName) ps str matchPackageDir :: [KnownPackage] From 5ebae3e3839f272b0bcd3138cafd1876041eb12d Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Thu, 2 Nov 2017 09:49:36 +0000 Subject: [PATCH 08/18] Add and rename a utility We'll need display of component kind both for component names (as now) and also directly for ComponentKind. Rename so the naming is sane. --- .../Distribution/Client/TargetSelector.hs | 21 +++++++++++-------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 64ec41f7bd4..fd56c94a891 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -1112,7 +1112,7 @@ syntaxForm2KindComponent cs = return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus2 (dispK c) noFileStatus (dispC p c)] + [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] render _ = [] -- | Syntax: package : module @@ -1267,7 +1267,7 @@ syntaxForm3PackageKindComponent ps = return (TargetComponent pinfoId (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus3 (dispP p) noFileStatus (dispK c) (dispC p c)] + [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] render _ = [] -- | Syntax: package : component : module @@ -1314,7 +1314,7 @@ syntaxForm3KindComponentModule cs = (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = - [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) (dispM m)] + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] render _ = [] -- | Syntax: package : component : filename @@ -1357,7 +1357,7 @@ syntaxForm3KindComponentFile cs = (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = - [TargetStringFileStatus3 (dispK c) noFileStatus (dispC p c) f] + [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] render _ = [] syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax @@ -1413,7 +1413,7 @@ syntaxForm5MetaNamespacePackageKindComponent ps = return (TargetComponent pinfoId (cinfoName c) WholeComponent) where render (TargetComponent p c WholeComponent) = - [TargetStringFileStatus5 "" "pkg" (dispP p) (dispK c) (dispC p c)] + [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] render _ = [] -- | Syntax: :pkg : package : namespace : component : module : module @@ -1442,7 +1442,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispK c) (dispC p c) + (dispCK c) (dispC p c) "module" (dispM m)] render _ = [] @@ -1471,7 +1471,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus7 "" "pkg" (dispP p) - (dispK c) (dispC p c) + (dispCK c) (dispC p c) "file" f] render _ = [] @@ -1544,8 +1544,11 @@ dispP = display . packageName dispC :: Package p => p -> ComponentName -> String dispC = componentStringName -dispK :: ComponentName -> String -dispK = showComponentKindShort . componentKind +dispK :: ComponentKind -> String +dispK = showComponentKindShort + +dispCK :: ComponentName -> String +dispCK = dispK . componentKind dispF :: ComponentKind -> String dispF = showComponentKindFilterShort From f438b0573f25a42d438348803414955a48f2d613 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sat, 4 Nov 2017 12:17:24 +0000 Subject: [PATCH 09/18] Add a target selector for extra-packages. Add TargetPackageNamed, like TargetPackage but for known packages within the project that are only specified by name. This includes the extra-packages from the @cabal.project@ file. It does not include indirect deps or other packages from hackage. That will be covered by a separate constructor. This replaces the previous TargetPackageName constructor which was part of a much more limited implementation of the same general idea. --- .../Distribution/Client/CmdErrorMessages.hs | 34 +++++---- .../Distribution/Client/CmdInstall.hs | 3 +- .../Client/ProjectOrchestration.hs | 9 +-- .../Distribution/Client/TargetSelector.hs | 71 +++++++++++++++---- 4 files changed, 83 insertions(+), 34 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal-install/Distribution/Client/CmdErrorMessages.hs index 2929eb6a1f5..126242e966d 100644 --- a/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -94,6 +94,13 @@ renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) = ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " " ++ renderListCommaAnd (map display pkgids) +renderTargetSelector (TargetPackageNamed pkgname Nothing) = + "the package " ++ display pkgname + +renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) = + "the " ++ renderComponentKind Plural kfilter + ++ " in the package " ++ display pkgname + renderTargetSelector (TargetAllPackages Nothing) = "all the packages in the project" @@ -113,9 +120,6 @@ renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) = renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) = "the module " ++ display modname ++ " in the " ++ showComponentName cname -renderTargetSelector (TargetPackageName pkgname) = - "the package " ++ display pkgname - renderOptionalStanza :: Plural -> OptionalStanza -> String renderOptionalStanza Singular TestStanzas = "test suite" @@ -134,21 +138,21 @@ optionalStanza _ = Nothing targetSelectorPluralPkgs :: TargetSelector -> Plural targetSelectorPluralPkgs (TargetAllPackages _) = Plural targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids +targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular -targetSelectorPluralPkgs (TargetPackageName _) = Singular -- | Does the 'TargetSelector' refer to packages or to components? targetSelectorRefersToPkgs :: TargetSelector -> Bool -targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetComponent _ _ _) = False -targetSelectorRefersToPkgs (TargetPackageName _) = True +targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter +targetSelectorRefersToPkgs (TargetComponent _ _ _) = False targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter -targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter -targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter -targetSelectorFilter (TargetComponent _ _ _) = Nothing -targetSelectorFilter (TargetPackageName _) = Nothing +targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter +targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter +targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter +targetSelectorFilter (TargetComponent _ _ _) = Nothing renderComponentKind :: Plural -> ComponentKind -> String renderComponentKind Singular ckind = case ckind of @@ -316,6 +320,10 @@ renderTargetProblemNoTargets verb targetSelector = "it does not contain any components at all" reason (TargetPackage _ _ (Just kfilter)) = "it does not contain any " ++ renderComponentKind Plural kfilter + reason (TargetPackageNamed _ Nothing) = + "it does not contain any components at all" + reason (TargetPackageNamed _ (Just kfilter)) = + "it does not contain any " ++ renderComponentKind Plural kfilter reason (TargetAllPackages Nothing) = "none of them contain any components at all" reason (TargetAllPackages (Just kfilter)) = @@ -323,8 +331,6 @@ renderTargetProblemNoTargets verb targetSelector = ++ renderComponentKind Plural kfilter reason ts@TargetComponent{} = error $ "renderTargetProblemNoTargets: " ++ show ts - reason (TargetPackageName _) = - "it does not contain any components at all" ----------------------------------------------------------- -- Renderering error messages for CannotPruneDependencies diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index 9df46a1c564..458bec3d8d6 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -136,7 +136,8 @@ installAction (applyFlagDefaults -> (configFlags, configExFlags, installFlags, h tmpDir packageSpecifiers - let targetSelectors = TargetPackageName <$> packageNames + let targetSelectors = [ TargetPackageNamed pn Nothing + | pn <- packageNames ] buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 275cd398414..f93c1b55629 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -506,8 +506,9 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem | otherwise = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) - checkTarget bt@(TargetPackageName pkgname) - | Just ats <- Map.lookup pkgname availableTargetsByPackageName + checkTarget bt@(TargetPackageNamed pkgname mkfilter) + | Just ats <- fmap (maybe id filterTargetsKind mkfilter) + $ Map.lookup pkgname availableTargetsByPackageName = case selectPackageTargets bt ats of Left e -> Left e Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) @@ -529,8 +530,8 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem availableTargetsByComponent `Map.union` availableTargetsEmptyPackages availableTargetsByPackageName = Map.mapKeysWith - (++) packageName - availableTargetsByPackage + (++) packageName + availableTargetsByPackage -- Add in all the empty packages. These do not appear in the -- availableTargetsByComponent map, since that only contains components diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index fd56c94a891..1d37924f321 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -37,8 +37,7 @@ module Distribution.Client.TargetSelector ( ) where import Distribution.Package - ( Package(..), PackageId - , PackageName, packageName, mkPackageName ) + ( Package(..), PackageId, PackageName, packageName ) import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..) ) @@ -149,6 +148,12 @@ data TargetSelector = -- TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + -- | A package within the project speciied by name. This includes the + -- @extra-packages@ from the @cabal.project@ file, and does not include + -- normal local directory package. It needs further processing to resolve. + -- + | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + -- | All packages, or all components of a particular kind in all packages. -- | TargetAllPackages (Maybe ComponentKindFilter) @@ -156,12 +161,6 @@ data TargetSelector = -- | A specific component in a package. -- | TargetComponent PackageId ComponentName SubComponentTarget - - -- | A named package, but not a known local package. It could for example - -- resolve to a dependency of a local package or to a package from - -- hackage. Either way, it requires further processing to resolve. - -- - | TargetPackageName PackageName deriving (Eq, Ord, Show, Generic) -- | Does this 'TargetPackage' selector arise from syntax referring to a @@ -358,12 +357,13 @@ showTargetSelectorKind bt = case bt of TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" + TargetPackageNamed _ Nothing -> "named-package" + TargetPackageNamed _ (Just _) -> "named-package:filter" TargetAllPackages Nothing -> "all-packages" TargetAllPackages (Just _) -> "all-packages:filter" TargetComponent _ _ WholeComponent -> "component" TargetComponent _ _ ModuleTarget{} -> "module" TargetComponent _ _ FileTarget{} -> "file" - TargetPackageName{} -> "package name" -- ------------------------------------------------------------ @@ -469,8 +469,6 @@ resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = Unambiguous target -> Right target None errs - | TargetStringFileStatus1 str _ <- targetStrStatus - , validPackageName str -> Right (TargetPackageName (mkPackageName str)) | projectIsEmpty -> Left TargetSelectorNoTargetsInProject | otherwise -> Left (classifyMatchErrors errs) @@ -949,9 +947,13 @@ syntaxForm1Package pinfo = case p of KnownPackage{pinfoId} -> return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) where render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus1 (dispP p) noFileStatus] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus1 (dispPN pn) noFileStatus] render _ = [] -- | Syntax: component @@ -1052,9 +1054,13 @@ syntaxForm2PackageFilter ps = case p of KnownPackage{pinfoId} -> return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) where render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] render _ = [] -- | Syntax: pkg : package name @@ -1070,9 +1076,13 @@ syntaxForm2NamespacePackage pinfo = case p of KnownPackage{pinfoId} -> return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) where render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] render _ = [] -- | Syntax: package : component @@ -1094,6 +1104,7 @@ syntaxForm2PackageComponent ps = return (TargetComponent pinfoId (cinfoName c) WholeComponent) --TODO: the error here ought to say there's no component by that name in -- this package, and name the package + KnownPackageName _pn -> mzero where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] @@ -1133,6 +1144,7 @@ syntaxForm2PackageModule ps = let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str2 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName _pn -> mzero where render (TargetComponent p _c (ModuleTarget m)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] @@ -1174,6 +1186,7 @@ syntaxForm2PackageFile ps = orNoThingIn "package" (display (packageName pinfoId)) $ do (filepath, c) <- matchComponentFile pinfoComponents str2 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName _pn -> mzero where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1242,9 +1255,13 @@ syntaxForm3MetaNamespacePackage pinfo = case p of KnownPackage{pinfoId} -> return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) + KnownPackageName pn -> + return (TargetPackageNamed pn Nothing) where render (TargetPackage TargetExplicitNamed [p] Nothing) = [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] + render (TargetPackageNamed pn Nothing) = + [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] render _ = [] -- | Syntax: package : namespace : component @@ -1265,6 +1282,7 @@ syntaxForm3PackageKindComponent ps = orNoThingIn "package" (display (packageName pinfoId)) $ do c <- matchComponentKindAndName pinfoComponents ckind str3 return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName _pn -> mzero where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] @@ -1291,6 +1309,7 @@ syntaxForm3PackageComponentModule ps = let ms = cinfoModules c m <- matchModuleName ms str3 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName _pn -> mzero where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] @@ -1336,6 +1355,7 @@ syntaxForm3PackageComponentFile ps = orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName _pn -> mzero where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] @@ -1370,9 +1390,13 @@ syntaxForm3NamespacePackageFilter ps = case p of KnownPackage{pinfoId} -> return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) where render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] render _ = [] -- @@ -1388,9 +1412,13 @@ syntaxForm4MetaNamespacePackageFilter ps = case p of KnownPackage{pinfoId} -> return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) + KnownPackageName pn -> + return (TargetPackageNamed pn (Just kfilter)) where render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] + render (TargetPackageNamed pn (Just kfilter)) = + [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] render _ = [] -- | Syntax: :pkg : package : namespace : component @@ -1411,6 +1439,7 @@ syntaxForm5MetaNamespacePackageKindComponent ps = orNoThingIn "package" (display (packageName pinfoId)) $ do c <- matchComponentKindAndName pinfoComponents ckind str5 return (TargetComponent pinfoId (cinfoName c) WholeComponent) + KnownPackageName _pn -> mzero where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] @@ -1439,6 +1468,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = let ms = cinfoModules c m <- matchModuleName ms str7 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) + KnownPackageName _pn -> mzero where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus7 "" "pkg" (dispP p) @@ -1468,6 +1498,7 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = orNoThingIn "component" (cinfoStrName c) $ do (filepath,_) <- matchComponentFile [c] str7 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) + KnownPackageName _pn -> mzero where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus7 "" "pkg" (dispP p) @@ -1541,6 +1572,9 @@ syntaxForm7 render f = dispP :: Package p => p -> String dispP = display . packageName +dispPN :: PackageName -> String +dispPN = display + dispC :: Package p => p -> ComponentName -> String dispC = componentStringName @@ -1571,12 +1605,16 @@ data KnownTargets = KnownTargets { } deriving Show -data KnownPackage = KnownPackage { +data KnownPackage = + KnownPackage { pinfoId :: PackageId, pinfoDirectory :: Maybe (FilePath, FilePath), pinfoPackageFile :: Maybe (FilePath, FilePath), pinfoComponents :: [KnownComponent] } + | KnownPackageName { + pinfoName :: PackageName + } deriving Show data KnownComponent = KnownComponent { @@ -1595,6 +1633,7 @@ type ComponentStringName = String knownPackageName :: KnownPackage -> PackageName knownPackageName KnownPackage{pinfoId} = packageName pinfoId +knownPackageName KnownPackageName{pinfoName} = pinfoName emptyKnownTargets :: KnownTargets emptyKnownTargets = KnownTargets [] [] [] [] [] [] @@ -1612,9 +1651,9 @@ getKnownTargets dirActions@DirActions{..} pkgs = do knownPackagesAll = pinfo, knownPackagesPrimary = ppinfo, knownPackagesOther = opinfo, - knownComponentsAll = concatMap pinfoComponents pinfo, - knownComponentsPrimary = concatMap pinfoComponents ppinfo, - knownComponentsOther = concatMap pinfoComponents opinfo + knownComponentsAll = allComponentsIn pinfo, + knownComponentsPrimary = allComponentsIn ppinfo, + knownComponentsOther = allComponentsIn opinfo } where selectPrimaryPackage :: FilePath @@ -1625,6 +1664,8 @@ getKnownTargets dirActions@DirActions{..} pkgs = do isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } | dir == cwd = True isPkgDirCwd _ = False + allComponentsIn ps = + [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m From 493f5fdca2bef7241542c4a40f674294b6180d9c Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sun, 5 Nov 2017 19:39:50 +0000 Subject: [PATCH 10/18] Plumb extra-packages through to TargetSpecifier Via the new KnownPackage and TargetPackageNamed stuff. --- cabal-install/Distribution/Client/TargetSelector.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 1d37924f321..18c4153a360 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -1643,8 +1643,7 @@ getKnownTargets :: (Applicative m, Monad m) -> [PackageSpecifier (SourcePackage (PackageLocation a))] -> m KnownTargets getKnownTargets dirActions@DirActions{..} pkgs = do - pinfo <- sequence [ collectKnownPackageInfo dirActions pkg - | SpecificSourcePackage pkg <- pkgs ] + pinfo <- mapM (collectKnownPackageInfo dirActions) pkgs cwd <- getCurrentDirectory let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo return KnownTargets { @@ -1669,13 +1668,15 @@ getKnownTargets dirActions@DirActions{..} pkgs = do collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m - -> SourcePackage (PackageLocation a) + -> PackageSpecifier (SourcePackage (PackageLocation a)) -> m KnownPackage +collectKnownPackageInfo _ (NamedPackage pkgname _props) = + return (KnownPackageName pkgname) collectKnownPackageInfo dirActions@DirActions{..} - SourcePackage { + (SpecificSourcePackage SourcePackage { packageDescription = pkg, packageSource = loc - } = do + }) = do (pkgdir, pkgfile) <- case loc of --TODO: local tarballs, remote tarballs etc From 2f8abd74c2a95d21825430bff6dbfa46d7f7afaa Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 6 Nov 2017 22:49:17 +0000 Subject: [PATCH 11/18] Refactor: split a util out of resolveTargets Easier to understand and document when it's a top level function. --- .../Client/ProjectOrchestration.hs | 60 ++++++++++++++----- 1 file changed, 44 insertions(+), 16 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index f93c1b55629..0e384e0b9a6 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -459,6 +459,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem (problems, _) -> Left problems where + AvailableTargetIndexes{..} = availableTargetIndexes installPlan -- TODO [required eventually] currently all build targets refer to packages -- inside the project. Ultimately this has to be generalised to allow -- referring to other packages and targets. @@ -467,7 +468,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem -- We can ask to build any whole package, project-local or a dependency checkTarget bt@(TargetPackage _ [pkgid] mkfilter) | Just ats <- fmap (maybe id filterTargetsKind mkfilter) - $ Map.lookup pkgid availableTargetsByPackage + $ Map.lookup pkgid availableTargetsByPackageId = case selectPackageTargets bt ats of Left e -> Left e Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) @@ -485,14 +486,15 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem checkTarget bt@(TargetAllPackages mkfilter) = let ats = maybe id filterTargetsKind mkfilter $ filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackage) + $ concat (Map.elems availableTargetsByPackageId) in case selectPackageTargets bt ats of Left e -> Left e Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) | (unitid, cname) <- ts ] checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- Map.lookup (pkgid, cname) availableTargetsByComponent + | Just ats <- Map.lookup (pkgid, cname) + availableTargetsByPackageIdAndComponentName = case partitionEithers (map (selectComponentTarget pkgid cname subtarget) ats) of (e:_,_) -> Left e @@ -500,7 +502,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem | let ctarget = ComponentTarget cname subtarget , (unitid, _) <- ts ] - | Map.member pkgid availableTargetsByPackage + | Map.member pkgid availableTargetsByPackageId = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname)) | otherwise @@ -520,18 +522,44 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem --TODO: check if the package is in hackage and return different -- error cases here so the commands can handle things appropriately - availableTargetsByPackage :: Map PackageId [AvailableTarget (UnitId, ComponentName)] - availableTargetsByPackageName :: Map PackageName [AvailableTarget (UnitId, ComponentName)] - availableTargetsByComponent :: Map (PackageId, ComponentName) [AvailableTarget (UnitId, ComponentName)] - - availableTargetsByComponent = availableTargets installPlan - availableTargetsByPackage = Map.mapKeysWith - (++) (\(pkgid, _cname) -> pkgid) - availableTargetsByComponent - `Map.union` availableTargetsEmptyPackages - availableTargetsByPackageName = Map.mapKeysWith - (++) packageName - availableTargetsByPackage + +data AvailableTargetIndexes = AvailableTargetIndexes { + availableTargetsByPackageIdAndComponentName + :: AvailableTargetsMap (PackageId, ComponentName), + + availableTargetsByPackageId + :: AvailableTargetsMap PackageId, + + availableTargetsByPackageName + :: AvailableTargetsMap PackageName + } +type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] + +-- We define a bunch of indexes to help 'resolveTargets' with resolving +-- 'TargetSelector's to specific 'UnitId's. +-- +-- They are all derived from the 'availableTargets' index. +-- The 'availableTargetsByPackageIdAndComponentName' is just that main index, +-- while the others are derived by re-grouping on the index key. +-- +-- They are all constructed lazily because they are not necessarily all used. +-- +availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes +availableTargetIndexes installPlan = AvailableTargetIndexes{..} + where + availableTargetsByPackageIdAndComponentName = + availableTargets installPlan + + availableTargetsByPackageId = + Map.mapKeysWith + (++) (\(pkgid, _cname) -> pkgid) + availableTargetsByPackageIdAndComponentName + `Map.union` availableTargetsEmptyPackages + + availableTargetsByPackageName = + Map.mapKeysWith + (++) packageName + availableTargetsByPackageId -- Add in all the empty packages. These do not appear in the -- availableTargetsByComponent map, since that only contains components From b0f7a9b6babd9df6c099cd02a9214009946ab719 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Wed, 8 Nov 2017 09:32:49 +0000 Subject: [PATCH 12/18] Remove reundant args of selectComponentTarget functions The PackageId and ComponentName are already part of the existing AvailableTarget record argument. We need to eliminate this redundancy because for new kinds of target selectors we will not have the PackageId and ComponentName from the selector, only from the AvailableTarget selected. --- cabal-install/Distribution/Client/CmdBench.hs | 15 +++++++++------ cabal-install/Distribution/Client/CmdBuild.hs | 6 +++--- cabal-install/Distribution/Client/CmdHaddock.hs | 6 +++--- cabal-install/Distribution/Client/CmdInstall.hs | 6 +++--- cabal-install/Distribution/Client/CmdRepl.hs | 6 +++--- cabal-install/Distribution/Client/CmdRun.hs | 15 +++++++++------ cabal-install/Distribution/Client/CmdTest.hs | 15 +++++++++------ .../Distribution/Client/ProjectOrchestration.hs | 15 +++++++++------ cabal-install/tests/IntegrationTests2.hs | 6 +++--- 9 files changed, 51 insertions(+), 39 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdBench.hs b/cabal-install/Distribution/Client/CmdBench.hs index f408323cf29..e7eaad15cec 100644 --- a/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal-install/Distribution/Client/CmdBench.hs @@ -162,17 +162,20 @@ selectPackageTargets targetSelector targets -- For the @bench@ command we just need to check it is a benchmark, in addition -- to the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget@WholeComponent t +selectComponentTarget subtarget@WholeComponent t | CBenchName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ - selectComponentTargetBasic pkgid cname subtarget t + selectComponentTargetBasic subtarget t | otherwise - = Left (TargetProblemComponentNotBenchmark pkgid cname) + = Left (TargetProblemComponentNotBenchmark (availableTargetPackageId t) + (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _ - = Left (TargetProblemIsSubComponent pkgid cname subtarget) +selectComponentTarget subtarget t + = Left (TargetProblemIsSubComponent (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @bench@ command. diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index d907d4d4338..019957b5375 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -159,11 +159,11 @@ selectPackageTargets targetSelector targets -- -- For the @build@ command we just need the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index 4e7dcb94401..548a926c988 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -165,11 +165,11 @@ selectPackageTargets haddockFlags targetSelector targets -- For the @haddock@ command we just need the basic checks on being buildable -- etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index 458bec3d8d6..e1134efb902 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -299,11 +299,11 @@ selectPackageTargets targetSelector targets -- -- For the @build@ command we just need the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index ca11df9ebb2..e6f6666e21f 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -215,11 +215,11 @@ selectPackageTargets targetSelector targets -- -- For the @repl@ command we just need the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget = +selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right - . selectComponentTargetBasic pkgid cname subtarget + . selectComponentTargetBasic subtarget -- | The various error conditions that can occur when matching a diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index df92e61f186..b574e207caf 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -323,17 +323,20 @@ selectPackageTargets targetSelector targets -- For the @run@ command we just need to check it is a executable, in addition -- to the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget@WholeComponent t +selectComponentTarget subtarget@WholeComponent t | CExeName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ - selectComponentTargetBasic pkgid cname subtarget t + selectComponentTargetBasic subtarget t | otherwise - = Left (TargetProblemComponentNotExe pkgid cname) + = Left (TargetProblemComponentNotExe (availableTargetPackageId t) + (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _ - = Left (TargetProblemIsSubComponent pkgid cname subtarget) +selectComponentTarget subtarget t + = Left (TargetProblemIsSubComponent (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @run@ command. diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index 78730f567eb..68d8c2c24cb 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -165,17 +165,20 @@ selectPackageTargets targetSelector targets -- For the @test@ command we just need to check it is a test-suite, in addition -- to the basic checks on being buildable etc. -- -selectComponentTarget :: PackageId -> ComponentName -> SubComponentTarget +selectComponentTarget :: SubComponentTarget -> AvailableTarget k -> Either TargetProblem k -selectComponentTarget pkgid cname subtarget@WholeComponent t +selectComponentTarget subtarget@WholeComponent t | CTestName _ <- availableTargetComponentName t = either (Left . TargetProblemCommon) return $ - selectComponentTargetBasic pkgid cname subtarget t + selectComponentTargetBasic subtarget t | otherwise - = Left (TargetProblemComponentNotTest pkgid cname) + = Left (TargetProblemComponentNotTest (availableTargetPackageId t) + (availableTargetComponentName t)) -selectComponentTarget pkgid cname subtarget _ - = Left (TargetProblemIsSubComponent pkgid cname subtarget) +selectComponentTarget subtarget t + = Left (TargetProblemIsSubComponent (availableTargetPackageId t) + (availableTargetComponentName t) + subtarget) -- | The various error conditions that can occur when matching a -- 'TargetSelector' against 'AvailableTarget's for the @test@ command. diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 0e384e0b9a6..182cb78e5de 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -431,7 +431,7 @@ resolveTargets :: forall err. (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) @@ -496,7 +496,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem | Just ats <- Map.lookup (pkgid, cname) availableTargetsByPackageIdAndComponentName = case partitionEithers - (map (selectComponentTarget pkgid cname subtarget) ats) of + (map (selectComponentTarget subtarget) ats) of (e:_,_) -> Left e ([],ts) -> Right [ (unitid, ctarget) | let ctarget = ComponentTarget cname subtarget @@ -623,12 +623,15 @@ forgetTargetsDetail = map forgetTargetDetail -- buildable and isn't a test suite or benchmark that is disabled. This -- can also be used to do these basic checks as part of a custom impl that -- -selectComponentTargetBasic :: PackageId - -> ComponentName - -> SubComponentTarget +selectComponentTargetBasic :: SubComponentTarget -> AvailableTarget k -> Either TargetProblemCommon k -selectComponentTargetBasic pkgid cname subtarget AvailableTarget {..} = +selectComponentTargetBasic subtarget + AvailableTarget { + availableTargetPackageId = pkgid, + availableTargetComponentName = cname, + availableTargetStatus + } = case availableTargetStatus of TargetDisabledByUser -> Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index d5caa118451..40d4b3e3f2f 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -1218,7 +1218,7 @@ assertProjectDistinctTargets :: forall err. (Eq err, Show err) => ElaboratedInstallPlan -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) -> [TargetSelector] -> [(UnitId, ComponentName)] @@ -1250,7 +1250,7 @@ assertProjectTargetProblems -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) @@ -1274,7 +1274,7 @@ assertTargetProblems :: forall err. (Eq err, Show err) => ElaboratedInstallPlan -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. PackageId -> ComponentName -> SubComponentTarget -> AvailableTarget k -> Either err k ) + -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) -> (TargetProblemCommon -> err) -> [(TargetSelector -> err, TargetSelector)] -> Assertion From ca5d7f4bd581300a7b76d38f318a41c4f92f936e Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Fri, 10 Nov 2017 22:49:14 +0000 Subject: [PATCH 13/18] A bit of refactoring in resolveTargets Improve clarity and reduce code duplication a bit. --- .../Client/ProjectOrchestration.hs | 76 +++++++++++-------- 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 182cb78e5de..dac431ad520 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -439,7 +439,7 @@ resolveTargets :: forall err. -> [TargetSelector] -> Either [err] TargetsMap resolveTargets selectPackageTargets selectComponentTarget liftProblem - installPlan targetSelectors = + installPlan = --TODO: [required eventually] -- we cannot resolve names of packages other than those that are -- directly in the current plan. We ought to keep a set of the known @@ -447,18 +447,19 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem -- really need that until we can do something sensible with packages -- outside of the project. - case partitionEithers - [ fmap ((,) targetSelector) (checkTarget targetSelector) - | targetSelector <- targetSelectors ] of - ([], targets) -> Right - . Map.map nubComponentTargets - $ Map.fromListWith (++) - [ (uid, [(ct, ts)]) - | (ts, cts) <- targets - , (uid, ct) <- cts ] - - (problems, _) -> Left problems + fmap mkTargetsMap + . checkErrors + . map (\ts -> (,) ts <$> checkTarget ts) where + mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] + -> TargetsMap + mkTargetsMap targets = + Map.map nubComponentTargets + $ Map.fromListWith (++) + [ (uid, [(ct, ts)]) + | (ts, cts) <- targets + , (uid, ct) <- cts ] + AvailableTargetIndexes{..} = availableTargetIndexes installPlan -- TODO [required eventually] currently all build targets refer to packages -- inside the project. Ultimately this has to be generalised to allow @@ -469,10 +470,8 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem checkTarget bt@(TargetPackage _ [pkgid] mkfilter) | Just ats <- fmap (maybe id filterTargetsKind mkfilter) $ Map.lookup pkgid availableTargetsByPackageId - = case selectPackageTargets bt ats of - Left e -> Left e - Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) - | (unitid, cname) <- ts ] + = fmap (componentTargets WholeComponent) + $ selectPackageTargets bt ats | otherwise = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) @@ -484,23 +483,17 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem -- will need handling properly when we do add support. checkTarget bt@(TargetAllPackages mkfilter) = - let ats = maybe id filterTargetsKind mkfilter - $ filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackageId) - in case selectPackageTargets bt ats of - Left e -> Left e - Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) - | (unitid, cname) <- ts ] + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) checkTarget (TargetComponent pkgid cname subtarget) | Just ats <- Map.lookup (pkgid, cname) availableTargetsByPackageIdAndComponentName - = case partitionEithers - (map (selectComponentTarget subtarget) ats) of - (e:_,_) -> Left e - ([],ts) -> Right [ (unitid, ctarget) - | let ctarget = ComponentTarget cname subtarget - , (unitid, _) <- ts ] + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats | Map.member pkgid availableTargetsByPackageId = Left (liftProblem (TargetProblemNoSuchComponent pkgid cname)) @@ -511,10 +504,9 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem checkTarget bt@(TargetPackageNamed pkgname mkfilter) | Just ats <- fmap (maybe id filterTargetsKind mkfilter) $ Map.lookup pkgname availableTargetsByPackageName - = case selectPackageTargets bt ats of - Left e -> Left e - Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent) - | (unitid, cname) <- ts ] + = fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats | otherwise = Left (liftProblem (TargetNotInProject pkgname)) @@ -522,6 +514,24 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem --TODO: check if the package is in hackage and return different -- error cases here so the commands can handle things appropriately + componentTargets :: SubComponentTarget + -> [(b, ComponentName)] + -> [(b, ComponentTarget)] + componentTargets subtarget = + map (fmap (\cname -> ComponentTarget cname subtarget)) + + selectComponentTargets :: SubComponentTarget + -> [AvailableTarget k] + -> Either err [k] + selectComponentTargets subtarget = + either (Left . head) Right + . checkErrors + . map (selectComponentTarget subtarget) + + checkErrors :: [Either e a] -> Either [e] [a] + checkErrors = (\(es, xs) -> if null es then Right xs else Left es) + . partitionEithers + data AvailableTargetIndexes = AvailableTargetIndexes { availableTargetsByPackageIdAndComponentName From 33fbff8926116ab3af467f8c0dad5a8802dadb0d Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Sun, 5 Nov 2017 19:51:56 +0000 Subject: [PATCH 14/18] Add target support for components of extra-packages For local packages we have the full .cabal file so we know exactly what components are available. For packages named in extra-packages we do not know the components until after solving, which is after the target parsing stage. So this adds partial support parsing targets that refer to components of extra-packages, even though we do not yet know if the component exists. --- .../Distribution/Client/CmdErrorMessages.hs | 56 ++++++-- .../Client/ProjectOrchestration.hs | 48 ++++++- .../Distribution/Client/TargetSelector.hs | 127 +++++++++++++++--- 3 files changed, 199 insertions(+), 32 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal-install/Distribution/Client/CmdErrorMessages.hs index 126242e966d..fc5e991d0bf 100644 --- a/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -12,7 +12,7 @@ import Distribution.Client.TargetSelector ( ComponentKindFilter, componentKind, showTargetSelector ) import Distribution.Package - ( packageId, packageName ) + ( packageId, PackageName, packageName ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Solver.Types.OptionalStanza @@ -108,17 +108,24 @@ renderTargetSelector (TargetAllPackages (Just kfilter)) = "all the " ++ renderComponentKind Plural kfilter ++ " in the project" -renderTargetSelector (TargetComponent pkgid CLibName WholeComponent) = - "the library in the package " ++ display pkgid +renderTargetSelector (TargetComponent pkgid cname subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName (packageName pkgid) cname -renderTargetSelector (TargetComponent _pkgid cname WholeComponent) = - "the " ++ showComponentName cname +renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) = + renderSubComponentTarget subtarget ++ "the component " ++ display ucname + ++ " in the package " ++ display pkgname -renderTargetSelector (TargetComponent _pkgid cname (FileTarget filename)) = - "the file " ++ filename ++ " in the " ++ showComponentName cname +renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) = + renderSubComponentTarget subtarget ++ "the " + ++ renderComponentName pkgname cname -renderTargetSelector (TargetComponent _pkgid cname (ModuleTarget modname)) = - "the module " ++ display modname ++ " in the " ++ showComponentName cname +renderSubComponentTarget :: SubComponentTarget -> String +renderSubComponentTarget WholeComponent = "" +renderSubComponentTarget (FileTarget filename) = + "the file " ++ filename ++ "in " +renderSubComponentTarget (ModuleTarget modname) = + "the module" ++ display modname ++ "in " renderOptionalStanza :: Plural -> OptionalStanza -> String @@ -139,20 +146,31 @@ targetSelectorPluralPkgs :: TargetSelector -> Plural targetSelectorPluralPkgs (TargetAllPackages _) = Plural targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular -targetSelectorPluralPkgs (TargetComponent _ _ _) = Singular +targetSelectorPluralPkgs TargetComponent{} = Singular +targetSelectorPluralPkgs TargetComponentUnknown{} = Singular -- | Does the 'TargetSelector' refer to packages or to components? targetSelectorRefersToPkgs :: TargetSelector -> Bool targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter -targetSelectorRefersToPkgs (TargetComponent _ _ _) = False +targetSelectorRefersToPkgs TargetComponent{} = False +targetSelectorRefersToPkgs TargetComponentUnknown{} = False targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter -targetSelectorFilter (TargetComponent _ _ _) = Nothing +targetSelectorFilter TargetComponent{} = Nothing +targetSelectorFilter TargetComponentUnknown{} = Nothing + +renderComponentName :: PackageName -> ComponentName -> String +renderComponentName pkgname CLibName = "library " ++ display pkgname +renderComponentName _ (CSubLibName name) = "library " ++ display name +renderComponentName _ (CFLibName name) = "foreign library " ++ display name +renderComponentName _ (CExeName name) = "executable " ++ display name +renderComponentName _ (CTestName name) = "test suite " ++ display name +renderComponentName _ (CBenchName name) = "benchmark " ++ display name renderComponentKind :: Plural -> ComponentKind -> String renderComponentKind Singular ckind = case ckind of @@ -222,6 +240,18 @@ renderTargetProblemCommon verb (TargetOptionalStanzaDisabledBySolver pkgid cname where compkinds = renderComponentKind Plural (componentKind cname) +renderTargetProblemCommon verb (TargetProblemUnknownComponent pkgname ecname) = + "Cannot " ++ verb ++ " the " + ++ (case ecname of + Left ucname -> "component " ++ display ucname + Right cname -> renderComponentName pkgname cname) + ++ " from the package " ++ display pkgname + ++ ", because the package does not contain a " + ++ (case ecname of + Left _ -> "component" + Right cname -> renderComponentKind Singular (componentKind cname)) + ++ " with that name." + renderTargetProblemCommon verb (TargetProblemNoSuchPackage pkgid) = "Internal error when trying to " ++ verb ++ " the package " ++ display pkgid ++ ". The package is not in the set of available targets " @@ -331,6 +361,8 @@ renderTargetProblemNoTargets verb targetSelector = ++ renderComponentKind Plural kfilter reason ts@TargetComponent{} = error $ "renderTargetProblemNoTargets: " ++ show ts + reason ts@TargetComponentUnknown{} = + error $ "renderTargetProblemNoTargets: " ++ show ts ----------------------------------------------------------- -- Renderering error messages for CannotPruneDependencies diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index dac431ad520..e0779fb5a0f 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -114,6 +114,10 @@ import Distribution.Client.TargetSelector import Distribution.Client.DistDirLayout import Distribution.Client.Config (defaultCabalDir) import Distribution.Client.Setup hiding (packageName) +import Distribution.Types.ComponentName + ( componentNameString ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, packageNameToUnqualComponentName ) import Distribution.Solver.Types.OptionalStanza @@ -501,6 +505,23 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem | otherwise = Left (liftProblem (TargetProblemNoSuchPackage pkgid)) + checkTarget (TargetComponentUnknown pkgname ecname subtarget) + | Just ats <- case ecname of + Left ucname -> + Map.lookup (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup (pkgname, cname) + availableTargetsByPackageNameAndComponentName + = fmap (componentTargets subtarget) + $ selectComponentTargets subtarget ats + + | Map.member pkgname availableTargetsByPackageName + = Left (liftProblem (TargetProblemUnknownComponent pkgname ecname)) + + | otherwise + = Left (liftProblem (TargetNotInProject pkgname)) + checkTarget bt@(TargetPackageNamed pkgname mkfilter) | Just ats <- fmap (maybe id filterTargetsKind mkfilter) $ Map.lookup pkgname availableTargetsByPackageName @@ -541,7 +562,13 @@ data AvailableTargetIndexes = AvailableTargetIndexes { :: AvailableTargetsMap PackageId, availableTargetsByPackageName - :: AvailableTargetsMap PackageName + :: AvailableTargetsMap PackageName, + + availableTargetsByPackageNameAndComponentName + :: AvailableTargetsMap (PackageName, ComponentName), + + availableTargetsByPackageNameAndUnqualComponentName + :: AvailableTargetsMap (PackageName, UnqualComponentName) } type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)] @@ -571,6 +598,23 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..} (++) packageName availableTargetsByPackageId + availableTargetsByPackageNameAndComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> (packageName pkgid, cname)) + availableTargetsByPackageIdAndComponentName + + availableTargetsByPackageNameAndUnqualComponentName = + Map.mapKeysWith + (++) (\(pkgid, cname) -> let pname = packageName pkgid + cname' = unqualComponentName pname cname + in (pname, cname')) + availableTargetsByPackageIdAndComponentName + where + unqualComponentName :: PackageName -> ComponentName -> UnqualComponentName + unqualComponentName pkgname = + fromMaybe (packageNameToUnqualComponentName pkgname) + . componentNameString + -- Add in all the empty packages. These do not appear in the -- availableTargetsByComponent map, since that only contains components -- so packages with no components are invisible from that perspective. @@ -664,6 +708,8 @@ data TargetProblemCommon | TargetComponentNotBuildable PackageId ComponentName SubComponentTarget | TargetOptionalStanzaDisabledByUser PackageId ComponentName SubComponentTarget | TargetOptionalStanzaDisabledBySolver PackageId ComponentName SubComponentTarget + | TargetProblemUnknownComponent PackageName + (Either UnqualComponentName ComponentName) -- The target matching stuff only returns packages local to the project, -- so these lookups should never fail, but if 'resolveTargets' is called diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 18c4153a360..76cc0c2a123 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -38,7 +38,9 @@ module Distribution.Client.TargetSelector ( import Distribution.Package ( Package(..), PackageId, PackageName, packageName ) -import Distribution.Types.UnqualComponentName ( unUnqualComponentName ) +import Distribution.Types.UnqualComponentName + ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName + , packageNameToUnqualComponentName ) import Distribution.Client.Types ( PackageLocation(..), PackageSpecifier(..) ) @@ -61,7 +63,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Types.ForeignLib import Distribution.Text - ( display, simpleParse ) + ( Text, display, simpleParse ) import Distribution.Simple.Utils ( die', lowercase, ordNub ) import Distribution.Client.Utils @@ -161,6 +163,13 @@ data TargetSelector = -- | A specific component in a package. -- | TargetComponent PackageId ComponentName SubComponentTarget + + -- | A component in a package, but where it cannot be verified that the + -- package has such a component. + -- + | TargetComponentUnknown PackageName + (Either UnqualComponentName ComponentName) + SubComponentTarget deriving (Eq, Ord, Show, Generic) -- | Does this 'TargetPackage' selector arise from syntax referring to a @@ -361,9 +370,12 @@ showTargetSelectorKind bt = case bt of TargetPackageNamed _ (Just _) -> "named-package:filter" TargetAllPackages Nothing -> "all-packages" TargetAllPackages (Just _) -> "all-packages:filter" - TargetComponent _ _ WholeComponent -> "component" - TargetComponent _ _ ModuleTarget{} -> "module" - TargetComponent _ _ FileTarget{} -> "file" + TargetComponent _ _ WholeComponent -> "component" + TargetComponent _ _ ModuleTarget{} -> "module" + TargetComponent _ _ FileTarget{} -> "file" + TargetComponentUnknown _ _ WholeComponent -> "unknown-component" + TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" + TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" -- ------------------------------------------------------------ @@ -1104,10 +1116,14 @@ syntaxForm2PackageComponent ps = return (TargetComponent pinfoId (cinfoName c) WholeComponent) --TODO: the error here ought to say there's no component by that name in -- this package, and name the package - KnownPackageName _pn -> mzero + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 in + return (TargetComponentUnknown pn (Left cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] + render (TargetComponentUnknown pn (Left cn) WholeComponent) = + [TargetStringFileStatus2 (dispPN pn) noFileStatus (display cn)] render _ = [] -- | Syntax: namespace : component @@ -1144,7 +1160,10 @@ syntaxForm2PackageModule ps = let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str2 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName _pn -> mzero + KnownPackageName pn -> do + m <- matchModuleNameUnknown str2 + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right CLibName) (ModuleTarget m)) where render (TargetComponent p _c (ModuleTarget m)) = [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] @@ -1186,7 +1205,10 @@ syntaxForm2PackageFile ps = orNoThingIn "package" (display (packageName pinfoId)) $ do (filepath, c) <- matchComponentFile pinfoComponents str2 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName _pn -> mzero + KnownPackageName pn -> + let filepath = str2 in + -- We assume the primary library component of the package: + return (TargetComponentUnknown pn (Right CLibName) (FileTarget filepath)) where render (TargetComponent p _c (FileTarget f)) = [TargetStringFileStatus2 (dispP p) noFileStatus f] @@ -1282,10 +1304,14 @@ syntaxForm3PackageKindComponent ps = orNoThingIn "package" (display (packageName pinfoId)) $ do c <- matchComponentKindAndName pinfoComponents ckind str3 return (TargetComponent pinfoId (cinfoName c) WholeComponent) - KnownPackageName _pn -> mzero + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] render _ = [] -- | Syntax: package : component : module @@ -1309,10 +1335,15 @@ syntaxForm3PackageComponentModule ps = let ms = cinfoModules c m <- matchModuleName ms str3 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName _pn -> mzero + KnownPackageName pn -> do + let cn = mkUnqualComponentName str2 + m <- matchModuleNameUnknown str3 + return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] + render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] render _ = [] -- | Syntax: namespace : component : module @@ -1355,10 +1386,15 @@ syntaxForm3PackageComponentFile ps = orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName _pn -> mzero + KnownPackageName pn -> + let cn = mkUnqualComponentName str2 + filepath = str3 in + return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] + render (TargetComponentUnknown pn (Left c) (FileTarget f)) = + [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] render _ = [] -- | Syntax: namespace : component : filename @@ -1439,10 +1475,14 @@ syntaxForm5MetaNamespacePackageKindComponent ps = orNoThingIn "package" (display (packageName pinfoId)) $ do c <- matchComponentKindAndName pinfoComponents ckind str5 return (TargetComponent pinfoId (cinfoName c) WholeComponent) - KnownPackageName _pn -> mzero + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in + return (TargetComponentUnknown pn (Right cn) WholeComponent) where render (TargetComponent p c WholeComponent) = [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] + render (TargetComponentUnknown pn (Right c) WholeComponent) = + [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] render _ = [] -- | Syntax: :pkg : package : namespace : component : module : module @@ -1468,12 +1508,19 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = let ms = cinfoModules c m <- matchModuleName ms str7 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) - KnownPackageName _pn -> mzero + KnownPackageName pn -> do + let cn = mkComponentName pn ckind (mkUnqualComponentName str2) + m <- matchModuleNameUnknown str7 + return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) where render (TargetComponent p c (ModuleTarget m)) = [TargetStringFileStatus7 "" "pkg" (dispP p) (dispCK c) (dispC p c) "module" (dispM m)] + render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "module" (dispM m)] render _ = [] -- | Syntax: :pkg : package : namespace : component : file : filename @@ -1498,12 +1545,19 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = orNoThingIn "component" (cinfoStrName c) $ do (filepath,_) <- matchComponentFile [c] str7 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) - KnownPackageName _pn -> mzero + KnownPackageName pn -> + let cn = mkComponentName pn ckind (mkUnqualComponentName str5) + filepath = str7 in + return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) where render (TargetComponent p c (FileTarget f)) = [TargetStringFileStatus7 "" "pkg" (dispP p) (dispCK c) (dispC p c) "file" f] + render (TargetComponentUnknown pn (Right c) (FileTarget f)) = + [TargetStringFileStatus7 "" "pkg" (dispPN pn) + (dispCK c) (dispC' pn c) + "file" f] render _ = [] @@ -1575,8 +1629,14 @@ dispP = display . packageName dispPN :: PackageName -> String dispPN = display -dispC :: Package p => p -> ComponentName -> String -dispC = componentStringName +dispC :: PackageId -> ComponentName -> String +dispC = componentStringName . packageName + +dispC' :: PackageName -> ComponentName -> String +dispC' = componentStringName + +dispCN :: UnqualComponentName -> String +dispCN = display dispK :: ComponentKind -> String dispK = showComponentKindShort @@ -1706,7 +1766,7 @@ collectKnownComponentInfo :: PackageDescription -> [KnownComponent] collectKnownComponentInfo pkg = [ KnownComponent { cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), + cinfoStrName = componentStringName (packageName pkg) (componentName c), cinfoPackageId = packageId pkg, cinfoSrcDirs = ordNub (hsSourceDirs bi), cinfoModules = ordNub (componentModules c), @@ -1718,8 +1778,8 @@ collectKnownComponentInfo pkg = , let bi = componentBuildInfo c ] -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg CLibName = display (packageName pkg) +componentStringName :: PackageName -> ComponentName -> ComponentStringName +componentStringName pkgname CLibName = display pkgname componentStringName _ (CSubLibName name) = unUnqualComponentName name componentStringName _ (CFLibName name) = unUnqualComponentName name componentStringName _ (CExeName name) = unUnqualComponentName name @@ -1993,6 +2053,13 @@ matchModuleNameAnd ms str = $ matchInexactly caseFold (display . fst) ms str +matchModuleNameUnknown :: String -> Match ModuleName +matchModuleNameUnknown str = + expecting "module" str + $ increaseConfidenceFor + $ matchParse str + + ------------------------------ -- Matching file targets -- @@ -2265,6 +2332,9 @@ matchInexactly cannonicalise key xs = -- the map of canonicalised keys to groups of inexact matches m' = Map.mapKeysWith (++) cannonicalise m +matchParse :: Text a => String -> Match a +matchParse = maybe mzero return . simpleParse + ------------------------------ -- Utils @@ -2273,6 +2343,25 @@ matchInexactly cannonicalise key xs = caseFold :: String -> String caseFold = lowercase +-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the +-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's +-- primary library from named private libraries. +-- +mkComponentName :: PackageName + -> ComponentKind + -> UnqualComponentName + -> ComponentName +mkComponentName pkgname ckind ucname = + case ckind of + LibKind + | packageNameToUnqualComponentName pkgname == ucname + -> CLibName + | otherwise -> CSubLibName ucname + FLibKind -> CFLibName ucname + ExeKind -> CExeName ucname + TestKind -> CTestName ucname + BenchKind -> CBenchName ucname + ------------------------------ -- Example inputs From e8a5ba082982f6be5fe5c1fe0d9752e7e876de5f Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 14 Nov 2017 00:09:44 +0000 Subject: [PATCH 15/18] Allow target selectors to refer to unknown packages This allows for referring to packages outside of the project, e.g. for cabal (new-)install to refer to packages from hackage. At the moment it still reports an error message that the package is not known, but this error is reported at an appropriate point where we could resolve the package name to a package from some wider context such as a hackage archive. --- .../Distribution/Client/TargetSelector.hs | 33 ++++++++++++++----- 1 file changed, 24 insertions(+), 9 deletions(-) diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index 76cc0c2a123..e26f7033c9d 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -150,22 +150,24 @@ data TargetSelector = -- TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) - -- | A package within the project speciied by name. This includes the - -- @extra-packages@ from the @cabal.project@ file, and does not include - -- normal local directory package. It needs further processing to resolve. + -- | A package specified by name. This may refer to @extra-packages@ from + -- the @cabal.project@ file, or a dependency of a known project package or + -- could refer to a package from a hackage archive. It needs further + -- context to resolve to a specific package. -- - | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + | TargetPackageNamed PackageName (Maybe ComponentKindFilter) -- | All packages, or all components of a particular kind in all packages. -- | TargetAllPackages (Maybe ComponentKindFilter) - -- | A specific component in a package. + -- | A specific component in a package within the project. -- | TargetComponent PackageId ComponentName SubComponentTarget -- | A component in a package, but where it cannot be verified that the - -- package has such a component. + -- package has such a component, or because the package is itself not + -- known. -- | TargetComponentUnknown PackageName (Either UnqualComponentName ComponentName) @@ -623,7 +625,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = Left ( originalMatch , [ (forgetFileStatus rendering, matches) | rendering <- matchRenderings - , let (Match Exact _ matches) = + , let (Match m _ matches) | m /= Inexact = memoisedMatches Map.! rendering ] ) @@ -638,6 +640,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = Match Exact _ [t'] | t == t' -> Just r Match Exact _ _ -> findUnambiguous t rs + Match Unknown _ _ -> findUnambiguous t rs Match Inexact _ _ -> internalError "Match Inexact" NoMatch _ _ -> internalError "NoMatch" @@ -1943,7 +1946,8 @@ matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackage pinfo = \str fstatus -> orNoThingIn "project" "" $ matchPackageName pinfo str - (matchPackageDir pinfo str fstatus + (matchPackageNameUnknown str + <|> matchPackageDir pinfo str fstatus <|> matchPackageFile pinfo str fstatus) @@ -1956,6 +1960,12 @@ matchPackageName ps = \str -> do matchInexactly caseFold (display . knownPackageName) ps str +matchPackageNameUnknown :: String -> Match KnownPackage +matchPackageNameUnknown str = do + pn <- matchParse str + unknownMatch (KnownPackageName pn) + + matchPackageDir :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage matchPackageDir ps = \str fstatus -> @@ -2146,7 +2156,9 @@ data Match a = NoMatch !Confidence [MatchError] -- prefer exact over inexact matches. The 'Ord' here is important: we try -- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. -- -data MatchClass = Inexact -- ^ Matches a known thing inexactly +data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package + -- name without it being a specific known package + | Inexact -- ^ Matches a known thing inexactly -- e.g. matches a known package case insensitively | Exact -- ^ Exactly matches a known thing, -- e.g. matches a known package case sensitively @@ -2268,6 +2280,9 @@ exactMatches xs = Match Exact 0 xs inexactMatches [] = mzero inexactMatches xs = Match Inexact 0 xs +unknownMatch :: a -> Match a +unknownMatch x = Match Unknown 0 [x] + tryEach :: [a] -> Match a tryEach = exactMatches From 4760f246f49c649a05cfef0073c2125c6a8e7eb1 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 14 Nov 2017 00:11:51 +0000 Subject: [PATCH 16/18] Remove a couple done TODOs for target selection --- cabal-install/Distribution/Client/ProjectOrchestration.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index e0779fb5a0f..6ed9793f216 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -465,9 +465,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem , (uid, ct) <- cts ] AvailableTargetIndexes{..} = availableTargetIndexes installPlan - -- TODO [required eventually] currently all build targets refer to packages - -- inside the project. Ultimately this has to be generalised to allow - -- referring to other packages and targets. + checkTarget :: TargetSelector -> Either err [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency @@ -531,7 +529,6 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem | otherwise = Left (liftProblem (TargetNotInProject pkgname)) - --TODO: check if the package is in the plan, even if it's not local --TODO: check if the package is in hackage and return different -- error cases here so the commands can handle things appropriately From 7996ed56a62325d02f003620439deb3e6c9f5e6d Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Mon, 20 Nov 2017 09:58:09 +0000 Subject: [PATCH 17/18] Fix compat for various ghc versions --- .../Client/ProjectOrchestration.hs | 7 +++--- .../Distribution/Client/TargetSelector.hs | 25 +++++-------------- 2 files changed, 9 insertions(+), 23 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 6ed9793f216..ddcc0c3bafd 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -94,6 +94,9 @@ module Distribution.Client.ProjectOrchestration ( cmdCommonHelpTextNewBuildBeta, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanning hiding ( pruneInstallPlanToTargets ) @@ -143,11 +146,7 @@ import Distribution.Simple.Compiler import qualified Data.Monoid as Mon import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Map (Map) -import Data.List -import Data.Maybe import Data.Either -import Control.Monad (void) import Control.Exception (Exception(..), throwIO, assert) import System.Exit (ExitCode(..), exitFailure) #ifdef MIN_VERSION_unix diff --git a/cabal-install/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index e26f7033c9d..8eebcbba758 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -36,6 +36,9 @@ module Distribution.Client.TargetSelector ( defaultDirActions, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Package ( Package(..), PackageId, PackageName, packageName ) import Distribution.Types.UnqualComponentName @@ -74,36 +77,19 @@ import Data.Either import Data.Function ( on ) import Data.List - ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) -import Data.Maybe - ( maybeToList ) + ( stripPrefix, partition, groupBy ) import Data.Ord ( comparing ) -import Distribution.Compat.Binary (Binary) -import GHC.Generics (Generic) -#if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Lazy as Map.Lazy import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) -#else -import qualified Data.Map as Map.Lazy -import qualified Data.Map as Map -import Data.Map (Map) -#endif import qualified Data.Set as Set import Control.Arrow ((&&&)) import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative (Applicative(..), (<$>)) -#endif -import Control.Applicative (Alternative(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import Distribution.ParseUtils ( readPToMaybe ) -import Data.Char - ( isSpace, isAlphaNum ) import System.FilePath as FilePath ( takeExtension, dropExtension , splitDirectories, joinPath, splitPath ) @@ -1014,7 +1000,8 @@ syntaxForm1File ps = -- all the other forms we don't require that. syntaxForm1 render $ \str1 fstatus1 -> expecting "file" str1 $ do - (pkgfile, KnownPackage{pinfoId, pinfoComponents}) + (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) + -- always returns the KnownPackage case <- matchPackageDirectoryPrefix ps fstatus1 orNoThingIn "package" (display (packageName pinfoId)) $ do (filepath, c) <- matchComponentFile pinfoComponents pkgfile From 8ffed56523c26367b38860fca1b480c203c82509 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 21 Nov 2017 23:33:00 +0000 Subject: [PATCH 18/18] Update the test CLI output in one case Trivial change, but actually a wording improvement. --- .../PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out index 629f54fc13d..49cbf7f6203 100644 --- a/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out +++ b/cabal-testsuite/PackageTests/NewBuild/CmdRun/ExeAndLib/cabal.out @@ -7,4 +7,4 @@ Configuring executable 'foo' for ExeAndLib-1.0.. Preprocessing executable 'foo' for ExeAndLib-1.0.. Building executable 'foo' for ExeAndLib-1.0.. # cabal new-run -cabal: The run command is for running executables, but the target 'ExeAndLib' refers to the library in the package ExeAndLib-1.0 from the package ExeAndLib-1.0. +cabal: The run command is for running executables, but the target 'ExeAndLib' refers to the library ExeAndLib from the package ExeAndLib-1.0.