1{-# LANGUAGE CPP #-} 2{-# LANGUAGE ScopedTypeVariables #-} 3{-# LANGUAGE DeriveGeneric #-} 4{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 5 6----------------------------------------------------------------------------- 7-- | 8-- Module : Distribution.Client.Targets 9-- Copyright : (c) Duncan Coutts 2011 10-- License : BSD-like 11-- 12-- Maintainer : duncan@community.haskell.org 13-- 14-- Handling for user-specified targets 15----------------------------------------------------------------------------- 16module Distribution.Client.Targets ( 17 -- * User targets 18 UserTarget(..), 19 readUserTargets, 20 21 -- * Resolving user targets to package specifiers 22 resolveUserTargets, 23 24 -- ** Detailed interface 25 UserTargetProblem(..), 26 readUserTarget, 27 reportUserTargetProblems, 28 expandUserTarget, 29 30 PackageTarget(..), 31 fetchPackageTarget, 32 readPackageTarget, 33 34 PackageTargetProblem(..), 35 reportPackageTargetProblems, 36 37 disambiguatePackageTargets, 38 disambiguatePackageName, 39 40 -- * User constraints 41 UserQualifier(..), 42 UserConstraintScope(..), 43 UserConstraint(..), 44 userConstraintPackageName, 45 readUserConstraint, 46 userToPackageConstraint, 47 48 ) where 49 50import Prelude () 51import Distribution.Client.Compat.Prelude 52 53import Distribution.Package 54 ( Package(..), PackageName, unPackageName, mkPackageName 55 , packageName ) 56import Distribution.Types.Dependency 57import Distribution.Client.Types 58 ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage 59 , PackageSpecifier(..) ) 60 61import Distribution.Solver.Types.OptionalStanza 62import Distribution.Solver.Types.PackageConstraint 63import Distribution.Solver.Types.PackagePath 64import Distribution.Solver.Types.PackageIndex (PackageIndex) 65import qualified Distribution.Solver.Types.PackageIndex as PackageIndex 66import Distribution.Solver.Types.SourcePackage 67 68import qualified Distribution.Client.World as World 69import qualified Codec.Archive.Tar as Tar 70import qualified Codec.Archive.Tar.Entry as Tar 71import qualified Distribution.Client.Tar as Tar 72import Distribution.Client.FetchUtils 73import Distribution.Client.Utils ( tryFindPackageDesc ) 74import Distribution.Client.GlobalFlags 75 ( RepoContext(..) ) 76import Distribution.Types.PackageVersionConstraint 77 ( PackageVersionConstraint (..) ) 78 79import Distribution.PackageDescription 80 ( GenericPackageDescription ) 81import Distribution.Types.Flag 82 ( nullFlagAssignment, parsecFlagAssignmentNonEmpty ) 83import Distribution.Version 84 ( anyVersion, isAnyVersion ) 85import Distribution.Simple.Utils 86 ( die', warn, lowercase ) 87 88import Distribution.PackageDescription.Parsec 89 ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe ) 90 91import qualified Data.Map as Map 92import qualified Data.ByteString.Lazy as BS 93import qualified Distribution.Client.GZipUtils as GZipUtils 94import qualified Distribution.Compat.CharParsing as P 95import System.FilePath 96 ( takeExtension, dropExtension, takeDirectory, splitPath ) 97import System.Directory 98 ( doesFileExist, doesDirectoryExist ) 99import Network.URI 100 ( URI(..), URIAuth(..), parseAbsoluteURI ) 101 102-- ------------------------------------------------------------ 103-- * User targets 104-- ------------------------------------------------------------ 105 106-- | Various ways that a user may specify a package or package collection. 107-- 108data UserTarget = 109 110 -- | A partially specified package, identified by name and possibly with 111 -- an exact version or a version constraint. 112 -- 113 -- > cabal install foo 114 -- > cabal install foo-1.0 115 -- > cabal install 'foo < 2' 116 -- 117 UserTargetNamed PackageVersionConstraint 118 119 -- | A special virtual package that refers to the collection of packages 120 -- recorded in the world file that the user specifically installed. 121 -- 122 -- > cabal install world 123 -- 124 | UserTargetWorld 125 126 -- | A specific package that is unpacked in a local directory, often the 127 -- current directory. 128 -- 129 -- > cabal install . 130 -- > cabal install ../lib/other 131 -- 132 -- * Note: in future, if multiple @.cabal@ files are allowed in a single 133 -- directory then this will refer to the collection of packages. 134 -- 135 | UserTargetLocalDir FilePath 136 137 -- | A specific local unpacked package, identified by its @.cabal@ file. 138 -- 139 -- > cabal install foo.cabal 140 -- > cabal install ../lib/other/bar.cabal 141 -- 142 | UserTargetLocalCabalFile FilePath 143 144 -- | A specific package that is available as a local tarball file 145 -- 146 -- > cabal install dist/foo-1.0.tar.gz 147 -- > cabal install ../build/baz-1.0.tar.gz 148 -- 149 | UserTargetLocalTarball FilePath 150 151 -- | A specific package that is available as a remote tarball file 152 -- 153 -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz 154 -- 155 | UserTargetRemoteTarball URI 156 deriving (Show,Eq) 157 158 159-- ------------------------------------------------------------ 160-- * Parsing and checking user targets 161-- ------------------------------------------------------------ 162 163readUserTargets :: Verbosity -> [String] -> IO [UserTarget] 164readUserTargets verbosity targetStrs = do 165 (problems, targets) <- liftM partitionEithers 166 (traverse readUserTarget targetStrs) 167 reportUserTargetProblems verbosity problems 168 return targets 169 170 171data UserTargetProblem 172 = UserTargetUnexpectedFile String 173 | UserTargetNonexistantFile String 174 | UserTargetUnexpectedUriScheme String 175 | UserTargetUnrecognisedUri String 176 | UserTargetUnrecognised String 177 | UserTargetBadWorldPkg 178 deriving Show 179 180readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) 181readUserTarget targetstr = 182 case eitherParsec targetstr of 183 Right (PackageVersionConstraint pkgn verrange) 184 | pkgn == mkPackageName "world" 185 -> return $ if verrange == anyVersion 186 then Right UserTargetWorld 187 else Left UserTargetBadWorldPkg 188 Right dep -> return (Right (UserTargetNamed dep)) 189 Left _err -> do 190 fileTarget <- testFileTargets targetstr 191 case fileTarget of 192 Just target -> return target 193 Nothing -> 194 case testUriTargets targetstr of 195 Just target -> return target 196 Nothing -> return (Left (UserTargetUnrecognised targetstr)) 197 where 198 testFileTargets filename = do 199 isDir <- doesDirectoryExist filename 200 isFile <- doesFileExist filename 201 parentDirExists <- case takeDirectory filename of 202 [] -> return False 203 dir -> doesDirectoryExist dir 204 let result 205 | isDir 206 = Just (Right (UserTargetLocalDir filename)) 207 208 | isFile && extensionIsTarGz filename 209 = Just (Right (UserTargetLocalTarball filename)) 210 211 | isFile && takeExtension filename == ".cabal" 212 = Just (Right (UserTargetLocalCabalFile filename)) 213 214 | isFile 215 = Just (Left (UserTargetUnexpectedFile filename)) 216 217 | parentDirExists 218 = Just (Left (UserTargetNonexistantFile filename)) 219 220 | otherwise 221 = Nothing 222 return result 223 224 testUriTargets str = 225 case parseAbsoluteURI str of 226 Just uri@URI { 227 uriScheme = scheme, 228 uriAuthority = Just URIAuth { uriRegName = host } 229 } 230 | scheme /= "http:" && scheme /= "https:" -> 231 Just (Left (UserTargetUnexpectedUriScheme targetstr)) 232 233 | null host -> 234 Just (Left (UserTargetUnrecognisedUri targetstr)) 235 236 | otherwise -> 237 Just (Right (UserTargetRemoteTarball uri)) 238 _ -> Nothing 239 240 extensionIsTarGz f = takeExtension f == ".gz" 241 && takeExtension (dropExtension f) == ".tar" 242 243reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO () 244reportUserTargetProblems verbosity problems = do 245 case [ target | UserTargetUnrecognised target <- problems ] of 246 [] -> return () 247 target -> die' verbosity 248 $ unlines 249 [ "Unrecognised target '" ++ name ++ "'." 250 | name <- target ] 251 ++ "Targets can be:\n" 252 ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" 253 ++ " - the special 'world' target\n" 254 ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" 255 ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" 256 257 case [ () | UserTargetBadWorldPkg <- problems ] of 258 [] -> return () 259 _ -> die' verbosity "The special 'world' target does not take any version." 260 261 case [ target | UserTargetNonexistantFile target <- problems ] of 262 [] -> return () 263 target -> die' verbosity 264 $ unlines 265 [ "The file does not exist '" ++ name ++ "'." 266 | name <- target ] 267 268 case [ target | UserTargetUnexpectedFile target <- problems ] of 269 [] -> return () 270 target -> die' verbosity 271 $ unlines 272 [ "Unrecognised file target '" ++ name ++ "'." 273 | name <- target ] 274 ++ "File targets can be either package tarballs 'pkgname.tar.gz' " 275 ++ "or cabal files 'pkgname.cabal'." 276 277 case [ target | UserTargetUnexpectedUriScheme target <- problems ] of 278 [] -> return () 279 target -> die' verbosity 280 $ unlines 281 [ "URL target not supported '" ++ name ++ "'." 282 | name <- target ] 283 ++ "Only 'http://' and 'https://' URLs are supported." 284 285 case [ target | UserTargetUnrecognisedUri target <- problems ] of 286 [] -> return () 287 target -> die' verbosity 288 $ unlines 289 [ "Unrecognise URL target '" ++ name ++ "'." 290 | name <- target ] 291 292 293-- ------------------------------------------------------------ 294-- * Resolving user targets to package specifiers 295-- ------------------------------------------------------------ 296 297-- | Given a bunch of user-specified targets, try to resolve what it is they 298-- refer to. They can either be specific packages (local dirs, tarballs etc) 299-- or they can be named packages (with or without version info). 300-- 301resolveUserTargets :: Package pkg 302 => Verbosity 303 -> RepoContext 304 -> FilePath 305 -> PackageIndex pkg 306 -> [UserTarget] 307 -> IO [PackageSpecifier UnresolvedSourcePackage] 308resolveUserTargets verbosity repoCtxt worldFile available userTargets = do 309 310 -- given the user targets, get a list of fully or partially resolved 311 -- package references 312 packageTargets <- traverse (readPackageTarget verbosity) 313 =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat 314 =<< traverse (expandUserTarget verbosity worldFile) userTargets 315 316 -- users are allowed to give package names case-insensitively, so we must 317 -- disambiguate named package references 318 let (problems, packageSpecifiers) = 319 disambiguatePackageTargets available availableExtra packageTargets 320 321 -- use any extra specific available packages to help us disambiguate 322 availableExtra = [ packageName pkg 323 | PackageTargetLocation pkg <- packageTargets ] 324 325 reportPackageTargetProblems verbosity problems 326 327 return packageSpecifiers 328 329 330-- ------------------------------------------------------------ 331-- * Package targets 332-- ------------------------------------------------------------ 333 334-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. 335-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. 336-- 337data PackageTarget pkg = 338 PackageTargetNamed PackageName [PackageProperty] UserTarget 339 340 -- | A package identified by name, but case insensitively, so it needs 341 -- to be resolved to the right case-sensitive name. 342 | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget 343 | PackageTargetLocation pkg 344 deriving (Show, Functor, Foldable, Traversable) 345 346 347-- ------------------------------------------------------------ 348-- * Converting user targets to package targets 349-- ------------------------------------------------------------ 350 351-- | Given a user-specified target, expand it to a bunch of package targets 352-- (each of which refers to only one package). 353-- 354expandUserTarget :: Verbosity 355 -> FilePath 356 -> UserTarget 357 -> IO [PackageTarget (PackageLocation ())] 358expandUserTarget verbosity worldFile userTarget = case userTarget of 359 360 UserTargetNamed (PackageVersionConstraint name vrange) -> 361 let props = [ PackagePropertyVersion vrange 362 | not (isAnyVersion vrange) ] 363 in return [PackageTargetNamedFuzzy name props userTarget] 364 365 UserTargetWorld -> do 366 worldPkgs <- World.getContents verbosity worldFile 367 --TODO: should we warn if there are no world targets? 368 return [ PackageTargetNamed name props userTarget 369 | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs 370 , let props = [ PackagePropertyVersion vrange 371 | not (isAnyVersion vrange) ] 372 ++ [ PackagePropertyFlags flags 373 | not (nullFlagAssignment flags) ] ] 374 375 UserTargetLocalDir dir -> 376 return [ PackageTargetLocation (LocalUnpackedPackage dir) ] 377 378 UserTargetLocalCabalFile file -> do 379 let dir = takeDirectory file 380 _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check 381 return [ PackageTargetLocation (LocalUnpackedPackage dir) ] 382 383 UserTargetLocalTarball tarballFile -> 384 return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] 385 386 UserTargetRemoteTarball tarballURL -> 387 return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] 388 389localPackageError :: FilePath -> String 390localPackageError dir = 391 "Error reading local package.\nCouldn't find .cabal file in: " ++ dir 392 393-- ------------------------------------------------------------ 394-- * Fetching and reading package targets 395-- ------------------------------------------------------------ 396 397 398-- | Fetch any remote targets so that they can be read. 399-- 400fetchPackageTarget :: Verbosity 401 -> RepoContext 402 -> PackageTarget (PackageLocation ()) 403 -> IO (PackageTarget ResolvedPkgLoc) 404fetchPackageTarget verbosity repoCtxt = traverse $ 405 fetchPackage verbosity repoCtxt . fmap (const Nothing) 406 407 408-- | Given a package target that has been fetched, read the .cabal file. 409-- 410-- This only affects targets given by location, named targets are unaffected. 411-- 412readPackageTarget :: Verbosity 413 -> PackageTarget ResolvedPkgLoc 414 -> IO (PackageTarget UnresolvedSourcePackage) 415readPackageTarget verbosity = traverse modifyLocation 416 where 417 modifyLocation location = case location of 418 419 LocalUnpackedPackage dir -> do 420 pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>= 421 readGenericPackageDescription verbosity 422 return SourcePackage 423 { srcpkgPackageId = packageId pkg 424 , srcpkgDescription = pkg 425 , srcpkgSource = fmap Just location 426 , srcpkgDescrOverride = Nothing 427 } 428 429 LocalTarballPackage tarballFile -> 430 readTarballPackageTarget location tarballFile tarballFile 431 432 RemoteTarballPackage tarballURL tarballFile -> 433 readTarballPackageTarget location tarballFile (show tarballURL) 434 435 RepoTarballPackage _repo _pkgid _ -> 436 error "TODO: readPackageTarget RepoTarballPackage" 437 -- For repo tarballs this info should be obtained from the index. 438 439 RemoteSourceRepoPackage _srcRepo _ -> 440 error "TODO: readPackageTarget RemoteSourceRepoPackage" 441 -- This can't happen, because it would have errored out already 442 -- in fetchPackage, via fetchPackageTarget before it gets to this 443 -- function. 444 -- 445 -- When that is corrected, this will also need to be fixed. 446 447 readTarballPackageTarget location tarballFile tarballOriginalLoc = do 448 (filename, content) <- extractTarballPackageCabalFile 449 tarballFile tarballOriginalLoc 450 case parsePackageDescription' content of 451 Nothing -> die' verbosity $ "Could not parse the cabal file " 452 ++ filename ++ " in " ++ tarballFile 453 Just pkg -> 454 return SourcePackage 455 { srcpkgPackageId = packageId pkg 456 , srcpkgDescription = pkg 457 , srcpkgSource = fmap Just location 458 , srcpkgDescrOverride = Nothing 459 } 460 461 extractTarballPackageCabalFile :: FilePath -> String 462 -> IO (FilePath, BS.ByteString) 463 extractTarballPackageCabalFile tarballFile tarballOriginalLoc = 464 either (die' verbosity . formatErr) return 465 . check 466 . accumEntryMap 467 . Tar.filterEntries isCabalFile 468 . Tar.read 469 . GZipUtils.maybeDecompress 470 =<< BS.readFile tarballFile 471 where 472 formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg 473 474 accumEntryMap = Tar.foldlEntries 475 (\m e -> Map.insert (Tar.entryTarPath e) e m) 476 Map.empty 477 478 check (Left e) = Left (show e) 479 check (Right m) = case Map.elems m of 480 [] -> Left noCabalFile 481 [file] -> case Tar.entryContent file of 482 Tar.NormalFile content _ -> Right (Tar.entryPath file, content) 483 _ -> Left noCabalFile 484 _files -> Left multipleCabalFiles 485 where 486 noCabalFile = "No cabal file found" 487 multipleCabalFiles = "Multiple cabal files found" 488 489 isCabalFile e = case splitPath (Tar.entryPath e) of 490 [ _dir, file] -> takeExtension file == ".cabal" 491 [".", _dir, file] -> takeExtension file == ".cabal" 492 _ -> False 493 494 parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription 495 parsePackageDescription' bs = 496 parseGenericPackageDescriptionMaybe (BS.toStrict bs) 497 498-- ------------------------------------------------------------ 499-- * Checking package targets 500-- ------------------------------------------------------------ 501 502data PackageTargetProblem 503 = PackageNameUnknown PackageName UserTarget 504 | PackageNameAmbiguous PackageName [PackageName] UserTarget 505 deriving Show 506 507 508-- | Users are allowed to give package names case-insensitively, so we must 509-- disambiguate named package references. 510-- 511disambiguatePackageTargets :: Package pkg' 512 => PackageIndex pkg' 513 -> [PackageName] 514 -> [PackageTarget pkg] 515 -> ( [PackageTargetProblem] 516 , [PackageSpecifier pkg] ) 517disambiguatePackageTargets availablePkgIndex availableExtra targets = 518 partitionEithers (map disambiguatePackageTarget targets) 519 where 520 disambiguatePackageTarget packageTarget = case packageTarget of 521 PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) 522 523 PackageTargetNamed pkgname props userTarget 524 | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) 525 -> Left (PackageNameUnknown pkgname userTarget) 526 | otherwise -> Right (NamedPackage pkgname props) 527 528 PackageTargetNamedFuzzy pkgname props userTarget -> 529 case disambiguatePackageName packageNameEnv pkgname of 530 None -> Left (PackageNameUnknown 531 pkgname userTarget) 532 Ambiguous pkgnames -> Left (PackageNameAmbiguous 533 pkgname pkgnames userTarget) 534 Unambiguous pkgname' -> Right (NamedPackage pkgname' props) 535 536 -- use any extra specific available packages to help us disambiguate 537 packageNameEnv :: PackageNameEnv 538 packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) 539 (extraPackageNameEnv availableExtra) 540 541 542-- | Report problems to the user. That is, if there are any problems 543-- then raise an exception. 544reportPackageTargetProblems :: Verbosity 545 -> [PackageTargetProblem] -> IO () 546reportPackageTargetProblems verbosity problems = do 547 case [ pkg | PackageNameUnknown pkg originalTarget <- problems 548 , not (isUserTagetWorld originalTarget) ] of 549 [] -> return () 550 pkgs -> die' verbosity $ unlines 551 [ "There is no package named '" ++ prettyShow name ++ "'. " 552 | name <- pkgs ] 553 ++ "You may need to run 'cabal update' to get the latest " 554 ++ "list of available packages." 555 556 case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of 557 [] -> return () 558 ambiguities -> die' verbosity $ unlines 559 [ "There is no package named '" ++ prettyShow name ++ "'. " 560 ++ (if length matches > 1 561 then "However, the following package names exist: " 562 else "However, the following package name exists: ") 563 ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches] 564 ++ "." 565 | (name, matches) <- ambiguities ] 566 567 case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of 568 [] -> return () 569 pkgs -> warn verbosity $ 570 "The following 'world' packages will be ignored because " 571 ++ "they refer to packages that cannot be found: " 572 ++ intercalate ", " (map prettyShow pkgs) ++ "\n" 573 ++ "You can suppress this warning by correcting the world file." 574 where 575 isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False 576 577 578-- ------------------------------------------------------------ 579-- * Disambiguating package names 580-- ------------------------------------------------------------ 581 582data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a] 583 584-- | Given a package name and a list of matching names, figure out 585-- which one it might be referring to. If there is an exact 586-- case-sensitive match then that's ok (i.e. returned via 587-- 'Unambiguous'). If it matches just one package case-insensitively 588-- or if it matches multiple packages case-insensitively, in that case 589-- the result is 'Ambiguous'. 590-- 591-- Note: Before cabal 2.2, when only a single package matched 592-- case-insensitively it would be considered 'Unambigious'. 593-- 594disambiguatePackageName :: PackageNameEnv 595 -> PackageName 596 -> MaybeAmbiguous PackageName 597disambiguatePackageName (PackageNameEnv pkgNameLookup) name = 598 case nub (pkgNameLookup name) of 599 [] -> None 600 names -> case find (name==) names of 601 Just name' -> Unambiguous name' 602 Nothing -> Ambiguous names 603 604 605newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) 606 607instance Monoid PackageNameEnv where 608 mempty = PackageNameEnv (const []) 609 mappend = (<>) 610 611instance Semigroup PackageNameEnv where 612 PackageNameEnv lookupA <> PackageNameEnv lookupB = 613 PackageNameEnv (\name -> lookupA name ++ lookupB name) 614 615indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv 616indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup 617 where 618 pkgNameLookup pname = 619 map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname) 620 621extraPackageNameEnv :: [PackageName] -> PackageNameEnv 622extraPackageNameEnv names = PackageNameEnv pkgNameLookup 623 where 624 pkgNameLookup pname = 625 [ pname' 626 | let lname = lowercase (unPackageName pname) 627 , pname' <- names 628 , lowercase (unPackageName pname') == lname ] 629 630 631-- ------------------------------------------------------------ 632-- * Package constraints 633-- ------------------------------------------------------------ 634 635-- | Version of 'Qualifier' that a user may specify on the 636-- command line. 637data UserQualifier = 638 -- | Top-level dependency. 639 UserQualToplevel 640 641 -- | Setup dependency. 642 | UserQualSetup PackageName 643 644 -- | Executable dependency. 645 | UserQualExe PackageName PackageName 646 deriving (Eq, Show, Generic) 647 648instance Binary UserQualifier 649instance Structured UserQualifier 650 651-- | Version of 'ConstraintScope' that a user may specify on the 652-- command line. 653data UserConstraintScope = 654 -- | Scope that applies to the package when it has the specified qualifier. 655 UserQualified UserQualifier PackageName 656 657 -- | Scope that applies to the package when it has a setup qualifier. 658 | UserAnySetupQualifier PackageName 659 660 -- | Scope that applies to the package when it has any qualifier. 661 | UserAnyQualifier PackageName 662 deriving (Eq, Show, Generic) 663 664instance Binary UserConstraintScope 665instance Structured UserConstraintScope 666 667fromUserQualifier :: UserQualifier -> Qualifier 668fromUserQualifier UserQualToplevel = QualToplevel 669fromUserQualifier (UserQualSetup name) = QualSetup name 670fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2 671 672fromUserConstraintScope :: UserConstraintScope -> ConstraintScope 673fromUserConstraintScope (UserQualified q pn) = 674 ScopeQualified (fromUserQualifier q) pn 675fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn 676fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn 677 678-- | Version of 'PackageConstraint' that the user can specify on 679-- the command line. 680data UserConstraint = 681 UserConstraint UserConstraintScope PackageProperty 682 deriving (Eq, Show, Generic) 683 684instance Binary UserConstraint 685instance Structured UserConstraint 686 687userConstraintPackageName :: UserConstraint -> PackageName 688userConstraintPackageName (UserConstraint scope _) = scopePN scope 689 where 690 scopePN (UserQualified _ pn) = pn 691 scopePN (UserAnyQualifier pn) = pn 692 scopePN (UserAnySetupQualifier pn) = pn 693 694userToPackageConstraint :: UserConstraint -> PackageConstraint 695userToPackageConstraint (UserConstraint scope prop) = 696 PackageConstraint (fromUserConstraintScope scope) prop 697 698readUserConstraint :: String -> Either String UserConstraint 699readUserConstraint str = 700 case explicitEitherParsec parsec str of 701 Left err -> Left $ msgCannotParse ++ err 702 Right c -> Right c 703 where 704 msgCannotParse = 705 "expected a (possibly qualified) package name followed by a " ++ 706 "constraint, which is either a version range, 'installed', " ++ 707 "'source', 'test', 'bench', or flags. " 708 709instance Pretty UserConstraint where 710 pretty (UserConstraint scope prop) = 711 dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop 712 713instance Parsec UserConstraint where 714 parsec = do 715 scope <- parseConstraintScope 716 P.spaces 717 prop <- P.choice 718 [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-" 719 , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be) 720 , PackagePropertyInstalled <$ P.string "installed" 721 , PackagePropertySource <$ P.string "source" 722 , PackagePropertyStanzas [TestStanzas] <$ P.string "test" 723 , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench" 724 ] 725 return (UserConstraint scope prop) 726 727 where 728 parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope 729 parseConstraintScope = do 730 pn <- parsec 731 P.choice 732 [ P.char '.' *> withDot pn 733 , P.char ':' *> withColon pn 734 , return (UserQualified UserQualToplevel pn) 735 ] 736 where 737 withDot :: PackageName -> m UserConstraintScope 738 withDot pn 739 | pn == mkPackageName "any" = UserAnyQualifier <$> parsec 740 | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec 741 | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn 742 743 withColon :: PackageName -> m UserConstraintScope 744 withColon pn = UserQualified (UserQualSetup pn) 745 <$ P.string "setup." 746 <*> parsec 747