{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Targets
-- Copyright   :  (c) Duncan Coutts 2011
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
--
-- Handling for user-specified targets
-----------------------------------------------------------------------------
module Distribution.Client.Targets (
  -- * User targets
  UserTarget(..),
  readUserTargets,

  -- * Resolving user targets to package specifiers
  resolveUserTargets,

  -- ** Detailed interface
  UserTargetProblem(..),
  readUserTarget,
  reportUserTargetProblems,
  expandUserTarget,

  PackageTarget(..),
  fetchPackageTarget,
  readPackageTarget,

  PackageTargetProblem(..),
  reportPackageTargetProblems,

  disambiguatePackageTargets,
  disambiguatePackageName,

  -- * User constraints
  UserQualifier(..),
  UserConstraintScope(..),
  UserConstraint(..),
  userConstraintPackageName,
  readUserConstraint,
  userToPackageConstraint,

  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude

import Distribution.Package
         ( Package(..), PackageName, unPackageName, mkPackageName
         , packageName )
import Distribution.Client.Types
         ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage
         , PackageSpecifier(..) )

import           Distribution.Solver.Types.OptionalStanza
import           Distribution.Solver.Types.PackageConstraint
import           Distribution.Solver.Types.PackagePath
import           Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
import           Distribution.Solver.Types.SourcePackage

import qualified Codec.Archive.Tar       as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.FetchUtils
import Distribution.Client.Utils ( tryFindPackageDesc )
import Distribution.Client.GlobalFlags
         ( RepoContext(..) )
import Distribution.Types.PackageVersionConstraint
         ( PackageVersionConstraint (..) )

import Distribution.PackageDescription
         ( GenericPackageDescription )
import Distribution.Types.Flag
         ( parsecFlagAssignmentNonEmpty )
import Distribution.Version
         ( isAnyVersion )
import Distribution.Simple.Utils
         ( die', lowercase )

import Distribution.PackageDescription.Parsec
         ( parseGenericPackageDescriptionMaybe )
import Distribution.Simple.PackageDescription
         ( readGenericPackageDescription )

import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BS
import qualified Distribution.Client.GZipUtils as GZipUtils
import qualified Distribution.Compat.CharParsing as P
import System.FilePath
         ( takeExtension, dropExtension, takeDirectory, splitPath )
import System.Directory
         ( doesFileExist, doesDirectoryExist )
import Network.URI
         ( URI(..), URIAuth(..), parseAbsoluteURI )

-- ------------------------------------------------------------
-- * User targets
-- ------------------------------------------------------------

-- | Various ways that a user may specify a package or package collection.
--
data UserTarget =

     -- | A partially specified package, identified by name and possibly with
     -- an exact version or a version constraint.
     --
     -- > cabal install foo
     -- > cabal install foo-1.0
     -- > cabal install 'foo < 2'
     --
     UserTargetNamed PackageVersionConstraint

     -- | A specific package that is unpacked in a local directory, often the
     -- current directory.
     --
     -- > cabal install .
     -- > cabal install ../lib/other
     --
     -- * Note: in future, if multiple @.cabal@ files are allowed in a single
     -- directory then this will refer to the collection of packages.
     --
   | UserTargetLocalDir FilePath

     -- | A specific local unpacked package, identified by its @.cabal@ file.
     --
     -- > cabal install foo.cabal
     -- > cabal install ../lib/other/bar.cabal
     --
   | UserTargetLocalCabalFile FilePath

     -- | A specific package that is available as a local tarball file
     --
     -- > cabal install dist/foo-1.0.tar.gz
     -- > cabal install ../build/baz-1.0.tar.gz
     --
   | UserTargetLocalTarball FilePath

     -- | A specific package that is available as a remote tarball file
     --
     -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz
     --
   | UserTargetRemoteTarball URI
  deriving (Int -> UserTarget -> ShowS
[UserTarget] -> ShowS
UserTarget -> String
(Int -> UserTarget -> ShowS)
-> (UserTarget -> String)
-> ([UserTarget] -> ShowS)
-> Show UserTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserTarget] -> ShowS
$cshowList :: [UserTarget] -> ShowS
show :: UserTarget -> String
$cshow :: UserTarget -> String
showsPrec :: Int -> UserTarget -> ShowS
$cshowsPrec :: Int -> UserTarget -> ShowS
Show,UserTarget -> UserTarget -> Bool
(UserTarget -> UserTarget -> Bool)
-> (UserTarget -> UserTarget -> Bool) -> Eq UserTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserTarget -> UserTarget -> Bool
$c/= :: UserTarget -> UserTarget -> Bool
== :: UserTarget -> UserTarget -> Bool
$c== :: UserTarget -> UserTarget -> Bool
Eq)


-- ------------------------------------------------------------
-- * Parsing and checking user targets
-- ------------------------------------------------------------

readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
readUserTargets Verbosity
verbosity [String]
targetStrs = do
    ([UserTargetProblem]
problems, [UserTarget]
targets) <- ([Either UserTargetProblem UserTarget]
 -> ([UserTargetProblem], [UserTarget]))
-> IO [Either UserTargetProblem UserTarget]
-> IO ([UserTargetProblem], [UserTarget])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Either UserTargetProblem UserTarget]
-> ([UserTargetProblem], [UserTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
                                 ((String -> IO (Either UserTargetProblem UserTarget))
-> [String] -> IO [Either UserTargetProblem UserTarget]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO (Either UserTargetProblem UserTarget)
readUserTarget [String]
targetStrs)
    Verbosity -> [UserTargetProblem] -> IO ()
reportUserTargetProblems Verbosity
verbosity [UserTargetProblem]
problems
    [UserTarget] -> IO [UserTarget]
forall (m :: * -> *) a. Monad m => a -> m a
return [UserTarget]
targets


data UserTargetProblem
   = UserTargetUnexpectedFile      String
   | UserTargetNonexistantFile     String
   | UserTargetUnexpectedUriScheme String
   | UserTargetUnrecognisedUri     String
   | UserTargetUnrecognised        String
  deriving Int -> UserTargetProblem -> ShowS
[UserTargetProblem] -> ShowS
UserTargetProblem -> String
(Int -> UserTargetProblem -> ShowS)
-> (UserTargetProblem -> String)
-> ([UserTargetProblem] -> ShowS)
-> Show UserTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserTargetProblem] -> ShowS
$cshowList :: [UserTargetProblem] -> ShowS
show :: UserTargetProblem -> String
$cshow :: UserTargetProblem -> String
showsPrec :: Int -> UserTargetProblem -> ShowS
$cshowsPrec :: Int -> UserTargetProblem -> ShowS
Show

readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)
readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)
readUserTarget String
targetstr =
    case String -> Either String PackageVersionConstraint
forall a. Parsec a => String -> Either String a
eitherParsec String
targetstr of
      Right PackageVersionConstraint
dep -> Either UserTargetProblem UserTarget
-> IO (Either UserTargetProblem UserTarget)
forall (m :: * -> *) a. Monad m => a -> m a
return (UserTarget -> Either UserTargetProblem UserTarget
forall a b. b -> Either a b
Right (PackageVersionConstraint -> UserTarget
UserTargetNamed PackageVersionConstraint
dep))
      Left String
_err -> do
        Maybe (Either UserTargetProblem UserTarget)
fileTarget <- String -> IO (Maybe (Either UserTargetProblem UserTarget))
testFileTargets String
targetstr
        case Maybe (Either UserTargetProblem UserTarget)
fileTarget of
          Just Either UserTargetProblem UserTarget
target -> Either UserTargetProblem UserTarget
-> IO (Either UserTargetProblem UserTarget)
forall (m :: * -> *) a. Monad m => a -> m a
return Either UserTargetProblem UserTarget
target
          Maybe (Either UserTargetProblem UserTarget)
Nothing     ->
            case String -> Maybe (Either UserTargetProblem UserTarget)
testUriTargets String
targetstr of
              Just Either UserTargetProblem UserTarget
target -> Either UserTargetProblem UserTarget
-> IO (Either UserTargetProblem UserTarget)
forall (m :: * -> *) a. Monad m => a -> m a
return Either UserTargetProblem UserTarget
target
              Maybe (Either UserTargetProblem UserTarget)
Nothing     -> Either UserTargetProblem UserTarget
-> IO (Either UserTargetProblem UserTarget)
forall (m :: * -> *) a. Monad m => a -> m a
return (UserTargetProblem -> Either UserTargetProblem UserTarget
forall a b. a -> Either a b
Left (String -> UserTargetProblem
UserTargetUnrecognised String
targetstr))
  where
    testFileTargets :: FilePath -> IO (Maybe (Either UserTargetProblem UserTarget))
    testFileTargets :: String -> IO (Maybe (Either UserTargetProblem UserTarget))
testFileTargets String
filename = do
      Bool
isDir  <- String -> IO Bool
doesDirectoryExist String
filename
      Bool
isFile <- String -> IO Bool
doesFileExist String
filename
      Bool
parentDirExists <- case ShowS
takeDirectory String
filename of
                           []  -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                           String
dir -> String -> IO Bool
doesDirectoryExist String
dir
      let result :: Maybe (Either UserTargetProblem UserTarget)
          result :: Maybe (Either UserTargetProblem UserTarget)
result
            | Bool
isDir
            = Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTarget -> Either UserTargetProblem UserTarget
forall a b. b -> Either a b
Right (String -> UserTarget
UserTargetLocalDir String
filename))

            | Bool
isFile Bool -> Bool -> Bool
&& String -> Bool
extensionIsTarGz String
filename
            = Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTarget -> Either UserTargetProblem UserTarget
forall a b. b -> Either a b
Right (String -> UserTarget
UserTargetLocalTarball String
filename))

            | Bool
isFile Bool -> Bool -> Bool
&& ShowS
takeExtension String
filename String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal"
            = Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTarget -> Either UserTargetProblem UserTarget
forall a b. b -> Either a b
Right (String -> UserTarget
UserTargetLocalCabalFile String
filename))

            | Bool
isFile
            = Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTargetProblem -> Either UserTargetProblem UserTarget
forall a b. a -> Either a b
Left (String -> UserTargetProblem
UserTargetUnexpectedFile String
filename))

            | Bool
parentDirExists
            = Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTargetProblem -> Either UserTargetProblem UserTarget
forall a b. a -> Either a b
Left (String -> UserTargetProblem
UserTargetNonexistantFile String
filename))

            | Bool
otherwise
            = Maybe (Either UserTargetProblem UserTarget)
forall a. Maybe a
Nothing
      Maybe (Either UserTargetProblem UserTarget)
-> IO (Maybe (Either UserTargetProblem UserTarget))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either UserTargetProblem UserTarget)
result

    testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget)
    testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget)
testUriTargets String
str =
      case String -> Maybe URI
parseAbsoluteURI String
str of
        Just uri :: URI
uri@URI {
            uriScheme :: URI -> String
uriScheme    = String
scheme,
            uriAuthority :: URI -> Maybe URIAuth
uriAuthority = Just URIAuth { uriRegName :: URIAuth -> String
uriRegName = String
host }
          }
          | String
scheme String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"http:" Bool -> Bool -> Bool
&& String
scheme String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"https:" ->
            Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTargetProblem -> Either UserTargetProblem UserTarget
forall a b. a -> Either a b
Left (String -> UserTargetProblem
UserTargetUnexpectedUriScheme String
targetstr))

          | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
host ->
            Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTargetProblem -> Either UserTargetProblem UserTarget
forall a b. a -> Either a b
Left (String -> UserTargetProblem
UserTargetUnrecognisedUri String
targetstr))

          | Bool
otherwise ->
            Either UserTargetProblem UserTarget
-> Maybe (Either UserTargetProblem UserTarget)
forall a. a -> Maybe a
Just (UserTarget -> Either UserTargetProblem UserTarget
forall a b. b -> Either a b
Right (URI -> UserTarget
UserTargetRemoteTarball URI
uri))
        Maybe URI
_ -> Maybe (Either UserTargetProblem UserTarget)
forall a. Maybe a
Nothing

    extensionIsTarGz :: FilePath -> Bool
    extensionIsTarGz :: String -> Bool
extensionIsTarGz String
f = ShowS
takeExtension String
f                 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".gz"
                      Bool -> Bool -> Bool
&& ShowS
takeExtension (ShowS
dropExtension String
f) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".tar"

reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()
reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()
reportUserTargetProblems Verbosity
verbosity [UserTargetProblem]
problems = do
    case [ String
target | UserTargetUnrecognised String
target <- [UserTargetProblem]
problems ] of
      []     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"Unrecognised target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Targets can be:\n"
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"

    case [ String
target | UserTargetNonexistantFile String
target <- [UserTargetProblem]
problems ] of
      []     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"The file does not exist '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]

    case [ String
target | UserTargetUnexpectedFile String
target <- [UserTargetProblem]
problems ] of
      []     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"Unrecognised file target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"File targets can be either package tarballs 'pkgname.tar.gz' "
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"or cabal files 'pkgname.cabal'."

    case [ String
target | UserTargetUnexpectedUriScheme String
target <- [UserTargetProblem]
problems ] of
      []     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"URL target not supported '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Only 'http://' and 'https://' URLs are supported."

    case [ String
target | UserTargetUnrecognisedUri String
target <- [UserTargetProblem]
problems ] of
      []     -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"Unrecognise URL target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]


-- ------------------------------------------------------------
-- * Resolving user targets to package specifiers
-- ------------------------------------------------------------

-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to. They can either be specific packages (local dirs, tarballs etc)
-- or they can be named packages (with or without version info).
--
resolveUserTargets :: Package pkg
                   => Verbosity
                   -> RepoContext
                   -> PackageIndex pkg
                   -> [UserTarget]
                   -> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets :: Verbosity
-> RepoContext
-> PackageIndex pkg
-> [UserTarget]
-> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets Verbosity
verbosity RepoContext
repoCtxt PackageIndex pkg
available [UserTarget]
userTargets = do

    -- given the user targets, get a list of fully or partially resolved
    -- package references
    [PackageTarget UnresolvedSourcePackage]
packageTargets <- (PackageTarget ResolvedPkgLoc
 -> IO (PackageTarget UnresolvedSourcePackage))
-> [PackageTarget ResolvedPkgLoc]
-> IO [PackageTarget UnresolvedSourcePackage]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity
-> PackageTarget ResolvedPkgLoc
-> IO (PackageTarget UnresolvedSourcePackage)
readPackageTarget Verbosity
verbosity)
                  ([PackageTarget ResolvedPkgLoc]
 -> IO [PackageTarget UnresolvedSourcePackage])
-> IO [PackageTarget ResolvedPkgLoc]
-> IO [PackageTarget UnresolvedSourcePackage]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PackageTarget (PackageLocation ())
 -> IO (PackageTarget ResolvedPkgLoc))
-> [PackageTarget (PackageLocation ())]
-> IO [PackageTarget ResolvedPkgLoc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity
-> RepoContext
-> PackageTarget (PackageLocation ())
-> IO (PackageTarget ResolvedPkgLoc)
fetchPackageTarget Verbosity
verbosity RepoContext
repoCtxt) ([PackageTarget (PackageLocation ())]
 -> IO [PackageTarget ResolvedPkgLoc])
