cabal-install/src/Distribution/Client/Targets.hs

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