{-# 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
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
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) <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. [Either a b] -> ([a], [b])
partitionEithers
                                 (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
    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
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 forall a. Parsec a => String -> Either String a
eitherParsec String
targetstr of
      Right PackageVersionConstraint
dep -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return Either UserTargetProblem UserTarget
target
              Maybe (Either UserTargetProblem UserTarget)
Nothing     -> forall (m :: * -> *) a. Monad m => a -> m a
return (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
                           []  -> 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
            = forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right (String -> UserTarget
UserTargetLocalDir String
filename))

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

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

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

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

            | Bool
otherwise
            = forall a. Maybe a
Nothing
      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 forall a. Eq a => a -> a -> Bool
/= String
"http:" Bool -> Bool -> Bool
&& String
scheme forall a. Eq a => a -> a -> Bool
/= String
"https:" ->
            forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left (String -> UserTargetProblem
UserTargetUnexpectedUriScheme String
targetstr))

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

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

    extensionIsTarGz :: FilePath -> Bool
    extensionIsTarGz :: String -> Bool
extensionIsTarGz String
f = ShowS
takeExtension String
f                 forall a. Eq a => a -> a -> Bool
== String
".gz"
                      Bool -> Bool -> Bool
&& ShowS
takeExtension (ShowS
dropExtension String
f) 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
      []     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"Unrecognised target '" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]
             forall a. [a] -> [a] -> [a]
++ String
"Targets can be:\n"
             forall a. [a] -> [a] -> [a]
++ String
" - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
             forall a. [a] -> [a] -> [a]
++ String
" - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
             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
      []     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"The file does not exist '" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"'."
                  | String
name <- [String]
target ]

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

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

    case [ String
target | UserTargetUnrecognisedUri String
target <- [UserTargetProblem]
problems ] of
      []     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [String]