-> ([[PackageTarget (PackageLocation ())]]
    -> [PackageTarget (PackageLocation ())])
-> [[PackageTarget (PackageLocation ())]]
-> IO [PackageTarget ResolvedPkgLoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[PackageTarget (PackageLocation ())]]
-> [PackageTarget (PackageLocation ())]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  ([[PackageTarget (PackageLocation ())]]
 -> IO [PackageTarget ResolvedPkgLoc])
-> IO [[PackageTarget (PackageLocation ())]]
-> IO [PackageTarget ResolvedPkgLoc]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (UserTarget -> IO [PackageTarget (PackageLocation ())])
-> [UserTarget] -> IO [[PackageTarget (PackageLocation ())]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity -> UserTarget -> IO [PackageTarget (PackageLocation ())]
expandUserTarget Verbosity
verbosity) [UserTarget]
userTargets

    -- users are allowed to give package names case-insensitively, so we must
    -- disambiguate named package references
    let ([PackageTargetProblem]
problems, [PackageSpecifier UnresolvedSourcePackage]
packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) =
           PackageIndex pkg
-> [PackageName]
-> [PackageTarget UnresolvedSourcePackage]
-> ([PackageTargetProblem],
    [PackageSpecifier UnresolvedSourcePackage])
forall pkg' pkg.
Package pkg' =>
PackageIndex pkg'
-> [PackageName]
-> [PackageTarget pkg]
-> ([PackageTargetProblem], [PackageSpecifier pkg])
disambiguatePackageTargets PackageIndex pkg
available [PackageName]
availableExtra [PackageTarget UnresolvedSourcePackage]
packageTargets

        -- use any extra specific available packages to help us disambiguate
        availableExtra :: [PackageName]
        availableExtra :: [PackageName]
availableExtra = [ UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName UnresolvedSourcePackage
pkg
                         | PackageTargetLocation UnresolvedSourcePackage
pkg <- [PackageTarget UnresolvedSourcePackage]
packageTargets ]

    Verbosity -> [PackageTargetProblem] -> IO ()
reportPackageTargetProblems Verbosity
verbosity [PackageTargetProblem]
problems

    [PackageSpecifier UnresolvedSourcePackage]
-> IO [PackageSpecifier UnresolvedSourcePackage]
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageSpecifier UnresolvedSourcePackage]
packageSpecifiers


-- ------------------------------------------------------------
-- * Package targets
-- ------------------------------------------------------------

