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

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