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