-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.
-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.
--
data PackageTarget pkg =
     PackageTargetNamed      PackageName [PackageProperty] UserTarget

     -- | A package identified by name, but case insensitively, so it needs
     -- to be resolved to the right case-sensitive name.
   | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget
   | PackageTargetLocation pkg
  deriving (Int -> PackageTarget pkg -> ShowS
[PackageTarget pkg] -> ShowS
PackageTarget pkg -> String
(Int -> PackageTarget pkg -> ShowS)
-> (PackageTarget pkg -> String)
-> ([PackageTarget pkg] -> ShowS)
-> Show (PackageTarget pkg)
forall pkg. Show pkg => Int -> PackageTarget pkg -> ShowS
forall pkg. Show pkg => [PackageTarget pkg] -> ShowS
forall pkg. Show pkg => PackageTarget pkg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageTarget pkg] -> ShowS
$cshowList :: forall pkg. Show pkg => [PackageTarget pkg] -> ShowS
show :: PackageTarget pkg -> String
$cshow :: forall pkg. Show pkg => PackageTarget pkg -> String
showsPrec :: Int -> PackageTarget pkg -> ShowS
$cshowsPrec :: forall pkg. Show pkg => Int -> PackageTarget pkg -> ShowS
Show, a -> PackageTarget b -> PackageTarget a
(a -> b) -> PackageTarget a -> PackageTarget b
(forall a b. (a -> b) -> PackageTarget a -> PackageTarget b)
-> (forall a b. a -> PackageTarget b -> PackageTarget a)
-> Functor PackageTarget
forall a b. a -> PackageTarget b -> PackageTarget a
forall a b. (a -> b) -> PackageTarget a -> PackageTarget b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PackageTarget b -> PackageTarget a
$c<$ :: forall a b. a -> PackageTarget b -> PackageTarget a
fmap :: (a -> b) -> PackageTarget a -> PackageTarget b
$cfmap :: forall a b. (a -> b) -> PackageTarget a -> PackageTarget b
Functor, PackageTarget a -> Bool
(a -> m) -> PackageTarget a -> m
(a -> b -> b) -> b -> PackageTarget a -> b
(forall m. Monoid m => PackageTarget m -> m)
-> (forall m a. Monoid m => (a -> m) -> PackageTarget a -> m)
-> (forall m a. Monoid m => (a -> m) -> PackageTarget a -> m)
-> (forall a b. (a -> b -> b) -> b -> PackageTarget a -> b)
-> (forall a b. (a -> b -> b) -> b -> PackageTarget a -> b)
-> (forall b a. (b -> a -> b) -> b -> PackageTarget a -> b)
-> (forall b a. (b -> a -> b) -> b -> PackageTarget a -> b)
-> (forall a. (a -> a -> a) -> PackageTarget a -> a)
-> (forall a. (a -> a -> a) -> PackageTarget a -> a)
-> (forall a. PackageTarget a -> [a])
-> (forall a. PackageTarget a -> Bool)
-> (forall a. PackageTarget a -> Int)
-> (forall a. Eq a => a -> PackageTarget a -> Bool)
-> (forall a. Ord a => PackageTarget a -> a)
-> (forall a. Ord a => PackageTarget a -> a)
-> (forall a. Num a => PackageTarget a -> a)
-> (forall a. Num a => PackageTarget a -> a)
-> Foldable PackageTarget
forall a. Eq a => a -> PackageTarget a -> Bool
forall a. Num a => PackageTarget a -> a
forall a. Ord a => PackageTarget a -> a
forall m. Monoid m => PackageTarget m -> m
forall a. PackageTarget a -> Bool
forall a. PackageTarget a -> Int
forall a. PackageTarget a -> [a]
forall a. (a -> a -> a) -> PackageTarget a -> a
forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: PackageTarget a -> a
$cproduct :: forall a. Num a => PackageTarget a -> a
sum :: PackageTarget a -> a
$csum :: forall a. Num a => PackageTarget a -> a
minimum :: PackageTarget a -> a
$cminimum :: forall a. Ord a => PackageTarget a -> a
maximum :: PackageTarget a -> a
$cmaximum :: forall a. Ord a => PackageTarget a -> a
elem :: a -> PackageTarget a -> Bool
$celem :: forall a. Eq a => a -> PackageTarget a -> Bool
length :: PackageTarget a -> Int
$clength :: forall a. PackageTarget a -> Int
null :: PackageTarget a -> Bool
$cnull :: forall a. PackageTarget a -> Bool
toList :: PackageTarget a -> [a]
$ctoList :: forall a. PackageTarget a -> [a]
foldl1 :: (a -> a -> a) -> PackageTarget a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
foldr1 :: (a -> a -> a) -> PackageTarget a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
foldl' :: (b -> a -> b) -> b -> PackageTarget a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
foldl :: (b -> a -> b) -> b -> PackageTarget a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
foldr' :: (a -> b -> b) -> b -> PackageTarget a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
foldr :: (a -> b -> b) -> b -> PackageTarget a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
foldMap' :: (a -> m) -> PackageTarget a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
foldMap :: (a -> m) -> PackageTarget a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
fold :: PackageTarget m -> m
$cfold :: forall m. Monoid m => PackageTarget m -> m
Foldable, Functor PackageTarget
Foldable PackageTarget
Functor PackageTarget
-> Foldable PackageTarget
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> PackageTarget a -> f (PackageTarget b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    PackageTarget (f a) -> f (PackageTarget a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> PackageTarget a -> m (PackageTarget b))
-> (forall (m :: * -> *) a.
    Monad m =>
    PackageTarget (m a) -> m (PackageTarget a))
-> Traversable PackageTarget
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
PackageTarget (m a) -> m (PackageTarget a)
forall (f :: * -> *) a.
Applicative f =>
PackageTarget (f a) -> f (PackageTarget a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PackageTarget a -> m (PackageTarget b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
sequence :: PackageTarget (m a) -> m (PackageTarget a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PackageTarget (m a) -> m (PackageTarget a)
mapM :: (a -> m b) -> PackageTarget a -> m (PackageTarget b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PackageTarget a -> m (PackageTarget b)
sequenceA :: PackageTarget (f a) -> f (PackageTarget a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PackageTarget (f a) -> f (PackageTarget a)
traverse :: (a -> f b) -> PackageTarget a -> f (PackageTarget b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
$cp2Traversable :: Foldable PackageTarget
$cp1Traversable :: Functor PackageTarget
Traversable)


-- ------------------------------------------------------------
-- * Converting user targets to package targets
-- ------------------------------------------------------------

-- | Given a user-specified target, expand it to a bunch of package targets
-- (each of which refers to only one package).
--
expandUserTarget :: Verbosity
                 -> UserTarget
                 -> IO [PackageTarget (PackageLocation ())]
expandUserTarget :: Verbosity -> UserTarget -> IO [PackageTarget (PackageLocation ())]
expandUserTarget Verbosity
verbosity UserTarget
userTarget = case UserTarget
userTarget of

    UserTargetNamed (PackageVersionConstraint PackageName
name VersionRange
vrange) ->
      let props :: [PackageProperty]
props = [ VersionRange -> PackageProperty
PackagePropertyVersion VersionRange
vrange
                  | Bool -> Bool
not (VersionRange -> Bool
isAnyVersion VersionRange
vrange) ]
      in  [PackageTarget (PackageLocation ())]
-> IO [PackageTarget (PackageLocation ())]
forall (m :: * -> *) a. Monad m => a -> m a
return [PackageName
-> [PackageProperty]
-> UserTarget
-> PackageTarget (PackageLocation ())
forall pkg.
PackageName -> [PackageProperty] -> UserTarget -> PackageTarget pkg
PackageTargetNamedFuzzy PackageName
name [PackageProperty]
props UserTarget
userTarget]

    UserTargetLocalDir String
dir ->
      [PackageTarget (PackageLocation ())]
-> IO [PackageTarget (PackageLocation ())]
forall (m :: * -> *) a. Monad m => a -> m a
return [ PackageLocation () -> PackageTarget (PackageLocation ())
forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (String -> PackageLocation ()
forall local. String -> PackageLocation local
LocalUnpackedPackage String
dir) ]

    UserTargetLocalCabalFile String
file -> do
      let dir :: String
dir = ShowS
takeDirectory String
file
      String
_   <- Verbosity -> String -> String -> IO String
tryFindPackageDesc Verbosity
verbosity String
dir (ShowS
localPackageError String
dir) -- just as a check
      [PackageTarget (PackageLocation ())]
-> IO [PackageTarget (PackageLocation ())]
forall (m :: * -> *) a. Monad m => a -> m a
return [ PackageLocation () -> PackageTarget (PackageLocation ())
forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (String -> PackageLocation ()
forall local. String -> PackageLocation local
LocalUnpackedPackage String
dir) ]

    UserTargetLocalTarball String
tarballFile ->
      [PackageTarget (PackageLocation ())]
-> IO [PackageTarget (PackageLocation ())]
forall (m :: * -> *) a. Monad m => a -> m a
return [ PackageLocation () -> PackageTarget (PackageLocation ())
forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (String -> PackageLocation ()
forall local. String -> PackageLocation local
LocalTarballPackage String
tarballFile) ]

    UserTargetRemoteTarball URI
tarballURL ->
      [PackageTarget (PackageLocation ())]
-> IO [PackageTarget (PackageLocation ())]
forall (m :: * -> *) a. Monad m => a -> m a
return [ PackageLocation () -> PackageTarget (PackageLocation ())
forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (URI -> () -> PackageLocation ()
forall local. URI -> local -> PackageLocation local
RemoteTarballPackage URI
tarballURL ()) ]

localPackageError :: FilePath -> String
localPackageError :: ShowS
localPackageError String
dir =
    String
"Error reading local package.\nCouldn't find .cabal file in: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
dir

-- ------------------------------------------------------------
-- * Fetching and reading package targets
-- ------------------------------------------------------------


-- | Fetch any remote targets so that they can be read.
--
fetchPackageTarget :: Verbosity
                   -> RepoContext
                   -> PackageTarget (PackageLocation ())
                   -> IO (PackageTarget ResolvedPkgLoc)
fetchPackageTarget :: Verbosity
-> RepoContext
-> PackageTarget (PackageLocation ())
-> IO (PackageTarget ResolvedPkgLoc)
fetchPackageTarget Verbosity
verbosity RepoContext
repoCtxt = (PackageLocation () -> IO ResolvedPkgLoc)
-> PackageTarget (PackageLocation ())
-> IO (PackageTarget ResolvedPkgLoc)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((PackageLocation () -> IO ResolvedPkgLoc)
 -> PackageTarget (PackageLocation ())
 -> IO (PackageTarget ResolvedPkgLoc))
-> (PackageLocation () -> IO ResolvedPkgLoc)
-> PackageTarget (PackageLocation ())
-> IO (PackageTarget ResolvedPkgLoc)
forall a b. (a -> b) -> a -> b
$
  Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage Verbosity
verbosity RepoContext
repoCtxt (UnresolvedPkgLoc -> IO ResolvedPkgLoc)
-> (PackageLocation () -> UnresolvedPkgLoc)
-> PackageLocation ()
-> IO ResolvedPkgLoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> Maybe String) -> PackageLocation () -> UnresolvedPkgLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String -> () -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing)


-- | Given a package target that has been fetched, read the .cabal file.
--
-- This only affects targets given by location, named targets are unaffected.
--
readPackageTarget :: Verbosity
                  -> PackageTarget ResolvedPkgLoc
                  -> IO (PackageTarget UnresolvedSourcePackage)
readPackageTarget :: Verbosity
-> PackageTarget ResolvedPkgLoc
-> IO (PackageTarget UnresolvedSourcePackage)
readPackageTarget Verbosity
verbosity = (ResolvedPkgLoc -> IO UnresolvedSourcePackage)
-> PackageTarget ResolvedPkgLoc
-> IO (PackageTarget UnresolvedSourcePackage)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ResolvedPkgLoc -> IO UnresolvedSourcePackage
modifyLocation
  where
    modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage
    modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage
modifyLocation ResolvedPkgLoc
location = case ResolvedPkgLoc
location of

      LocalUnpackedPackage String
dir -> do
        GenericPackageDescription
pkg <- Verbosity -> String -> String -> IO String
tryFindPackageDesc Verbosity
verbosity String
dir (ShowS
localPackageError String
dir) IO String
-> (String -> IO GenericPackageDescription)
-> IO GenericPackageDescription
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                 Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity
        UnresolvedSourcePackage -> IO UnresolvedSourcePackage
forall (m :: * -> *) a. Monad m => a -> m a
return SourcePackage :: forall loc.
PackageId
-> GenericPackageDescription
-> loc
-> PackageDescriptionOverride
-> SourcePackage loc
SourcePackage
          { srcpkgPackageId :: PackageId
srcpkgPackageId     = GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
          , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
          , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = (String -> Maybe String) -> ResolvedPkgLoc -> UnresolvedPkgLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just ResolvedPkgLoc
location
          , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = PackageDescriptionOverride
forall a. Maybe a
Nothing
          }

      LocalTarballPackage String
tarballFile ->
        ResolvedPkgLoc -> String -> String -> IO UnresolvedSourcePackage
readTarballPackageTarget ResolvedPkgLoc
location String
tarballFile String
tarballFile

      RemoteTarballPackage URI
tarballURL String
tarballFile ->
        ResolvedPkgLoc -> String -> String -> IO UnresolvedSourcePackage
readTarballPackageTarget ResolvedPkgLoc
location String
tarballFile (URI -> String
forall a. Show a => a -> String
show URI
tarballURL)

      RepoTarballPackage Repo
_repo PackageId
_pkgid String
_ ->
        String -> IO UnresolvedSourcePackage
forall a. HasCallStack => String -> a
error String
"TODO: readPackageTarget RepoTarballPackage"
        -- For repo tarballs this info should be obtained from the index.

      RemoteSourceRepoPackage SourceRepoMaybe
_srcRepo String
_ ->
        String -> IO UnresolvedSourcePackage
forall a. HasCallStack => String -> a
error String
"TODO: readPackageTarget RemoteSourceRepoPackage"
        -- This can't happen, because it would have errored out already
        -- in fetchPackage, via fetchPackageTarget before it gets to this
        -- function.
        --
        -- When that is corrected, this will also need to be fixed.

    readTarballPackageTarget :: ResolvedPkgLoc -> FilePath -> FilePath -> IO UnresolvedSourcePackage
    readTarballPackageTarget :: ResolvedPkgLoc -> String -> String -> IO UnresolvedSourcePackage
readTarballPackageTarget ResolvedPkgLoc
location String
tarballFile String
tarballOriginalLoc = do
      (String
filename, ByteString
content) <- String -> String -> IO (String, ByteString)
extractTarballPackageCabalFile
                               String
tarballFile String
tarballOriginalLoc
      case ByteString -> Maybe GenericPackageDescription
parsePackageDescription' ByteString
content of
        Maybe GenericPackageDescription
Nothing  -> Verbosity -> String -> IO UnresolvedSourcePackage
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO UnresolvedSourcePackage)
-> String -> IO UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$ String
"Could not parse the cabal file "
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filename String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tarballFile
        Just GenericPackageDescription
pkg ->
          UnresolvedSourcePackage -> IO UnresolvedSourcePackage
forall (m :: * -> *) a. Monad m => a -> m a
return SourcePackage :: forall loc.
PackageId
-> GenericPackageDescription
-> loc
-> PackageDescriptionOverride
-> SourcePackage loc
SourcePackage
            { srcpkgPackageId :: PackageId
srcpkgPackageId     = GenericPackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
            , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
            , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = (String -> Maybe String) -> ResolvedPkgLoc -> UnresolvedPkgLoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just ResolvedPkgLoc
location
            , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = PackageDescriptionOverride
forall a. Maybe a
Nothing
            }

    extractTarballPackageCabalFile :: FilePath -> String
                                   -> IO (FilePath, BS.ByteString)
    extractTarballPackageCabalFile :: String -> String -> IO (String, ByteString)
extractTarballPackageCabalFile String
tarballFile String
tarballOriginalLoc =
          (String -> IO (String, ByteString))
-> ((String, ByteString) -> IO (String, ByteString))
-> Either String (String, ByteString)
-> IO (String, ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> String -> IO (String, ByteString)
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO (String, ByteString))
-> ShowS -> String -> IO (String, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
formatErr) (String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Either String (String, ByteString) -> IO (String, ByteString))
-> (ByteString -> Either String (String, ByteString))
-> ByteString
-> IO (String, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
-> Either String (String, ByteString)
forall a k.
Show a =>
Either a (Map k Entry) -> Either String (String, ByteString)
check
        (Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
 -> Either String (String, ByteString))
-> (ByteString
    -> Either (FormatError, Map TarPath Entry) (Map TarPath Entry))
-> ByteString
-> Either String (String, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries FormatError
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
accumEntryMap
        (Entries FormatError
 -> Either (FormatError, Map TarPath Entry) (Map TarPath Entry))
-> (ByteString -> Entries FormatError)
-> ByteString
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry -> Bool) -> Entries FormatError -> Entries FormatError
forall e. (Entry -> Bool) -> Entries e -> Entries e
Tar.filterEntries Entry -> Bool
isCabalFile
        (Entries FormatError -> Entries FormatError)
-> (ByteString -> Entries FormatError)
-> ByteString
-> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
        (ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZipUtils.maybeDecompress
      (ByteString -> IO (String, ByteString))
-> IO ByteString -> IO (String, ByteString)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile String
tarballFile
      where
        formatErr :: ShowS
formatErr String
msg = String
"Error reading " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tarballOriginalLoc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

        accumEntryMap :: Tar.Entries Tar.FormatError
                      -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry)
        accumEntryMap :: Entries FormatError
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
accumEntryMap = (Map TarPath Entry -> Entry -> Map TarPath Entry)
-> Map TarPath Entry
-> Entries FormatError
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
forall a e. (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
Tar.foldlEntries
                          (\Map TarPath Entry
m Entry
e -> TarPath -> Entry -> Map TarPath Entry -> Map TarPath Entry
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Entry -> TarPath
Tar.entryTarPath Entry
e) Entry
e Map TarPath Entry
m)
                          Map TarPath Entry
forall k a. Map k a
Map.empty

        check :: Either a (Map k Entry) -> Either String (String, ByteString)
check (Left a
e)  = String -> Either String (String, ByteString)
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
e)
        check (Right Map k Entry
m) = case Map k Entry -> [Entry]
forall k a. Map k a -> [a]
Map.elems Map k Entry
m of
            []     -> String -> Either String (String, ByteString)
forall a b. a -> Either a b
Left String
noCabalFile
            [Entry
file] -> case Entry -> EntryContent
Tar.entryContent Entry
file of
              Tar.NormalFile ByteString
content FileSize
_ -> (String, ByteString) -> Either String (String, ByteString)
forall a b. b -> Either a b
Right (Entry -> String
Tar.entryPath Entry
file, ByteString
content)
              EntryContent
_                        -> String -> Either String (String, ByteString)
forall a b. a -> Either a b
Left String
noCabalFile
            [Entry]
_files -> String -> Either String (String, ByteString)
forall a b. a -> Either a b
Left String
multipleCabalFiles
          where
            noCabalFile :: String
noCabalFile        = String
"No cabal file found"
            multipleCabalFiles :: String
multipleCabalFiles = String
"Multiple cabal files found"

        isCabalFile :: Tar.Entry -> Bool
        isCabalFile :: Entry -> Bool
isCabalFile Entry
e = case String -> [String]
splitPath (Entry -> String
Tar.entryPath Entry
e) of
          [     String
_dir, String
file] -> ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal"
          [String
".", String
_dir, String
file] -> ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal"
          [String]
_                 -> Bool
False

    parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription
    parsePackageDescription' :: ByteString -> Maybe GenericPackageDescription
parsePackageDescription' ByteString
bs =
        ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe (ByteString -> ByteString
BS.toStrict ByteString
bs)

-- ------------------------------------------------------------
-- * Checking package targets
-- ------------------------------------------------------------

data PackageTargetProblem
   = PackageNameUnknown   PackageName               UserTarget
   | PackageNameAmbiguous PackageName [PackageName] UserTarget
  deriving Int -> PackageTargetProblem -> ShowS
[PackageTargetProblem] -> ShowS
PackageTargetProblem -> String
(Int -> PackageTargetProblem -> ShowS)
-> (PackageTargetProblem -> String)
-> ([PackageTargetProblem] -> ShowS)
-> Show PackageTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageTargetProblem] -> ShowS
$cshowList :: [PackageTargetProblem] -> ShowS
show :: PackageTargetProblem -> String
$cshow :: PackageTargetProblem -> String
showsPrec :: Int -> PackageTargetProblem -> ShowS
$cshowsPrec :: Int -> PackageTargetProblem -> ShowS
Show


-- | Users are allowed to give package names case-insensitively, so we must
-- disambiguate named package references.
--
disambiguatePackageTargets :: Package pkg'
                           => PackageIndex pkg'
                           -> [PackageName]
                           -> [PackageTarget pkg]
                           -> ( [PackageTargetProblem]
                              , [PackageSpecifier pkg] )
disambiguatePackageTargets :: PackageIndex pkg'
-> [PackageName]
-> [PackageTarget pkg]
-> ([PackageTargetProblem], [PackageSpecifier pkg])
disambiguatePackageTargets PackageIndex pkg'
availablePkgIndex [PackageName]
availableExtra [PackageTarget pkg]
targets =
    [Either PackageTargetProblem (PackageSpecifier pkg)]
-> ([PackageTargetProblem], [PackageSpecifier pkg])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((PackageTarget pkg
 -> Either PackageTargetProblem (PackageSpecifier pkg))
-> [PackageTarget pkg]
-> [Either PackageTargetProblem (PackageSpecifier pkg)]
forall a b. (a -> b) -> [a] -> [b]
map PackageTarget pkg
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall pkg.
PackageTarget pkg
-> Either PackageTargetProblem (PackageSpecifier pkg)
disambiguatePackageTarget [PackageTarget pkg]
targets)
  where
    disambiguatePackageTarget :: PackageTarget pkg
-> Either PackageTargetProblem (PackageSpecifier pkg)
disambiguatePackageTarget PackageTarget pkg
packageTarget = case PackageTarget pkg
packageTarget of
      PackageTargetLocation pkg
pkg -> PackageSpecifier pkg
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall a b. b -> Either a b
Right (pkg -> PackageSpecifier pkg
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage pkg
pkg)

      PackageTargetNamed PackageName
pkgname [PackageProperty]
props UserTarget
userTarget
        | [pkg'] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageIndex pkg' -> PackageName -> [pkg']
forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
PackageIndex.lookupPackageName PackageIndex pkg'
availablePkgIndex PackageName
pkgname)
                    -> PackageTargetProblem
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall a b. a -> Either a b
Left (PackageName -> UserTarget -> PackageTargetProblem
PackageNameUnknown PackageName
pkgname UserTarget
userTarget)
        | Bool
otherwise -> PackageSpecifier pkg
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall a b. b -> Either a b
Right (PackageName -> [PackageProperty] -> PackageSpecifier pkg
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgname [PackageProperty]
props)

      PackageTargetNamedFuzzy PackageName
pkgname [PackageProperty]
props UserTarget
userTarget ->
        case PackageNameEnv -> PackageName -> MaybeAmbiguous PackageName
disambiguatePackageName PackageNameEnv
packageNameEnv PackageName
pkgname of
          MaybeAmbiguous PackageName
None                 -> PackageTargetProblem
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall a b. a -> Either a b
Left  (PackageName -> UserTarget -> PackageTargetProblem
PackageNameUnknown
                                          PackageName
pkgname UserTarget
userTarget)
          Ambiguous   [PackageName]
pkgnames -> PackageTargetProblem
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall a b. a -> Either a b
Left  (PackageName -> [PackageName] -> UserTarget -> PackageTargetProblem
PackageNameAmbiguous
                                          PackageName
pkgname [PackageName]
pkgnames UserTarget
userTarget)
          Unambiguous PackageName
pkgname' -> PackageSpecifier pkg
-> Either PackageTargetProblem (PackageSpecifier pkg)
forall a b. b -> Either a b
Right (PackageName -> [PackageProperty] -> PackageSpecifier pkg
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgname' [PackageProperty]
props)

    -- use any extra specific available packages to help us disambiguate
    packageNameEnv :: PackageNameEnv
    packageNameEnv :: PackageNameEnv
packageNameEnv = PackageNameEnv -> PackageNameEnv -> PackageNameEnv
forall a. Monoid a => a -> a -> a
mappend (PackageIndex pkg' -> PackageNameEnv
forall pkg. PackageIndex pkg -> PackageNameEnv
indexPackageNameEnv PackageIndex pkg'
availablePkgIndex)
                             ([PackageName] -> PackageNameEnv
extraPackageNameEnv [PackageName]
availableExtra)


-- | Report problems to the user. That is, if there are any problems
-- then raise an exception.
reportPackageTargetProblems :: Verbosity
                            -> [PackageTargetProblem] -> IO ()
reportPackageTargetProblems :: Verbosity -> [PackageTargetProblem] -> IO ()
reportPackageTargetProblems Verbosity
verbosity [PackageTargetProblem]
problems = do
    case [ PackageName
pkg | PackageNameUnknown PackageName
pkg UserTarget
_ <- [PackageTargetProblem]
problems ] of
      []    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [PackageName]
pkgs  -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                       [ String
"There is no package named '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. "
                       | PackageName
name <- [PackageName]
pkgs ]
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"You may need to run 'cabal update' to get the latest "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"list of available packages."

    case [ (PackageName
pkg, [PackageName]
matches) | PackageNameAmbiguous PackageName
pkg [PackageName]
matches UserTarget
_ <- [PackageTargetProblem]
problems ] of
      []          -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(PackageName, [PackageName])]
ambiguities -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                         [    String
"There is no package named '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'. "
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if [PackageName] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
matches Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
                               then String
"However, the following package names exist: "
                               else String
"However, the following package name exists: ")
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ String
"'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'" | PackageName
m <- [PackageName]
matches]
                           String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
                         | (PackageName
name, [PackageName]
matches) <- [(PackageName, [PackageName])]
ambiguities ]


-- ------------------------------------------------------------
-- * Disambiguating package names
-- ------------------------------------------------------------

data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]

-- | Given a package name and a list of matching names, figure out
-- which one it might be referring to. If there is an exact
-- case-sensitive match then that's ok (i.e. returned via
-- 'Unambiguous'). If it matches just one package case-insensitively
-- or if it matches multiple packages case-insensitively, in that case
-- the result is 'Ambiguous'.
--
-- Note: Before cabal 2.2, when only a single package matched
--       case-insensitively it would be considered 'Unambiguous'.
--
disambiguatePackageName :: PackageNameEnv
                        -> PackageName
                        -> MaybeAmbiguous PackageName
disambiguatePackageName :: PackageNameEnv -> PackageName -> MaybeAmbiguous PackageName
disambiguatePackageName (PackageNameEnv PackageName -> [PackageName]
pkgNameLookup) PackageName
name =
    case [PackageName] -> [PackageName]
forall a. Eq a => [a] -> [a]
nub (PackageName -> [PackageName]
pkgNameLookup PackageName
name) of
      []      -> MaybeAmbiguous PackageName
forall a. MaybeAmbiguous a
None
      [PackageName]
names   -> case (PackageName -> Bool) -> [PackageName] -> Maybe PackageName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (PackageName
namePackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
==) [PackageName]
names of
                   Just PackageName
name' -> PackageName -> MaybeAmbiguous PackageName
forall a. a -> MaybeAmbiguous a
Unambiguous PackageName
name'
                   Maybe PackageName
Nothing    -> [PackageName] -> MaybeAmbiguous PackageName
forall a. [a] -> MaybeAmbiguous a
Ambiguous [PackageName]
names


newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])

instance Monoid PackageNameEnv where
  mempty :: PackageNameEnv
mempty = (PackageName -> [PackageName]) -> PackageNameEnv
PackageNameEnv ([PackageName] -> PackageName -> [PackageName]
forall a b. a -> b -> a
const [])
  mappend :: PackageNameEnv -> PackageNameEnv -> PackageNameEnv
mappend = PackageNameEnv -> PackageNameEnv -> PackageNameEnv
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup PackageNameEnv where
  PackageNameEnv PackageName -> [PackageName]
lookupA <> :: PackageNameEnv -> PackageNameEnv -> PackageNameEnv
<> PackageNameEnv PackageName -> [PackageName]
lookupB =
    (PackageName -> [PackageName]) -> PackageNameEnv
PackageNameEnv (\PackageName
name -> PackageName -> [PackageName]
lookupA PackageName
name [PackageName] -> [PackageName] -> [PackageName]
forall a. [a] -> [a] -> [a]
++ PackageName -> [PackageName]
lookupB PackageName
name)

indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv
indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv
indexPackageNameEnv PackageIndex pkg
pkgIndex = (PackageName -> [PackageName]) -> PackageNameEnv
PackageNameEnv PackageName -> [PackageName]
pkgNameLookup
  where
    pkgNameLookup :: PackageName -> [PackageName]
pkgNameLookup PackageName
pname =
      ((PackageName, [pkg]) -> PackageName)
-> [(PackageName, [pkg])] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, [pkg]) -> PackageName
forall a b. (a, b) -> a
fst (PackageIndex pkg -> String -> [(PackageName, [pkg])]
forall pkg. PackageIndex pkg -> String -> [(PackageName, [pkg])]
PackageIndex.searchByName PackageIndex pkg
pkgIndex (String -> [(PackageName, [pkg])])
-> String -> [(PackageName, [pkg])]
forall a b. (a -> b) -> a -> b
$ PackageName -> String
unPackageName PackageName
pname)

extraPackageNameEnv :: [PackageName] -> PackageNameEnv
extraPackageNameEnv :: [PackageName] -> PackageNameEnv
extraPackageNameEnv [PackageName]
names = (PackageName -> [PackageName]) -> PackageNameEnv
PackageNameEnv PackageName -> [PackageName]
pkgNameLookup
  where
    pkgNameLookup :: PackageName -> [PackageName]
pkgNameLookup PackageName
pname =
      [ PackageName
pname'
      | let lname :: String
lname = ShowS
lowercase (PackageName -> String
unPackageName PackageName
pname)
      , PackageName
pname' <- [PackageName]
names
      , ShowS
lowercase (PackageName -> String
unPackageName PackageName
pname') String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
lname ]


-- ------------------------------------------------------------
-- * Package constraints
-- ------------------------------------------------------------

-- | Version of 'Qualifier' that a user may specify on the
-- command line.
data UserQualifier =
  -- | Top-level dependency.
  UserQualToplevel

  -- | Setup dependency.
  | UserQualSetup PackageName

  -- | Executable dependency.
  | UserQualExe PackageName PackageName
  deriving (UserQualifier -> UserQualifier -> Bool
(UserQualifier -> UserQualifier -> Bool)
-> (UserQualifier -> UserQualifier -> Bool) -> Eq UserQualifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserQualifier -> UserQualifier -> Bool
$c/= :: UserQualifier -> UserQualifier -> Bool
== :: UserQualifier -> UserQualifier -> Bool
$c== :: UserQualifier -> UserQualifier -> Bool
Eq, Int -> UserQualifier -> ShowS
[UserQualifier] -> ShowS
UserQualifier -> String
(Int -> UserQualifier -> ShowS)
-> (UserQualifier -> String)
-> ([UserQualifier] -> ShowS)
-> Show UserQualifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserQualifier] -> ShowS
$cshowList :: [UserQualifier] -> ShowS
show :: UserQualifier -> String
$cshow :: UserQualifier -> String
showsPrec :: Int -> UserQualifier -> ShowS
$cshowsPrec :: Int -> UserQualifier -> ShowS
Show, (forall x. UserQualifier -> Rep UserQualifier x)
-> (forall x. Rep UserQualifier x -> UserQualifier)
-> Generic UserQualifier
forall x. Rep UserQualifier x -> UserQualifier
forall x. UserQualifier -> Rep UserQualifier x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserQualifier x -> UserQualifier
$cfrom :: forall x. UserQualifier -> Rep UserQualifier x
Generic)

instance Binary UserQualifier
instance Structured UserQualifier

-- | Version of 'ConstraintScope' that a user may specify on the
-- command line.
data UserConstraintScope =
  -- | Scope that applies to the package when it has the specified qualifier.
  UserQualified UserQualifier PackageName

  -- | Scope that applies to the package when it has a setup qualifier.
  | UserAnySetupQualifier PackageName

  -- | Scope that applies to the package when it has any qualifier.
  | UserAnyQualifier PackageName
  deriving (UserConstraintScope -> UserConstraintScope -> Bool
(UserConstraintScope -> UserConstraintScope -> Bool)
-> (UserConstraintScope -> UserConstraintScope -> Bool)
-> Eq UserConstraintScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserConstraintScope -> UserConstraintScope -> Bool
$c/= :: UserConstraintScope -> UserConstraintScope -> Bool
== :: UserConstraintScope -> UserConstraintScope -> Bool
$c== :: UserConstraintScope -> UserConstraintScope -> Bool
Eq, Int -> UserConstraintScope -> ShowS
[UserConstraintScope] -> ShowS
UserConstraintScope -> String
(Int -> UserConstraintScope -> ShowS)
-> (UserConstraintScope -> String)
-> ([UserConstraintScope] -> ShowS)
-> Show UserConstraintScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserConstraintScope] -> ShowS
$cshowList :: [UserConstraintScope] -> ShowS
show :: UserConstraintScope -> String
$cshow :: UserConstraintScope -> String
showsPrec :: Int -> UserConstraintScope -> ShowS
$cshowsPrec :: Int -> UserConstraintScope -> ShowS
Show, (forall x. UserConstraintScope -> Rep UserConstraintScope x)
-> (forall x. Rep UserConstraintScope x -> UserConstraintScope)
-> Generic UserConstraintScope
forall x. Rep UserConstraintScope x -> UserConstraintScope
forall x. UserConstraintScope -> Rep UserConstraintScope x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserConstraintScope x -> UserConstraintScope
$cfrom :: forall x. UserConstraintScope -> Rep UserConstraintScope x
Generic)

instance Binary UserConstraintScope
instance Structured UserConstraintScope

fromUserQualifier :: UserQualifier -> Qualifier
fromUserQualifier :: UserQualifier -> Qualifier
fromUserQualifier UserQualifier
UserQualToplevel = Qualifier
QualToplevel
fromUserQualifier (UserQualSetup PackageName
name) = PackageName -> Qualifier
QualSetup PackageName
name
fromUserQualifier (UserQualExe PackageName
name1 PackageName
name2) = PackageName -> PackageName -> Qualifier
QualExe PackageName
name1 PackageName
name2

fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
fromUserConstraintScope (UserQualified UserQualifier
q PackageName
pn) =
    Qualifier -> PackageName -> ConstraintScope
ScopeQualified (UserQualifier -> Qualifier
fromUserQualifier UserQualifier
q) PackageName
pn
fromUserConstraintScope (UserAnySetupQualifier PackageName
pn) = PackageName -> ConstraintScope
ScopeAnySetupQualifier PackageName
pn
fromUserConstraintScope (UserAnyQualifier PackageName
pn) = PackageName -> ConstraintScope
ScopeAnyQualifier PackageName
pn

-- | Version of 'PackageConstraint' that the user can specify on
-- the command line.
data UserConstraint =
    UserConstraint UserConstraintScope PackageProperty
  deriving (UserConstraint -> UserConstraint -> Bool
(UserConstraint -> UserConstraint -> Bool)
-> (UserConstraint -> UserConstraint -> Bool) -> Eq UserConstraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserConstraint -> UserConstraint -> Bool
$c/= :: UserConstraint -> UserConstraint -> Bool
== :: UserConstraint -> UserConstraint -> Bool
$c== :: UserConstraint -> UserConstraint -> Bool
Eq, Int -> UserConstraint -> ShowS
[UserConstraint] -> ShowS
UserConstraint -> String
(Int -> UserConstraint -> ShowS)
-> (UserConstraint -> String)
-> ([UserConstraint] -> ShowS)
-> Show UserConstraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserConstraint] -> ShowS
$cshowList :: [UserConstraint] -> ShowS
show :: UserConstraint -> String
$cshow :: UserConstraint -> String
showsPrec :: Int -> UserConstraint -> ShowS
$cshowsPrec :: Int -> UserConstraint -> ShowS
Show, (forall x. UserConstraint -> Rep UserConstraint x)
-> (forall x. Rep UserConstraint x -> UserConstraint)
-> Generic UserConstraint
forall x. Rep UserConstraint x -> UserConstraint
forall x. UserConstraint -> Rep UserConstraint x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserConstraint x -> UserConstraint
$cfrom :: forall x. UserConstraint -> Rep UserConstraint x
Generic)

instance Binary UserConstraint
instance Structured UserConstraint

userConstraintPackageName :: UserConstraint -> PackageName
userConstraintPackageName :: UserConstraint -> PackageName
userConstraintPackageName (UserConstraint UserConstraintScope
scope PackageProperty
_) = UserConstraintScope -> PackageName
scopePN UserConstraintScope
scope
  where
    scopePN :: UserConstraintScope -> PackageName
scopePN (UserQualified UserQualifier
_ PackageName
pn) = PackageName
pn
    scopePN (UserAnyQualifier PackageName
pn) = PackageName
pn
    scopePN (UserAnySetupQualifier PackageName
pn) = PackageName
pn

userToPackageConstraint :: UserConstraint -> PackageConstraint
userToPackageConstraint :: UserConstraint -> PackageConstraint
userToPackageConstraint (UserConstraint UserConstraintScope
scope PackageProperty
prop) =
  ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint (UserConstraintScope -> ConstraintScope
fromUserConstraintScope UserConstraintScope
scope) PackageProperty
prop

readUserConstraint :: String -> Either String UserConstraint
readUserConstraint :: String -> Either String UserConstraint
readUserConstraint String
str =
    case ParsecParser UserConstraint
-> String -> Either String UserConstraint
forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser UserConstraint
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec String
str of
      Left String
err -> String -> Either String UserConstraint
forall a b. a -> Either a b
Left (String -> Either String UserConstraint)
-> String -> Either String UserConstraint
forall a b. (a -> b) -> a -> b
$ String
msgCannotParse String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
      Right UserConstraint
c  -> UserConstraint -> Either String UserConstraint
forall a b. b -> Either a b
Right UserConstraint
c
  where
    msgCannotParse :: String
msgCannotParse =
         String
"expected a (possibly qualified) package name followed by a " String -> ShowS
forall a. [a] -> [a] -> [a]
++
         String
"constraint, which is either a version range, 'installed', " String -> ShowS
forall a. [a] -> [a] -> [a]
++
         String
"'source', 'test', 'bench', or flags. "

instance Pretty UserConstraint where
  pretty :: UserConstraint -> Doc
pretty (UserConstraint UserConstraintScope
scope PackageProperty
prop) =
    PackageConstraint -> Doc
dispPackageConstraint (PackageConstraint -> Doc) -> PackageConstraint -> Doc
forall a b. (a -> b) -> a -> b
$ ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint (UserConstraintScope -> ConstraintScope
fromUserConstraintScope UserConstraintScope
scope) PackageProperty
prop

instance Parsec UserConstraint where
    parsec :: m UserConstraint
parsec = do
        UserConstraintScope
scope <- m UserConstraintScope
forall (m :: * -> *). CabalParsing m => m UserConstraintScope
parseConstraintScope
        m ()
forall (m :: * -> *). CharParsing m => m ()
P.spaces
        PackageProperty
prop <- [m PackageProperty] -> m PackageProperty
forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice
            [ FlagAssignment -> PackageProperty
PackagePropertyFlags                  (FlagAssignment -> PackageProperty)
-> m FlagAssignment -> m PackageProperty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FlagAssignment
forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsecFlagAssignmentNonEmpty -- headed by "+-"
            , VersionRange -> PackageProperty
PackagePropertyVersion                (VersionRange -> PackageProperty)
-> m VersionRange -> m PackageProperty
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m VersionRange
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec                       -- headed by "<=>" (will be)
            , PackageProperty
PackagePropertyInstalled              PackageProperty -> m String -> m PackageProperty
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"installed"
            , PackageProperty
PackagePropertySource                 PackageProperty -> m String -> m PackageProperty
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"source"
            , [OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza
TestStanzas]  PackageProperty -> m String -> m PackageProperty
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"test"
            , [OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza
BenchStanzas] PackageProperty -> m String -> m PackageProperty
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"bench"
            ]
        UserConstraint -> m UserConstraint
forall (m :: * -> *) a. Monad m => a -> m a
return (UserConstraintScope -> PackageProperty -> UserConstraint
UserConstraint UserConstraintScope
scope PackageProperty
prop)

      where
        parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
        parseConstraintScope :: m UserConstraintScope
parseConstraintScope = do
            PackageName
pn <- m PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
            [m UserConstraintScope] -> m UserConstraintScope
forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice
                [ Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'.' m Char -> m UserConstraintScope -> m UserConstraintScope
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageName -> m UserConstraintScope
withDot PackageName
pn
                , Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' m Char -> m UserConstraintScope -> m UserConstraintScope
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageName -> m UserConstraintScope
withColon PackageName
pn
                , UserConstraintScope -> m UserConstraintScope
forall (m :: * -> *) a. Monad m => a -> m a
return (UserQualifier -> PackageName -> UserConstraintScope
UserQualified UserQualifier
UserQualToplevel PackageName
pn)
                ]
          where
            withDot :: PackageName -> m UserConstraintScope
            withDot :: PackageName -> m UserConstraintScope
withDot PackageName
pn
                | PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"any"   = PackageName -> UserConstraintScope
UserAnyQualifier (PackageName -> UserConstraintScope)
-> m PackageName -> m UserConstraintScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
                | PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"setup" = PackageName -> UserConstraintScope
UserAnySetupQualifier (PackageName -> UserConstraintScope)
-> m PackageName -> m UserConstraintScope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
                | Bool
otherwise                   = String -> m UserConstraintScope
forall (m :: * -> *) a. Parsing m => String -> m a
P.unexpected (String -> m UserConstraintScope)
-> String -> m UserConstraintScope
forall a b. (a -> b) -> a -> b
$ String
"constraint scope: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageName -> String
unPackageName PackageName
pn

            withColon :: PackageName -> m UserConstraintScope
            withColon :: PackageName -> m UserConstraintScope
withColon PackageName
pn = UserQualifier -> PackageName -> UserConstraintScope
UserQualified (PackageName -> UserQualifier
UserQualSetup PackageName
pn)
                (PackageName -> UserConstraintScope)
-> m String -> m (PackageName -> UserConstraintScope)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  String -> m String
forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"setup."
                m (PackageName -> UserConstraintScope)
-> m PackageName -> m UserConstraintScope
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec