{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- 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 Distribution.Client.Compat.Prelude
import Prelude ()

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

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

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

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

import Distribution.PackageDescription.Parsec
  ( parseGenericPackageDescriptionMaybe
  )

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

-- ------------------------------------------------------------

-- * 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
$cshowsPrec :: Int -> UserTarget -> ShowS
showsPrec :: Int -> UserTarget -> ShowS
$cshow :: UserTarget -> String
show :: UserTarget -> String
$cshowList :: [UserTarget] -> ShowS
showList :: [UserTarget] -> ShowS
Show, UserTarget -> UserTarget -> Bool
(UserTarget -> UserTarget -> Bool)
-> (UserTarget -> UserTarget -> Bool) -> Eq UserTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserTarget -> UserTarget -> Bool
== :: UserTarget -> UserTarget -> Bool
$c/= :: UserTarget -> UserTarget -> Bool
/= :: 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> IO (Either UserTargetProblem UserTarget)
readUserTarget [String]
targetStrs)
  Verbosity -> [UserTargetProblem] -> IO ()
reportUserTargetProblems Verbosity
verbosity [UserTargetProblem]
problems
  [UserTarget] -> IO [UserTarget]
forall a. a -> IO a
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
$cshowsPrec :: Int -> UserTargetProblem -> ShowS
showsPrec :: Int -> UserTargetProblem -> ShowS
$cshow :: UserTargetProblem -> String
show :: UserTargetProblem -> String
$cshowList :: [UserTargetProblem] -> ShowS
showList :: [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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
target ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
ReportUserTargetProblems [String]
target
  case [String
target | UserTargetNonexistantFile String
target <- [UserTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
target ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
ReportUserTargerNonexistantFile [String]
target

  case [String
target | UserTargetUnexpectedFile String
target <- [UserTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
target ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
ReportUserTargetUnexpectedFile [String]
target

  case [String
target | UserTargetUnexpectedUriScheme String
target <- [UserTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
target ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
ReportUserTargetUnexpectedUriScheme [String]
target

  case [String
target | UserTargetUnrecognisedUri String
target <- [UserTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
target ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
ReportUserTargetUnrecognisedUri [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 <-
    (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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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 a. a -> IO a
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
$cshowsPrec :: forall pkg. Show pkg => Int -> PackageTarget pkg -> ShowS
showsPrec :: Int -> PackageTarget pkg -> ShowS
$cshow :: forall pkg. Show pkg => PackageTarget pkg -> String
show :: PackageTarget pkg -> String
$cshowList :: forall pkg. Show pkg => [PackageTarget pkg] -> ShowS
showList :: [PackageTarget pkg] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> PackageTarget a -> PackageTarget b
fmap :: forall a b. (a -> b) -> PackageTarget a -> PackageTarget b
$c<$ :: forall a b. a -> PackageTarget b -> PackageTarget a
<$ :: forall a b. a -> PackageTarget b -> PackageTarget a
Functor, (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
$cfold :: forall m. Monoid m => PackageTarget m -> m
fold :: forall m. Monoid m => PackageTarget m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> PackageTarget a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> PackageTarget a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
foldr1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
foldl1 :: forall a. (a -> a -> a) -> PackageTarget a -> a
$ctoList :: forall a. PackageTarget a -> [a]
toList :: forall a. PackageTarget a -> [a]
$cnull :: forall a. PackageTarget a -> Bool
null :: forall a. PackageTarget a -> Bool
$clength :: forall a. PackageTarget a -> Int
length :: forall a. PackageTarget a -> Int
$celem :: forall a. Eq a => a -> PackageTarget a -> Bool
elem :: forall a. Eq a => a -> PackageTarget a -> Bool
$cmaximum :: forall a. Ord a => PackageTarget a -> a
maximum :: forall a. Ord a => PackageTarget a -> a
$cminimum :: forall a. Ord a => PackageTarget a -> a
minimum :: forall a. Ord a => PackageTarget a -> a
$csum :: forall a. Num a => PackageTarget a -> a
sum :: forall a. Num a => PackageTarget a -> a
$cproduct :: forall a. Num a => PackageTarget a -> a
product :: forall a. Num a => PackageTarget a -> a
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
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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PackageTarget (f a) -> f (PackageTarget a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PackageTarget (f a) -> f (PackageTarget a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PackageTarget a -> m (PackageTarget b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PackageTarget a -> m (PackageTarget b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PackageTarget (m a) -> m (PackageTarget a)
sequence :: forall (m :: * -> *) a.
Monad m =>
PackageTarget (m a) -> m (PackageTarget a)
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 a. a -> IO a
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 a. a -> IO a
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
    GenericPackageDescription
_ <- Verbosity
-> SymbolicPath CWD ('Dir Pkg)
-> String
-> IO GenericPackageDescription
tryReadGenericPackageDesc Verbosity
verbosity (String -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath String
dir) (ShowS
localPackageError String
dir) -- just as a check
    [PackageTarget (PackageLocation ())]
-> IO [PackageTarget (PackageLocation ())]
forall a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget 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 a b. (a -> b) -> PackageLocation a -> PackageLocation b
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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PackageTarget a -> f (PackageTarget 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
-> SymbolicPath CWD ('Dir Pkg)
-> String
-> IO GenericPackageDescription
tryReadGenericPackageDesc Verbosity
verbosity (String -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath String
dir) (ShowS
localPackageError String
dir)
        UnresolvedSourcePackage -> IO UnresolvedSourcePackage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
          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 a b. (a -> b) -> PackageLocation a -> PackageLocation b
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 -> CabalInstallException -> IO UnresolvedSourcePackage
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO UnresolvedSourcePackage)
-> CabalInstallException -> IO UnresolvedSourcePackage
forall a b. (a -> b) -> a -> b
$ String -> String -> CabalInstallException
ReadTarballPackageTarget String
filename String
tarballFile
        Just GenericPackageDescription
pkg ->
          UnresolvedSourcePackage -> IO UnresolvedSourcePackage
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
            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 a b. (a -> b) -> PackageLocation a -> PackageLocation b
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 -> CabalInstallException -> IO (String, ByteString)
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO (String, ByteString))
-> (String -> CabalInstallException)
-> String
-> IO (String, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CabalInstallException
ExtractTarballPackageErr (String -> CabalInstallException)
-> ShowS -> String -> CabalInstallException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
formatErr) (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
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} {linkTarget}.
Show a =>
Either a (Map k (GenEntry TarPath linkTarget))
-> 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 tarPath linkTarget e.
(a -> GenEntry tarPath linkTarget -> a)
-> a -> GenEntries tarPath linkTarget 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
forall tarPath linkTarget. GenEntry tarPath linkTarget -> 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 (GenEntry TarPath linkTarget))
-> 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 (GenEntry TarPath linkTarget)
m) = case Map k (GenEntry TarPath linkTarget)
-> [GenEntry TarPath linkTarget]
forall k a. Map k a -> [a]
Map.elems Map k (GenEntry TarPath linkTarget)
m of
          [] -> String -> Either String (String, ByteString)
forall a b. a -> Either a b
Left String
noCabalFile
          [GenEntry TarPath linkTarget
file] -> case GenEntry TarPath linkTarget -> GenEntryContent linkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent GenEntry TarPath linkTarget
file of
            Tar.NormalFile ByteString
content FileSize
_ -> (String, ByteString) -> Either String (String, ByteString)
forall a b. b -> Either a b
Right (GenEntry TarPath linkTarget -> String
forall linkTarget. GenEntry TarPath linkTarget -> String
Tar.entryPath GenEntry TarPath linkTarget
file, ByteString
content)
            GenEntryContent linkTarget
_ -> String -> Either String (String, ByteString)
forall a b. a -> Either a b
Left String
noCabalFile
          [GenEntry TarPath linkTarget]
_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
forall linkTarget. GenEntry TarPath linkTarget -> 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
$cshowsPrec :: Int -> PackageTargetProblem -> ShowS
showsPrec :: Int -> PackageTargetProblem -> ShowS
$cshow :: PackageTargetProblem -> String
show :: PackageTargetProblem -> String
$cshowList :: [PackageTargetProblem] -> ShowS
showList :: [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 =
  [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 a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [PackageName]
pkgs ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [PackageName] -> CabalInstallException
ReportPackageTargetProblems [PackageName]
pkgs

  case [(PackageName
pkg, [PackageName]
matches) | PackageNameAmbiguous PackageName
pkg [PackageName]
matches UserTarget
_ <- [PackageTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(PackageName, [PackageName])]
ambiguities ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [(PackageName, [PackageName])] -> CabalInstallException
PackageNameAmbiguousErr [(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
name PackageName -> 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 :: forall pkg. 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
$c== :: UserQualifier -> UserQualifier -> Bool
== :: UserQualifier -> UserQualifier -> Bool
$c/= :: UserQualifier -> UserQualifier -> Bool
/= :: 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
$cshowsPrec :: Int -> UserQualifier -> ShowS
showsPrec :: Int -> UserQualifier -> ShowS
$cshow :: UserQualifier -> String
show :: UserQualifier -> String
$cshowList :: [UserQualifier] -> ShowS
showList :: [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
$cfrom :: forall x. UserQualifier -> Rep UserQualifier x
from :: forall x. UserQualifier -> Rep UserQualifier x
$cto :: forall x. Rep UserQualifier x -> UserQualifier
to :: forall x. Rep UserQualifier x -> UserQualifier
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
$c== :: UserConstraintScope -> UserConstraintScope -> Bool
== :: UserConstraintScope -> UserConstraintScope -> Bool
$c/= :: UserConstraintScope -> UserConstraintScope -> Bool
/= :: 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
$cshowsPrec :: Int -> UserConstraintScope -> ShowS
showsPrec :: Int -> UserConstraintScope -> ShowS
$cshow :: UserConstraintScope -> String
show :: UserConstraintScope -> String
$cshowList :: [UserConstraintScope] -> ShowS
showList :: [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
$cfrom :: forall x. UserConstraintScope -> Rep UserConstraintScope x
from :: forall x. UserConstraintScope -> Rep UserConstraintScope x
$cto :: forall x. Rep UserConstraintScope x -> UserConstraintScope
to :: forall x. Rep UserConstraintScope x -> UserConstraintScope
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
$c== :: UserConstraint -> UserConstraint -> Bool
== :: UserConstraint -> UserConstraint -> Bool
$c/= :: UserConstraint -> UserConstraint -> Bool
/= :: 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
$cshowsPrec :: Int -> UserConstraint -> ShowS
showsPrec :: Int -> UserConstraint -> ShowS
$cshow :: UserConstraint -> String
show :: UserConstraint -> String
$cshowList :: [UserConstraint] -> ShowS
showList :: [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
$cfrom :: forall x. UserConstraint -> Rep UserConstraint x
from :: forall x. UserConstraint -> Rep UserConstraint x
$cto :: forall x. Rep UserConstraint x -> UserConstraint
to :: forall x. Rep UserConstraint x -> UserConstraint
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
forall (m :: * -> *). CabalParsing m => m UserConstraint
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 :: forall (m :: * -> *). CabalParsing m => 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
forall (m :: * -> *). CabalParsing m => m VersionRange
parsec -- headed by "<=>" (will be)
        , PackageProperty
PackagePropertyInstalled PackageProperty -> m String -> m PackageProperty
forall a b. a -> m b -> m a
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 a b. a -> m b -> m a
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 a b. a -> m b -> m a
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 a b. a -> m b -> m a
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 a. a -> m a
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 <- m PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m PackageName
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 a b. m a -> m b -> m b
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 a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> PackageName -> m UserConstraintScope
withColon PackageName
pn
          , UserConstraintScope -> m UserConstraintScope
forall a. a -> m a
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
forall (m :: * -> *). CabalParsing m => m PackageName
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
forall (m :: * -> *). CabalParsing m => m PackageName
parsec
            | Bool
otherwise = String -> m UserConstraintScope
forall a. String -> m a
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 a b. a -> m b -> m a
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 a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m PackageName
parsec