target -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity
              forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                  [ String
"Unrecognise URL target '" forall a. [a] -> [a] -> [a]
++ String
name 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 :: forall pkg.
Package pkg =>
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 <- 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)
                  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                  forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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]) =
           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 = [ forall pkg. Package pkg => pkg -> PackageName
packageName UnresolvedSourcePackage
pkg
                         | PackageTargetLocation UnresolvedSourcePackage
pkg <- [PackageTarget UnresolvedSourcePackage]
packageTargets ]

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

    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
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, 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
<$ :: forall a b. a -> PackageTarget b -> PackageTarget a
$c<$ :: forall a b. a -> PackageTarget b -> PackageTarget a
fmap :: forall a b. (a -> b) -> PackageTarget a -> PackageTarget b
$cfmap :: forall a b. (a -> b) -> PackageTarget a -> PackageTarget b
Functor, 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 :: forall a. Num a => PackageTarget a -> a
$cproduct :: forall a. Num a => PackageTarget a -> a
sum :: forall a. Num a => PackageTarget a -> a
$csum :: forall a. Num a => PackageTarget a -> a
minimum :: forall a. Ord a => PackageTarget a -> a
$cminimum :: forall a. Ord a => PackageTarget a -> a
maximum :: forall a. Ord a => PackageTarget a -> a
$cmaximum :: forall a. Ord a => PackageTarget a -> a
elem :: forall a. Eq a => a -> PackageTarget a -> Bool
$celem :: forall a. Eq a => a -> PackageTarget a -> Bool
length :: forall a. PackageTarget a -> Int
$clength :: forall a. PackageTarget a -> Int
null :: forall a. PackageTarget a -> Bool
$cnull :: forall a. PackageTarget a -> Bool
toList :: forall a. PackageTarget a -> [a]
$ctoList :: forall a. PackageTarget a -> [a]
foldl1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
foldr1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
foldl :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
foldr :: forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> PackageTarget a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
fold :: forall m. Monoid m => PackageTarget m -> m
$cfold :: forall m. Monoid m => PackageTarget m -> m
Foldable, Functor PackageTarget
Foldable PackageTarget
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 :: forall (m :: * -> *) a.
Monad m =>
PackageTarget (m a) -> m (PackageTarget a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PackageTarget (m a) -> m (PackageTarget a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PackageTarget a -> m (PackageTarget b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PackageTarget a -> m (PackageTarget b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PackageTarget (f a) -> f (PackageTarget a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PackageTarget (f a) -> f (PackageTarget a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
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  forall (m :: * -> *) a. Monad m => a -> m a
return [forall pkg.
PackageName -> [PackageProperty] -> UserTarget -> PackageTarget pkg
PackageTargetNamedFuzzy PackageName
name [PackageProperty]
props UserTarget
userTarget]

    UserTargetLocalDir String
dir ->
      forall (m :: * -> *) a. Monad m => a -> m a
return [ forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (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
      forall (m :: * -> *) a. Monad m => a -> m a
return [ forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (forall local. String -> PackageLocation local
LocalUnpackedPackage String
dir) ]

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

    UserTargetRemoteTarball URI
tarballURL ->
      forall (m :: * -> *) a. Monad m => a -> m a
return [ forall pkg. pkg -> PackageTarget pkg
PackageTargetLocation (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: " 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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$
  Verbosity -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
fetchPackage Verbosity
verbosity RepoContext
repoCtxt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const 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 = 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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                 Verbosity -> String -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
verbosity
        forall (m :: * -> *) a. Monad m => a -> m a
return SourcePackage
          { srcpkgPackageId :: PackageId
srcpkgPackageId     = forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
          , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
          , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just ResolvedPkgLoc
location
          , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = 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 (forall a. Show a => a -> String
show URI
tarballURL)

      RepoTarballPackage Repo
_repo PackageId
_pkgid String
_ ->
        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
_ ->
        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  -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ String
"Could not parse the cabal file "
                       forall a. [a] -> [a] -> [a]
++ String
filename forall a. [a] -> [a] -> [a]
++ String
" in " forall a. [a] -> [a] -> [a]
++ String
tarballFile
        Just GenericPackageDescription
pkg ->
          forall (m :: * -> *) a. Monad m => a -> m a
return SourcePackage
            { srcpkgPackageId :: PackageId
srcpkgPackageId     = forall pkg. Package pkg => pkg -> PackageId
packageId GenericPackageDescription
pkg
            , srcpkgDescription :: GenericPackageDescription
srcpkgDescription   = GenericPackageDescription
pkg
            , srcpkgSource :: UnresolvedPkgLoc
srcpkgSource        = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just ResolvedPkgLoc
location
            , srcpkgDescrOverride :: PackageDescriptionOverride
srcpkgDescrOverride = forall a. Maybe a
Nothing
            }

    extractTarballPackageCabalFile :: FilePath -> String
                                   -> IO (FilePath, BS.ByteString)
    extractTarballPackageCabalFile :: String -> String -> IO (String, ByteString)
extractTarballPackageCabalFile String
tarballFile String
tarballOriginalLoc =
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
formatErr) forall (m :: * -> *) a. Monad m => a -> m a
return
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {k}.
Show a =>
Either a (Map k Entry) -> Either String (String, ByteString)
check
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries FormatError
-> Either (FormatError, Map TarPath Entry) (Map TarPath Entry)
accumEntryMap
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. (Entry -> Bool) -> Entries e -> Entries e
Tar.filterEntries Entry -> Bool
isCabalFile
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZipUtils.maybeDecompress
      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 " forall a. [a] -> [a] -> [a]
++ String
tarballOriginalLoc forall a. [a] -> [a] -> [a]
++ String
": " 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 = forall a e. (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
Tar.foldlEntries
                          (\Map TarPath Entry
m Entry
e -> 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)
                          forall k a. Map k a
Map.empty

        check :: Either a (Map k Entry) -> Either String (String, ByteString)
check (Left a
e)  = forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show a
e)
        check (Right Map k Entry
m) = case forall k a. Map k a -> [a]
Map.elems Map k Entry
m of
            []     -> 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
_ -> forall a b. b -> Either a b
Right (Entry -> String
Tar.entryPath Entry
file, ByteString
content)
              EntryContent
_                        -> forall a b. a -> Either a b
Left String
noCabalFile
            [Entry]
_files -> 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 forall a. Eq a => a -> a -> Bool
== String
".cabal"
          [String
".", String
_dir, String
file] -> ShowS
takeExtension String
file 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
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 :: forall pkg' pkg.
Package pkg' =>
PackageIndex pkg'
-> [PackageName]
-> [PackageTarget pkg]
-> ([PackageTargetProblem], [PackageSpecifier pkg])
disambiguatePackageTargets PackageIndex pkg'
availablePkgIndex [PackageName]
availableExtra [PackageTarget pkg]
targets =
    forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map 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 -> forall a b. b -> Either a b
Right (forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage pkg
pkg)

      PackageTargetNamed PackageName
pkgname [PackageProperty]
props UserTarget
userTarget
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
PackageIndex.lookupPackageName PackageIndex pkg'
availablePkgIndex PackageName
pkgname)
                    -> forall a b. a -> Either a b
Left (PackageName -> UserTarget -> PackageTargetProblem
PackageNameUnknown PackageName
pkgname UserTarget
userTarget)
        | Bool
otherwise -> forall a b. b -> Either a b
Right (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                 -> forall a b. a -> Either a b
Left  (PackageName -> UserTarget -> PackageTargetProblem
PackageNameUnknown
                                          PackageName
pkgname UserTarget
userTarget)
          Ambiguous   [PackageName]
pkgnames -> forall a b. a -> Either a b
Left  (PackageName -> [PackageName] -> UserTarget -> PackageTargetProblem
PackageNameAmbiguous
                                          PackageName
pkgname [PackageName]
pkgnames UserTarget
userTarget)
          Unambiguous PackageName
pkgname' -> forall a b. b -> Either a b
Right (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 = forall a. Monoid a => a -> a -> a
mappend (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
      []    -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [PackageName]
pkgs  -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                       [ String
"There is no package named '" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow PackageName
name forall a. [a] -> [a] -> [a]
++ String
"'. "
                       | PackageName
name <- [PackageName]
pkgs ]
                  forall a. [a] -> [a] -> [a]
++ String
"You may need to run 'cabal update' to get the latest "
                  forall a. [a] -> [a] -> [a]
++ String
"list of available packages."

    case [ (PackageName
pkg, [PackageName]
matches) | PackageNameAmbiguous PackageName
pkg [PackageName]
matches UserTarget
_ <- [PackageTargetProblem]
problems ] of
      []          -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(PackageName, [PackageName])]
ambiguities -> forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
                         [    String
"There is no package named '" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow PackageName
name forall a. [a] -> [a] -> [a]
++ String
"'. "
                           forall a. [a] -> [a] -> [a]
++ (if forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageName]
matches 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: ")
                           forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ String
"'" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow PackageName
m forall a. [a] -> [a] -> [a]
++ String
"'" | PackageName
m <- [PackageName]
matches]
                           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 forall a. Eq a => [a] -> [a]
nub (PackageName -> [PackageName]
pkgNameLookup PackageName
name) of
      []      -> forall a. MaybeAmbiguous a
None
      [PackageName]
names   -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (PackageName
nameforall a. Eq a => a -> a -> Bool
==) [PackageName]
names of
                   Just PackageName
name' -> forall a. a -> MaybeAmbiguous a
Unambiguous PackageName
name'
                   Maybe PackageName
Nothing    -> forall a. [a] -> MaybeAmbiguous a
Ambiguous [PackageName]
names


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

instance Monoid PackageNameEnv where
  mempty :: PackageNameEnv
mempty = (PackageName -> [PackageName]) -> PackageNameEnv
PackageNameEnv (forall a b. a -> b -> a
const [])
  mappend :: PackageNameEnv -> PackageNameEnv -> PackageNameEnv
mappend = 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 forall a. [a] -> [a] -> [a]
++ PackageName -> [PackageName]
lookupB PackageName
name)

indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv
indexPackageNameEnv :: forall pkg. PackageIndex pkg -> PackageNameEnv
indexPackageNameEnv PackageIndex pkg
pkgIndex = (PackageName -> [PackageName]) -> PackageNameEnv
PackageNameEnv PackageName -> [PackageName]
pkgNameLookup
  where
    pkgNameLookup :: PackageName -> [PackageName]
pkgNameLookup PackageName
pname =
      forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall pkg. PackageIndex pkg -> String -> [(PackageName, [pkg])]
PackageIndex.searchByName PackageIndex pkg
pkgIndex 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') 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
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
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. 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
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
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. 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
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
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. 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 forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec String
str of
      Left String
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
msgCannotParse forall a. [a] -> [a] -> [a]
++ String
err
      Right UserConstraint
c  -> forall a b. b -> Either a b
Right UserConstraint
c
  where
    msgCannotParse :: String
msgCannotParse =
         String
"expected a (possibly qualified) package name followed by a " forall a. [a] -> [a] -> [a]
++
         String
"constraint, which is either a version range, 'installed', " 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 forall a b. (a -> b) -> a -> b
$ ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint (UserConstraintScope -> ConstraintScope
fromUserConstraintScope UserConstraintScope
scope) PackageProperty
prop

instance Parsec UserConstraint where
    parsec :: forall (m :: * -> *). CabalParsing m => m UserConstraint
parsec = do
        UserConstraintScope
scope <- forall (m :: * -> *). CabalParsing m => m UserConstraintScope
parseConstraintScope
        forall (m :: * -> *). CharParsing m => m ()
P.spaces
        PackageProperty
prop <- forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice
            [ FlagAssignment -> PackageProperty
PackagePropertyFlags                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsecFlagAssignmentNonEmpty -- headed by "+-"
            , VersionRange -> PackageProperty
PackagePropertyVersion                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec                       -- headed by "<=>" (will be)
            , PackageProperty
PackagePropertyInstalled              forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"installed"
            , PackageProperty
PackagePropertySource                 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"source"
            , [OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza
TestStanzas]  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"test"
            , [OptionalStanza] -> PackageProperty
PackagePropertyStanzas [OptionalStanza
BenchStanzas] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"bench"
            ]
        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 :: forall (m :: * -> *). CabalParsing m => m UserConstraintScope
parseConstraintScope = do
            PackageName
pn <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
            forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice
                [ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'.' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageName -> m UserConstraintScope
withDot PackageName
pn
                , forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageName -> m UserConstraintScope
withColon PackageName
pn
                , 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 forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"any"   = PackageName -> UserConstraintScope
UserAnyQualifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
                | PackageName
pn forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"setup" = PackageName -> UserConstraintScope
UserAnySetupQualifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
                | Bool
otherwise                   = forall (m :: * -> *) a. Parsing m => String -> m a
P.unexpected forall a b. (a -> b) -> a -> b
$ String
"constraint scope: " 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)
                forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$  forall (m :: * -> *). CharParsing m => String -> m String
P.string String
"setup."
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec