{-# LANGUAGE DeriveGeneric #-}

-- | Per-package constraints. Package constraints must be respected by the
-- solver. Multiple constraints for each package can be given, though obviously
-- it is possible to construct conflicting constraints (eg impossible version
-- range or inconsistent flag assignment).
--
module Distribution.Solver.Types.PackageConstraint (
    ConstraintScope(..),
    scopeToplevel,
    scopeToPackageName,
    constraintScopeMatches,
    PackageProperty(..),
    PackageConstraint(..),
    showPackageConstraint,
    packageConstraintToDependency
  ) where

import Distribution.Solver.Compat.Prelude
import Prelude ()

import Distribution.Package                        (PackageName)
import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)
import Distribution.Pretty                         (flatStyle, Pretty(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


-- | Determines to what packages and in what contexts a
-- constraint applies.
data ConstraintScope
     -- | A scope that applies when the given package is used as a build target.
     -- In other words, the scope applies iff a goal has a top-level qualifier
     -- and its namespace matches the given package name. A namespace is
     -- considered to match a package name when it is either the default
     -- namespace (for --no-independent-goals) or it is an independent namespace
     -- with the given package name (for --independent-goals).

     -- TODO: Try to generalize the ConstraintScopes once component-based
     -- solving is implemented, and remove this special case for targets.
   = ScopeTarget PackageName
     -- | The package with the specified name and qualifier.
   | ScopeQualified Qualifier PackageName
     -- | The package with the specified name when it has a
     -- setup qualifier.
   | ScopeAnySetupQualifier PackageName
     -- | The package with the specified name regardless of
     -- qualifier.
   | ScopeAnyQualifier PackageName
  deriving (ConstraintScope -> ConstraintScope -> Bool
(ConstraintScope -> ConstraintScope -> Bool)
-> (ConstraintScope -> ConstraintScope -> Bool)
-> Eq ConstraintScope
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstraintScope -> ConstraintScope -> Bool
== :: ConstraintScope -> ConstraintScope -> Bool
$c/= :: ConstraintScope -> ConstraintScope -> Bool
/= :: 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
$cshowsPrec :: Int -> ConstraintScope -> ShowS
showsPrec :: Int -> ConstraintScope -> ShowS
$cshow :: ConstraintScope -> String
show :: ConstraintScope -> String
$cshowList :: [ConstraintScope] -> ShowS
showList :: [ConstraintScope] -> ShowS
Show)

-- | Constructor for a common use case: the constraint applies to
-- the package with the specified name when that package is a
-- top-level dependency in the default namespace.
scopeToplevel :: PackageName -> ConstraintScope
scopeToplevel :: PackageName -> ConstraintScope
scopeToplevel = Qualifier -> PackageName -> ConstraintScope
ScopeQualified Qualifier
QualToplevel

-- | Returns the package name associated with a constraint scope.
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'

instance Pretty ConstraintScope where
  pretty :: ConstraintScope -> Doc
pretty (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
  pretty (ScopeQualified Qualifier
q PackageName
pn) = Qualifier -> Doc
dispQualifier Qualifier
q Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
  pretty (ScopeAnySetupQualifier PackageName
pn) = String -> Doc
Disp.text String
"setup." Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn
  pretty (ScopeAnyQualifier PackageName
pn) = String -> Doc
Disp.text String
"any." Doc -> Doc -> Doc
<<>> PackageName -> Doc
forall a. Pretty a => a -> Doc
pretty PackageName
pn

-- | A package property is a logical predicate on packages.
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
$c== :: PackageProperty -> PackageProperty -> Bool
== :: PackageProperty -> PackageProperty -> Bool
$c/= :: PackageProperty -> PackageProperty -> Bool
/= :: 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
$cshowsPrec :: Int -> PackageProperty -> ShowS
showsPrec :: Int -> PackageProperty -> ShowS
$cshow :: PackageProperty -> String
show :: PackageProperty -> String
$cshowList :: [PackageProperty] -> ShowS
showList :: [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
$cfrom :: forall x. PackageProperty -> Rep PackageProperty x
from :: forall x. PackageProperty -> Rep PackageProperty x
$cto :: forall x. Rep PackageProperty x -> PackageProperty
to :: forall x. Rep PackageProperty x -> PackageProperty
Generic)

instance Binary PackageProperty
instance Structured PackageProperty

instance Pretty PackageProperty where
  pretty :: PackageProperty -> Doc
pretty (PackagePropertyVersion VersionRange
verrange) = VersionRange -> Doc
forall a. Pretty a => a -> Doc
pretty VersionRange
verrange
  pretty PackageProperty
PackagePropertyInstalled          = String -> Doc
Disp.text String
"installed"
  pretty PackageProperty
PackagePropertySource             = String -> Doc
Disp.text String
"source"
  pretty (PackagePropertyFlags FlagAssignment
flags)      = FlagAssignment -> Doc
dispFlagAssignment FlagAssignment
flags
  pretty (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

-- | A package constraint consists of a scope plus a property
-- that must hold for all packages within that scope.
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
$c== :: PackageConstraint -> PackageConstraint -> Bool
== :: PackageConstraint -> PackageConstraint -> Bool
$c/= :: PackageConstraint -> PackageConstraint -> Bool
/= :: 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
$cshowsPrec :: Int -> PackageConstraint -> ShowS
showsPrec :: Int -> PackageConstraint -> ShowS
$cshow :: PackageConstraint -> String
show :: PackageConstraint -> String
$cshowList :: [PackageConstraint] -> ShowS
showList :: [PackageConstraint] -> ShowS
Show)

instance Pretty PackageConstraint where
  pretty :: PackageConstraint -> Doc
pretty (PackageConstraint ConstraintScope
scope PackageProperty
prop) =
    ConstraintScope -> Doc
forall a. Pretty a => a -> Doc
pretty ConstraintScope
scope Doc -> Doc -> Doc
<+> PackageProperty -> Doc
forall a. Pretty a => a -> Doc
pretty PackageProperty
prop

-- | Alternative textual representation of a package constraint
-- for debugging purposes (slightly more verbose than that
-- produced by 'dispPackageConstraint').
--
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
forall a. Pretty a => a -> Doc
pretty 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

-- | Lossily convert a 'PackageConstraint' to a 'Dependency'.
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