{-# LANGUAGE DeriveGeneric #-}
module Distribution.Solver.Types.PackageConstraint (
ConstraintScope(..),
scopeToplevel,
scopeToPackageName,
constraintScopeMatches,
PackageProperty(..),
dispPackageProperty,
PackageConstraint(..),
dispPackageConstraint,
showPackageConstraint,
packageConstraintToDependency
) where
import Distribution.Solver.Compat.Prelude
import Prelude ()
import Distribution.Package (PackageName)
import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment)
import Distribution.Pretty (flatStyle, pretty)
import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))
import Distribution.Version (VersionRange, simplifyVersionRange)
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import qualified Text.PrettyPrint as Disp
data ConstraintScope
= ScopeTarget PackageName
| ScopeQualified Qualifier PackageName
| ScopeAnySetupQualifier PackageName
| ScopeAnyQualifier PackageName
deriving (ConstraintScope -> ConstraintScope -> Bool
(ConstraintScope -> ConstraintScope -> Bool)
-> (ConstraintScope -> ConstraintScope -> Bool)
-> Eq ConstraintScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConstraintScope -> ConstraintScope -> Bool
$c/= :: ConstraintScope -> ConstraintScope -> Bool
== :: ConstraintScope -> ConstraintScope -> Bool
$c== :: ConstraintScope -> ConstraintScope -> Bool
Eq, Int -> ConstraintScope -> ShowS
[ConstraintScope] -> ShowS
ConstraintScope -> String
(Int -> ConstraintScope -> ShowS)
-> (ConstraintScope -> String)
-> ([ConstraintScope] -> ShowS)
-> Show ConstraintScope
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConstraintScope] -> ShowS
$cshowList :: [ConstraintScope] -> ShowS
show :: ConstraintScope -> String
$cshow :: ConstraintScope -> String
showsPrec :: Int -> ConstraintScope -> ShowS
$cshowsPrec :: Int -> ConstraintScope -> ShowS
Show)
scopeToplevel :: PackageName -> ConstraintScope
scopeToplevel :: PackageName -> ConstraintScope
scopeToplevel = Qualifier -> PackageName -> ConstraintScope
ScopeQualified Qualifier
QualToplevel
scopeToPackageName :: ConstraintScope -> PackageName
scopeToPackageName :: ConstraintScope -> PackageName
scopeToPackageName (ScopeTarget PackageName
pn) = PackageName
pn
scopeToPackageName (ScopeQualified Qualifier
_ PackageName
pn) = PackageName
pn
scopeToPackageName (ScopeAnySetupQualifier PackageName
pn) = PackageName
pn
scopeToPackageName (ScopeAnyQualifier PackageName
pn) = PackageName
pn
constraintScopeMatches :: ConstraintScope -> QPN -> Bool
constraintScopeMatches :: ConstraintScope -> QPN -> Bool
constraintScopeMatches (ScopeTarget PackageName
pn) (Q (PackagePath Namespace
ns Qualifier
q) PackageName
pn') =
let namespaceMatches :: Namespace -> Bool
namespaceMatches Namespace
DefaultNamespace = Bool
True
namespaceMatches (Independent PackageName
namespacePn) = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
namespacePn
in Namespace -> Bool
namespaceMatches Namespace
ns Bool -> Bool -> Bool
&& Qualifier
q Qualifier -> Qualifier -> Bool
forall a. Eq a => a -> a -> Bool
== Qualifier
QualToplevel Bool -> Bool -> Bool
&& PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
pn'
constraintScopeMatches (ScopeQualified Qualifier
q PackageName
pn) (Q (PackagePath Namespace
_ Qualifier
q') PackageName
pn') =
Qualifier
q Qualifier -> Qualifier -> Bool
forall a. Eq a => a -> a -> Bool
== Qualifier
q' Bool -> Bool -> Bool
&& PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
pn'
constraintScopeMatches (ScopeAnySetupQualifier PackageName
pn) (Q PackagePath
pp PackageName
pn') =
let setup :: PackagePath -> Bool
setup (PackagePath Namespace
_ (QualSetup PackageName
_)) = Bool
True
setup PackagePath
_ = Bool
False
in PackagePath -> Bool
setup PackagePath
pp Bool -> Bool -> Bool
&& PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
pn'
constraintScopeMatches (ScopeAnyQualifier PackageName
pn) (Q PackagePath
_ PackageName
pn') = PackageName
pn PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
pn'
dispConstraintScope :: ConstraintScope -> Disp.Doc
dispConstraintScope :: ConstraintScope -> Doc
dispConstraintScope (ScopeTarget PackageName
pn) = PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn Doc -> Doc -> Doc
<<>> String -> Doc
Disp.text String
"." Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
dispConstraintScope (ScopeQualified Qualifier
q PackageName
pn) = Qualifier -> Doc
dispQualifier Qualifier
q Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
dispConstraintScope (ScopeAnySetupQualifier PackageName
pn) = String -> Doc
Disp.text String
"setup." Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
dispConstraintScope (ScopeAnyQualifier PackageName
pn) = String -> Doc
Disp.text String
"any." Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
data PackageProperty
= PackagePropertyVersion VersionRange
| PackagePropertyInstalled
| PackagePropertySource
| PackagePropertyFlags FlagAssignment
| PackagePropertyStanzas [OptionalStanza]
deriving (PackageProperty -> PackageProperty -> Bool
(PackageProperty -> PackageProperty -> Bool)
-> (PackageProperty -> PackageProperty -> Bool)
-> Eq PackageProperty
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageProperty -> PackageProperty -> Bool
$c/= :: PackageProperty -> PackageProperty -> Bool
== :: PackageProperty -> PackageProperty -> Bool
$c== :: PackageProperty -> PackageProperty -> Bool
Eq, Int -> PackageProperty -> ShowS
[PackageProperty] -> ShowS
PackageProperty -> String
(Int -> PackageProperty -> ShowS)
-> (PackageProperty -> String)
-> ([PackageProperty] -> ShowS)
-> Show PackageProperty
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageProperty] -> ShowS
$cshowList :: [PackageProperty] -> ShowS
show :: PackageProperty -> String
$cshow :: PackageProperty -> String
showsPrec :: Int -> PackageProperty -> ShowS
$cshowsPrec :: Int -> PackageProperty -> ShowS
Show, (forall x. PackageProperty -> Rep PackageProperty x)
-> (forall x. Rep PackageProperty x -> PackageProperty)
-> Generic PackageProperty
forall x. Rep PackageProperty x -> PackageProperty
forall x. PackageProperty -> Rep PackageProperty x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageProperty x -> PackageProperty
$cfrom :: forall x. PackageProperty -> Rep PackageProperty x
Generic)
instance Binary PackageProperty
instance Structured PackageProperty
dispPackageProperty :: PackageProperty -> Disp.Doc
dispPackageProperty :: PackageProperty -> Doc
dispPackageProperty (PackagePropertyVersion VersionRange
verrange) = VersionRange -> Doc
forall a. Pretty a => a -> Doc
pretty VersionRange
verrange
dispPackageProperty PackageProperty
PackagePropertyInstalled = String -> Doc
Disp.text String
"installed"
dispPackageProperty PackageProperty
PackagePropertySource = String -> Doc
Disp.text String
"source"
dispPackageProperty (PackagePropertyFlags FlagAssignment
flags) = FlagAssignment -> Doc
dispFlagAssignment FlagAssignment
flags
dispPackageProperty (PackagePropertyStanzas [OptionalStanza]
stanzas) =
[Doc] -> Doc
Disp.hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (OptionalStanza -> Doc) -> [OptionalStanza] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
Disp.text (String -> Doc)
-> (OptionalStanza -> String) -> OptionalStanza -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptionalStanza -> String
showStanza) [OptionalStanza]
stanzas
data PackageConstraint = PackageConstraint ConstraintScope PackageProperty
deriving (PackageConstraint -> PackageConstraint -> Bool
(PackageConstraint -> PackageConstraint -> Bool)
-> (PackageConstraint -> PackageConstraint -> Bool)
-> Eq PackageConstraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageConstraint -> PackageConstraint -> Bool
$c/= :: PackageConstraint -> PackageConstraint -> Bool
== :: PackageConstraint -> PackageConstraint -> Bool
$c== :: PackageConstraint -> PackageConstraint -> Bool
Eq, Int -> PackageConstraint -> ShowS
[PackageConstraint] -> ShowS
PackageConstraint -> String
(Int -> PackageConstraint -> ShowS)
-> (PackageConstraint -> String)
-> ([PackageConstraint] -> ShowS)
-> Show PackageConstraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageConstraint] -> ShowS
$cshowList :: [PackageConstraint] -> ShowS
show :: PackageConstraint -> String
$cshow :: PackageConstraint -> String
showsPrec :: Int -> PackageConstraint -> ShowS
$cshowsPrec :: Int -> PackageConstraint -> ShowS
Show)
dispPackageConstraint :: PackageConstraint -> Disp.Doc
dispPackageConstraint :: PackageConstraint -> Doc
dispPackageConstraint (PackageConstraint ConstraintScope
scope PackageProperty
prop) =
ConstraintScope -> Doc
dispConstraintScope ConstraintScope
scope Doc -> Doc -> Doc
<+> PackageProperty -> Doc
dispPackageProperty PackageProperty
prop
showPackageConstraint :: PackageConstraint -> String
showPackageConstraint :: PackageConstraint -> String
showPackageConstraint pc :: PackageConstraint
pc@(PackageConstraint ConstraintScope
scope PackageProperty
prop) =
Style -> Doc -> String
Disp.renderStyle Style
flatStyle (Doc -> String) -> (Doc -> Doc) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
postprocess (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ PackageConstraint -> Doc
dispPackageConstraint PackageConstraint
pc2
where
pc2 :: PackageConstraint
pc2 = case PackageProperty
prop of
PackagePropertyVersion VersionRange
vr ->
ConstraintScope -> PackageProperty -> PackageConstraint
PackageConstraint ConstraintScope
scope (PackageProperty -> PackageConstraint)
-> PackageProperty -> PackageConstraint
forall a b. (a -> b) -> a -> b
$ VersionRange -> PackageProperty
PackagePropertyVersion (VersionRange -> VersionRange
simplifyVersionRange VersionRange
vr)
PackageProperty
_ -> PackageConstraint
pc
postprocess :: Doc -> Doc
postprocess = case PackageProperty
prop of
PackagePropertyFlags FlagAssignment
_ -> (String -> Doc
Disp.text String
"flags" Doc -> Doc -> Doc
<+>)
PackagePropertyStanzas [OptionalStanza]
_ -> (String -> Doc
Disp.text String
"stanzas" Doc -> Doc -> Doc
<+>)
PackageProperty
_ -> Doc -> Doc
forall a. a -> a
id
packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint
packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint
packageConstraintToDependency (PackageConstraint ConstraintScope
scope PackageProperty
prop) = PackageProperty -> Maybe PackageVersionConstraint
toDep PackageProperty
prop
where
toDep :: PackageProperty -> Maybe PackageVersionConstraint
toDep (PackagePropertyVersion VersionRange
vr) = PackageVersionConstraint -> Maybe PackageVersionConstraint
forall a. a -> Maybe a
Just (PackageVersionConstraint -> Maybe PackageVersionConstraint)
-> PackageVersionConstraint -> Maybe PackageVersionConstraint
forall a b. (a -> b) -> a -> b
$ PackageName -> VersionRange -> PackageVersionConstraint
PackageVersionConstraint (ConstraintScope -> PackageName
scopeToPackageName ConstraintScope
scope) VersionRange
vr
toDep (PackageProperty
PackagePropertyInstalled) = Maybe PackageVersionConstraint
forall a. Maybe a
Nothing
toDep (PackageProperty
PackagePropertySource) = Maybe PackageVersionConstraint
forall a. Maybe a
Nothing
toDep (PackagePropertyFlags FlagAssignment
_) = Maybe PackageVersionConstraint
forall a. Maybe a
Nothing
toDep (PackagePropertyStanzas [OptionalStanza]
_) = Maybe PackageVersionConstraint
forall a. Maybe a
Nothing