Commit 34e0d5cd authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Change TargetSelector to remove TargetCwdPackage

Refactor so that instead of two constructors TargetPackage and
TargetCwdPackage we have just TargetPackage with an extra bool-like field to
distinguish the two.

This simplifies things in the consumers of TargetSelector which
typically have to treat TargetPackage and TargetCwdPackage in the same
way.

Also eliminate the list field in TargetCwdPackage. We don't yet support
multiple .cabal files in one dir, and when we do we'll do the same for
the cwd targets as for other explicit targets. The only annoying thing
here is that we need to use a dummy package info value because the
representation does not allow for not having one. The tradeoff is still
worth it in terms of less verbose consumers.

Also adjust tests.
parent ac006b4d
......@@ -136,8 +136,7 @@ selectPackageTargets bt ts
-- When there's a target filter like "pkg:tests" then we do select tests,
-- but if it's just a target like "pkg" then we don't build tests unless
-- they are requested by default (i.e. by using --enable-tests)
pruneReq (TargetPackage _ Nothing) TargetNotRequestedByDefault = False
pruneReq (TargetCwdPackage _ Nothing) TargetNotRequestedByDefault = False
pruneReq (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
pruneReq (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
pruneReq _ _ = True
......
......@@ -412,7 +412,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem
-> 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 filterComponentKind mkfilter)
$ Map.lookup pkgid availableTargetsByPackage
= case selectPackageTargets bt ats of
......@@ -422,17 +422,6 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem
| otherwise = internalErrorUnknownTarget
checkTarget bt@(TargetCwdPackage [pkgid] mkfilter)
| Just ats <- fmap (maybe id filterComponentKind mkfilter)
$ Map.lookup pkgid availableTargetsByPackage
= case selectPackageTargets bt ats of
Left e -> Left e
Right ts -> Right [ (unitid, ComponentTarget cname WholeComponent)
| (unitid, cname) <- ts ]
checkTarget (TargetCwdPackage _ _)
= internalErrorUnknownTarget
checkTarget bt@(TargetAllPackages mkfilter) =
let ats = maybe id filterComponentKind mkfilter
$ filter availableTargetLocalToProject
......
......@@ -14,6 +14,7 @@ module Distribution.Client.TargetSelector (
-- * Target selectors
TargetSelector(..),
TargetImplicitCwd(..),
ComponentKind(..),
SubComponentTarget(..),
QualLevel(..),
......@@ -31,7 +32,10 @@ module Distribution.Client.TargetSelector (
) where
import Distribution.Package
( Package(..), PackageId, packageName )
( Package(..), PackageId, PackageIdentifier(..), packageName
, mkPackageName )
import Distribution.Version
( mkVersion )
import Distribution.Types.UnqualComponentName ( unUnqualComponentName )
import Distribution.Client.Types
( PackageLocation(..) )
......@@ -137,11 +141,7 @@ data TargetSelector pkg =
-- | A package as a whole: the default components for the package or all
-- components of a particular kind.
--
TargetPackage pkg (Maybe ComponentKindFilter)
-- | All packages, or all components of a particular kind in all packages.
--
| TargetCwdPackage [pkg] (Maybe ComponentKindFilter)
TargetPackage TargetImplicitCwd pkg (Maybe ComponentKindFilter)
-- | All packages, or all components of a particular kind in all packages.
--
......@@ -152,6 +152,14 @@ data TargetSelector pkg =
| TargetComponent pkg ComponentName SubComponentTarget
deriving (Eq, Ord, Functor, Show, Generic)
-- | Does this 'TargetPackage' selector arise from syntax referring to a
-- packge in the current directory (e.g. @tests@ or no giving no explicit
-- target at all) or does it come from syntax referring to a package name
-- or location.
--
data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed
deriving (Eq, Ord, Show, Generic)
data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
deriving (Eq, Ord, Enum, Show)
......@@ -418,7 +426,7 @@ resolveTargetSelectors [] _opinfo [] =
([TargetSelectorNoTargets], [])
resolveTargetSelectors ppinfo _opinfo [] =
([], [TargetCwdPackage ppinfo Nothing])
([], [TargetPackage TargetImplicitCwd (head ppinfo) Nothing])
--TODO: in future allow multiple packages in the same dir
resolveTargetSelectors ppinfo opinfo targetStrs =
......@@ -432,10 +440,12 @@ resolveTargetSelector :: [PackageInfo] -> [PackageInfo]
(TargetSelector PackageInfo)
resolveTargetSelector ppinfo opinfo targetStrStatus =
case findMatch (matcher targetStrStatus) of
Unambiguous (TargetCwdPackage _ mkfilter) ->
case ppinfo of
[] -> Left (TargetSelectorNoCurrentPackage targetStr)
_ -> Right (TargetCwdPackage ppinfo mkfilter)
Unambiguous (TargetPackage TargetImplicitCwd _ mkfilter)
| null ppinfo -> Left (TargetSelectorNoCurrentPackage targetStr)
| otherwise -> Right (TargetPackage TargetImplicitCwd
(head ppinfo) mkfilter)
--TODO: in future allow multiple packages in the same dir
Unambiguous target -> Right target
None errs -> Left (classifyMatchErrors errs)
......@@ -722,10 +732,10 @@ reportTargetSelectorProblems verbosity problems = do
showTargetSelectorKind :: TargetSelector a -> String
showTargetSelectorKind bt = case bt of
TargetPackage _ Nothing -> "package"
TargetPackage _ (Just _) -> "package:filter"
TargetCwdPackage _ Nothing -> "cwd-package"
TargetCwdPackage _ (Just _) -> "cwd-package:filter"
TargetPackage TargetExplicitNamed _ Nothing -> "package"
TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter"
TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package"
TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter"
TargetAllPackages Nothing -> "all-packages"
TargetAllPackages (Just _) -> "all-packages:filter"
TargetComponent _ _ WholeComponent -> "component"
......@@ -899,12 +909,27 @@ syntaxForm1Filter :: Syntax
syntaxForm1Filter =
syntaxForm1 render $ \str1 _fstatus1 -> do
kfilter <- matchComponentKindFilter str1
return (TargetCwdPackage [] (Just kfilter))
return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter))
where
render (TargetCwdPackage _ (Just kfilter)) =
render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =
[TargetStringFileStatus1 (dispF kfilter) noFileStatus]
render _ = []
-- Only used for TargetPackage TargetImplicitCwd
dummyPackageInfo :: PackageInfo
dummyPackageInfo =
PackageInfo {
pinfoId = PackageIdentifier
(mkPackageName "dummyPackageInfo")
(mkVersion []),
pinfoLocation = unused,
pinfoDirectory = unused,
pinfoPackageFile = unused,
pinfoComponents = unused
}
where
unused = error "dummyPackageInfo"
-- | Syntax: package (name, dir or file)
--
-- > cabal build foo
......@@ -915,9 +940,9 @@ syntaxForm1Package pinfo =
syntaxForm1 render $ \str1 fstatus1 -> do
guardPackage str1 fstatus1
p <- matchPackage pinfo str1 fstatus1
return (TargetPackage p Nothing)
return (TargetPackage TargetExplicitNamed p Nothing)
where
render (TargetPackage p Nothing) =
render (TargetPackage TargetExplicitNamed p Nothing) =
[TargetStringFileStatus1 (dispP p) noFileStatus]
render _ = []
......@@ -1015,9 +1040,9 @@ syntaxForm2PackageFilter ps =
guardPackage str1 fstatus1
p <- matchPackage ps str1 fstatus1
kfilter <- matchComponentKindFilter str2
return (TargetPackage p (Just kfilter))
return (TargetPackage TargetExplicitNamed p (Just kfilter))
where
render (TargetPackage p (Just kfilter)) =
render (TargetPackage TargetExplicitNamed p (Just kfilter)) =
[TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)]
render _ = []
......@@ -1031,9 +1056,9 @@ syntaxForm2NamespacePackage pinfo =
guardNamespacePackage str1
guardPackageName str2
p <- matchPackage pinfo str2 noFileStatus
return (TargetPackage p Nothing)
return (TargetPackage TargetExplicitNamed p Nothing)
where
render (TargetPackage p Nothing) =
render (TargetPackage TargetExplicitNamed p Nothing) =
[TargetStringFileStatus2 "pkg" noFileStatus (dispP p)]
render _ = []
......@@ -1177,9 +1202,9 @@ syntaxForm3MetaCwdFilter =
guardNamespaceMeta str1
guardNamespaceCwd str2
kfilter <- matchComponentKindFilter str3
return (TargetCwdPackage [] (Just kfilter))
return (TargetPackage TargetImplicitCwd dummyPackageInfo (Just kfilter))
where
render (TargetCwdPackage _ (Just kfilter)) =
render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =
[TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]
render _ = []
......@@ -1194,9 +1219,9 @@ syntaxForm3MetaNamespacePackage pinfo =
guardNamespacePackage str2
guardPackageName str3
p <- matchPackage pinfo str3 noFileStatus
return (TargetPackage p Nothing)
return (TargetPackage TargetExplicitNamed p Nothing)
where
render (TargetPackage p Nothing) =
render (TargetPackage TargetExplicitNamed p Nothing) =
[TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)]
render _ = []
......@@ -1314,9 +1339,9 @@ syntaxForm3NamespacePackageFilter ps =
guardPackageName str2
p <- matchPackage ps str2 noFileStatus
kfilter <- matchComponentKindFilter str3
return (TargetPackage p (Just kfilter))
return (TargetPackage TargetExplicitNamed p (Just kfilter))
where
render (TargetPackage p (Just kfilter)) =
render (TargetPackage TargetExplicitNamed p (Just kfilter)) =
[TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)]
render _ = []
......@@ -1330,9 +1355,9 @@ syntaxForm4MetaNamespacePackageFilter ps =
guardPackageName str3
p <- matchPackage ps str3 noFileStatus
kfilter <- matchComponentKindFilter str4
return (TargetPackage p (Just kfilter))
return (TargetPackage TargetExplicitNamed p (Just kfilter))
where
render (TargetPackage p (Just kfilter)) =
render (TargetPackage TargetExplicitNamed p (Just kfilter)) =
[TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)]
render _ = []
......
......@@ -105,7 +105,7 @@ testTargetSelectors reportSubCase = do
reportSubCase "cwd"
do Right ts <- readTargetSelectors' []
ts @?= [TargetCwdPackage [pkgidP] Nothing]
ts @?= [TargetPackage TargetImplicitCwd pkgidP Nothing]
reportSubCase "all"
do Right ts <- readTargetSelectors'
......@@ -120,7 +120,7 @@ testTargetSelectors reportSubCase = do
, "tests", ":cwd:tests"
, "benchmarks", ":cwd:benchmarks"]
zipWithM_ (@?=) ts
[ TargetCwdPackage [pkgidP] (Just kind)
[ TargetPackage TargetImplicitCwd pkgidP (Just kind)
| kind <- concatMap (replicate 2) [LibKind .. ]
]
......@@ -140,8 +140,8 @@ testTargetSelectors reportSubCase = do
do Right ts <- readTargetSelectors'
[ ":pkg:p", ".", "./", "p.cabal"
, "q", ":pkg:q", "q/", "./q/", "q/q.cabal"]
ts @?= replicate 4 (TargetPackage pkgidP Nothing)
++ replicate 5 (TargetPackage pkgidQ Nothing)
ts @?= replicate 4 (TargetPackage TargetExplicitNamed pkgidP Nothing)
++ replicate 5 (TargetPackage TargetExplicitNamed pkgidQ Nothing)
reportSubCase "pkg:filter"
do Right ts <- readTargetSelectors'
......@@ -156,10 +156,10 @@ testTargetSelectors reportSubCase = do
, "q:tests", "q/:tests", ":pkg:q:tests"
, "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"]
zipWithM_ (@?=) ts $
[ TargetPackage pkgidP (Just kind)
[ TargetPackage TargetExplicitNamed pkgidP (Just kind)
| kind <- concatMap (replicate 3) [LibKind .. ]
] ++
[ TargetPackage pkgidQ (Just kind)
[ TargetPackage TargetExplicitNamed pkgidQ (Just kind)
| kind <- concatMap (replicate 3) [LibKind .. ]
]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment