Commit 768d7618 authored by Duncan Coutts's avatar Duncan Coutts

Add command line support for installed, source and flag constraints

e.g. --constraint='foo source'
     --constraint='baz installed'
     --constraint='bar +this -that'
parent c0bebf4e
......@@ -24,6 +24,8 @@ import Distribution.Client.Setup
import Distribution.Client.Types as Source
import Distribution.Client.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Targets
( userToPackageConstraint )
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId)
......@@ -142,8 +144,9 @@ planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
. addConstraints
-- version constraints from the config file or command line
[ PackageConstraintVersion name ver
| Dependency name ver <- configConstraints configFlags ]
-- TODO: should warn or error on constraints that are not on direct deps
-- or flag constraints not on the package in question.
(map userToPackageConstraint (configExConstraints configExFlags))
. addConstraints
-- package flags from the config file or command line
......
......@@ -241,8 +241,7 @@ planPackages comp configFlags configExFlags installFlags
. addConstraints
-- version constraints from the config file or command line
[ PackageConstraintVersion name ver
| Dependency name ver <- configConstraints configFlags ]
(map userToPackageConstraint (configExConstraints configExFlags))
. addConstraints
--FIXME: this just applies all flags to all targets which
......
......@@ -39,6 +39,8 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
( UserConstraint, readUserConstraint )
import Distribution.Simple.Program
( defaultProgramConfiguration )
......@@ -60,7 +62,7 @@ import Distribution.Package
import Distribution.Text
( Text(parse), display )
import Distribution.ReadE
( readP_to_E, succeedReadE )
( ReadE(..), readP_to_E, succeedReadE )
import qualified Distribution.Compat.ReadP as Parse
( ReadP, readP_to_S, char, munch1, pfail, (+++) )
import Distribution.Verbosity
......@@ -231,6 +233,7 @@ filterConfigureFlags flags cabalLibVersion
--
data ConfigExFlags = ConfigExFlags {
configCabalVersion :: Flag Version,
configExConstraints:: [UserConstraint],
configPreferences :: [Dependency]
}
......@@ -241,7 +244,8 @@ configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
configureExCommand = configureCommand {
commandDefaultFlags = (mempty, defaultConfigExFlags),
commandOptions = \showOrParseArgs ->
liftOptions fst setFst (configureOptions showOrParseArgs)
liftOptions fst setFst (filter ((/="constraint") . optionName) $
configureOptions showOrParseArgs)
++ liftOptions snd setSnd (configureExOptions showOrParseArgs)
}
where
......@@ -257,22 +261,31 @@ configureExOptions _showOrParseArgs =
(reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)
(fmap toFlag parse))
(map display . flagToList))
, option [] ["constraint"]
"Specify constraints on a package (version, installed/source, flags)"
configExConstraints (\v flags -> flags { configExConstraints = v })
(reqArg "CONSTRAINT"
(fmap (\x -> [x]) (ReadE readUserConstraint))
(map display))
, option [] ["preference"]
"Specify preferences (soft constraints) on the version of a package"
configPreferences (\v flags -> flags { configPreferences = v })
(reqArg "DEPENDENCY"
(readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))
(map (\x -> display x)))
(reqArg "CONSTRAINT"
(readP_to_E (const "dependency expected")
(fmap (\x -> [x]) parse))
(map display))
]
instance Monoid ConfigExFlags where
mempty = ConfigExFlags {
configCabalVersion = mempty,
configExConstraints= mempty,
configPreferences = mempty
}
mappend a b = ConfigExFlags {
configCabalVersion = combine configCabalVersion,
configExConstraints= combine configExConstraints,
configPreferences = combine configPreferences
}
where combine field = field a `mappend` field b
......@@ -612,7 +625,8 @@ installCommand = CommandUI {
++ " Constrained package version\n",
commandDefaultFlags = (mempty, mempty, mempty),
commandOptions = \showOrParseArgs ->
liftOptions get1 set1 (configureOptions showOrParseArgs)
liftOptions get1 set1 (filter ((/="constraint") . optionName) $
configureOptions showOrParseArgs)
++ liftOptions get2 set2 (configureExOptions showOrParseArgs)
++ liftOptions get3 set3 (installOptions showOrParseArgs)
}
......
......@@ -37,6 +37,11 @@ module Distribution.Client.Targets (
disambiguatePackageTargets,
disambiguatePackageName,
-- * User constraints
UserConstraint(..),
readUserConstraint,
userToPackageConstraint
) where
import Distribution.Package
......@@ -55,13 +60,14 @@ import qualified Distribution.Client.Tar as Tar
import Distribution.Client.FetchUtils
import Distribution.PackageDescription
( GenericPackageDescription )
( GenericPackageDescription, FlagName(..), FlagAssignment )
import Distribution.PackageDescription.Parse
( readPackageDescription, parsePackageDescription, ParseResult(..) )
import Distribution.Version
( Version(Version), thisVersion, anyVersion, isAnyVersion )
( Version(Version), thisVersion, anyVersion, isAnyVersion
, VersionRange )
import Distribution.Text
( Text(parse), display )
( Text(..), display )
import Distribution.Verbosity (Verbosity)
import Distribution.Simple.Utils
( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )
......@@ -80,9 +86,13 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import qualified Distribution.Client.GZipUtils as GZipUtils
import Control.Monad (liftM)
import qualified Distribution.Compat.ReadP as Parse
( ReadP, readP_to_S, (+++) )
import Distribution.Compat.ReadP
( (+++), (<++) )
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint
( (<>), (<+>) )
import Data.Char
( isSpace )
( isSpace, isAlphaNum )
import System.FilePath
( takeExtension, dropExtension, takeDirectory, splitPath )
import System.Directory
......@@ -265,16 +275,17 @@ readUserTarget targetstr =
&& takeExtension (dropExtension f) == ".tar"
parseDependencyOrPackageId :: Parse.ReadP r Dependency
parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse
parseDependencyOrPackageId = parse
+++ liftM pkgidToDependency parse
where
pkgidToDependency :: PackageIdentifier -> Dependency
pkgidToDependency p = case packageVersion p of
Version [] _ -> Dependency (packageName p) anyVersion
version -> Dependency (packageName p) (thisVersion version)
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
reportUserTargetProblems :: [UserTargetProblem] -> IO ()
......@@ -649,3 +660,75 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup
| let lname = lowercase name
, PackageName name' <- names
, lowercase name' == lname ]
-- ------------------------------------------------------------
-- * Package constraints
-- ------------------------------------------------------------
data UserConstraint =
UserConstraintVersion PackageName VersionRange
| UserConstraintInstalled PackageName
| UserConstraintSource PackageName
| UserConstraintFlags PackageName FlagAssignment
deriving (Show,Eq)
userToPackageConstraint :: UserConstraint -> PackageConstraint
-- At the moment, the types happen to be directly equivalent
userToPackageConstraint uc = case uc of
UserConstraintVersion name ver -> PackageConstraintVersion name ver
UserConstraintInstalled name -> PackageConstraintInstalled name
UserConstraintSource name -> PackageConstraintSource name
UserConstraintFlags name flags -> PackageConstraintFlags name flags
readUserConstraint :: String -> Either String UserConstraint
readUserConstraint str =
case readPToMaybe parse str of
Nothing -> Left msgCannotParse
Just c -> Right c
where
msgCannotParse =
"expected a package name followed by a constraint, which is "
++ "either a version range, 'installed', 'source' or flags"
--FIXME: use Text instance for FlagName and FlagAssignment
instance Text UserConstraint where
disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange
disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed"
disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source"
disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags
where
dispFlagAssignment = Disp.hsep . map dispFlagValue
dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f
dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f
dispFlagName (FlagName f) = Disp.text f
parse = parse >>= parseConstraint
where
parseConstraint pkgname =
(parse >>= return . UserConstraintVersion pkgname)
+++ (do Parse.skipSpaces
_ <- Parse.string "installed"
return (UserConstraintInstalled pkgname))
+++ (do Parse.skipSpaces
_ <- Parse.string "source"
return (UserConstraintSource pkgname))
<++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))
parseFlagAssignment = Parse.many1 (Parse.skipSpaces >> parseFlagValue)
parseFlagValue =
(do Parse.optional (Parse.char '+')
f <- parseFlagName
return (f, True))
+++ (do _ <- Parse.char '-'
f <- parseFlagName
return (f, False))
parseFlagName = liftM FlagName ident
ident :: Parse.ReadP r String
ident = Parse.munch1 identChar >>= \s -> check s >> return s
where
identChar c = isAlphaNum c || c == '_' || c == '-'
check ('-':_) = Parse.pfail
check _ = return ()
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