{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Distribution.Client.Targets (
UserTarget(..),
readUserTargets,
resolveUserTargets,
UserTargetProblem(..),
readUserTarget,
reportUserTargetProblems,
expandUserTarget,
PackageTarget(..),
fetchPackageTarget,
readPackageTarget,
PackageTargetProblem(..),
reportPackageTargetProblems,
disambiguatePackageTargets,
disambiguatePackageName,
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 )
data UserTarget =
UserTargetNamed PackageVersionConstraint
| UserTargetLocalDir FilePath
| UserTargetLocalCabalFile FilePath
| UserTargetLocalTarball FilePath
| 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)
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 ]
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
[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
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
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
data PackageTarget pkg =
PackageTargetNamed PackageName [PackageProperty] UserTarget
| 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)
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)
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
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)
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"
RemoteSourceRepoPackage SourceRepoMaybe
_srcRepo String
_ ->
forall a. HasCallStack => String -> a
error String
"TODO: readPackageTarget RemoteSourceRepoPackage"
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)
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
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)
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)
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 ]
data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]
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
[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 ]
data UserQualifier =
UserQualToplevel
| UserQualSetup PackageName
| 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
data UserConstraintScope =
UserQualified UserQualifier PackageName
| UserAnySetupQualifier PackageName
| 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
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
, 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
, 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