{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Types.AllowNewer (
    AllowNewer (..),
    AllowOlder (..),
    RelaxDeps (..),
    mkRelaxDepSome,
    RelaxDepMod (..),
    RelaxDepScope (..),
    RelaxDepSubject (..),
    RelaxedDep (..),
    isRelaxDeps,
) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Parsec            (parsecLeadingCommaNonEmpty)
import Distribution.Types.PackageId   (PackageId, PackageIdentifier (..))
import Distribution.Types.PackageName (PackageName, mkPackageName)
import Distribution.Types.Version     (nullVersion)

import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint                as Disp

-- $setup
-- >>> import Distribution.Parsec

-- TODO: When https://github.com/haskell/cabal/issues/4203 gets tackled,
-- it may make sense to move these definitions to the Solver.Types
-- module

-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)
newtype AllowNewer = AllowNewer { AllowNewer -> RelaxDeps
unAllowNewer :: RelaxDeps }
                   deriving (AllowNewer -> AllowNewer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllowNewer -> AllowNewer -> Bool
$c/= :: AllowNewer -> AllowNewer -> Bool
== :: AllowNewer -> AllowNewer -> Bool
$c== :: AllowNewer -> AllowNewer -> Bool
Eq, ReadPrec [AllowNewer]
ReadPrec AllowNewer
Int -> ReadS AllowNewer
ReadS [AllowNewer]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AllowNewer]
$creadListPrec :: ReadPrec [AllowNewer]
readPrec :: ReadPrec AllowNewer
$creadPrec :: ReadPrec AllowNewer
readList :: ReadS [AllowNewer]
$creadList :: ReadS [AllowNewer]
readsPrec :: Int -> ReadS AllowNewer
$creadsPrec :: Int -> ReadS AllowNewer
Read, Int -> AllowNewer -> ShowS
[AllowNewer] -> ShowS
AllowNewer -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllowNewer] -> ShowS
$cshowList :: [AllowNewer] -> ShowS
show :: AllowNewer -> String
$cshow :: AllowNewer -> String
showsPrec :: Int -> AllowNewer -> ShowS
$cshowsPrec :: Int -> AllowNewer -> ShowS
Show, forall x. Rep AllowNewer x -> AllowNewer
forall x. AllowNewer -> Rep AllowNewer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AllowNewer x -> AllowNewer
$cfrom :: forall x. AllowNewer -> Rep AllowNewer x
Generic)

-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)
newtype AllowOlder = AllowOlder { AllowOlder -> RelaxDeps
unAllowOlder :: RelaxDeps }
                   deriving (AllowOlder -> AllowOlder -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllowOlder -> AllowOlder -> Bool
$c/= :: AllowOlder -> AllowOlder -> Bool
== :: AllowOlder -> AllowOlder -> Bool
$c== :: AllowOlder -> AllowOlder -> Bool
Eq, ReadPrec [AllowOlder]
ReadPrec AllowOlder
Int -> ReadS AllowOlder
ReadS [AllowOlder]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AllowOlder]
$creadListPrec :: ReadPrec [AllowOlder]
readPrec :: ReadPrec AllowOlder
$creadPrec :: ReadPrec AllowOlder
readList :: ReadS [AllowOlder]
$creadList :: ReadS [AllowOlder]
readsPrec :: Int -> ReadS AllowOlder
$creadsPrec :: Int -> ReadS AllowOlder
Read, Int -> AllowOlder -> ShowS
[AllowOlder] -> ShowS
AllowOlder -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AllowOlder] -> ShowS
$cshowList :: [AllowOlder] -> ShowS
show :: AllowOlder -> String
$cshow :: AllowOlder -> String
showsPrec :: Int -> AllowOlder -> ShowS
$cshowsPrec :: Int -> AllowOlder -> ShowS
Show, forall x. Rep AllowOlder x -> AllowOlder
forall x. AllowOlder -> Rep AllowOlder x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AllowOlder x -> AllowOlder
$cfrom :: forall x. AllowOlder -> Rep AllowOlder x
Generic)

-- | Generic data type for policy when relaxing bounds in dependencies.
-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending
-- on whether or not you are relaxing an lower or upper bound
-- (respectively).
data RelaxDeps =

  -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.
  --
  -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all
  -- dependencies, never choose versions newer (resp. older) than allowed.
    RelaxDepsSome [RelaxedDep]

  -- | Ignore upper (resp. lower) bounds in dependencies on all packages.
  --
  -- __Note__: This is should be semantically equivalent to
  --
  -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
  --
  -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')
  | RelaxDepsAll
  deriving (RelaxDeps -> RelaxDeps -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelaxDeps -> RelaxDeps -> Bool
$c/= :: RelaxDeps -> RelaxDeps -> Bool
== :: RelaxDeps -> RelaxDeps -> Bool
$c== :: RelaxDeps -> RelaxDeps -> Bool
Eq, ReadPrec [RelaxDeps]
ReadPrec RelaxDeps
Int -> ReadS RelaxDeps
ReadS [RelaxDeps]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelaxDeps]
$creadListPrec :: ReadPrec [RelaxDeps]
readPrec :: ReadPrec RelaxDeps
$creadPrec :: ReadPrec RelaxDeps
readList :: ReadS [RelaxDeps]
$creadList :: ReadS [RelaxDeps]
readsPrec :: Int -> ReadS RelaxDeps
$creadsPrec :: Int -> ReadS RelaxDeps
Read, Int -> RelaxDeps -> ShowS
[RelaxDeps] -> ShowS
RelaxDeps -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelaxDeps] -> ShowS
$cshowList :: [RelaxDeps] -> ShowS
show :: RelaxDeps -> String
$cshow :: RelaxDeps -> String
showsPrec :: Int -> RelaxDeps -> ShowS
$cshowsPrec :: Int -> RelaxDeps -> ShowS
Show, forall x. Rep RelaxDeps x -> RelaxDeps
forall x. RelaxDeps -> Rep RelaxDeps x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelaxDeps x -> RelaxDeps
$cfrom :: forall x. RelaxDeps -> Rep RelaxDeps x
Generic)

-- | Dependencies can be relaxed either for all packages in the install plan, or
-- only for some packages.
data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject
                deriving (RelaxedDep -> RelaxedDep -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelaxedDep -> RelaxedDep -> Bool
$c/= :: RelaxedDep -> RelaxedDep -> Bool
== :: RelaxedDep -> RelaxedDep -> Bool
$c== :: RelaxedDep -> RelaxedDep -> Bool
Eq, ReadPrec [RelaxedDep]
ReadPrec RelaxedDep
Int -> ReadS RelaxedDep
ReadS [RelaxedDep]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelaxedDep]
$creadListPrec :: ReadPrec [RelaxedDep]
readPrec :: ReadPrec RelaxedDep
$creadPrec :: ReadPrec RelaxedDep
readList :: ReadS [RelaxedDep]
$creadList :: ReadS [RelaxedDep]
readsPrec :: Int -> ReadS RelaxedDep
$creadsPrec :: Int -> ReadS RelaxedDep
Read, Int -> RelaxedDep -> ShowS
[RelaxedDep] -> ShowS
RelaxedDep -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelaxedDep] -> ShowS
$cshowList :: [RelaxedDep] -> ShowS
show :: RelaxedDep -> String
$cshow :: RelaxedDep -> String
showsPrec :: Int -> RelaxedDep -> ShowS
$cshowsPrec :: Int -> RelaxedDep -> ShowS
Show, forall x. Rep RelaxedDep x -> RelaxedDep
forall x. RelaxedDep -> Rep RelaxedDep x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelaxedDep x -> RelaxedDep
$cfrom :: forall x. RelaxedDep -> Rep RelaxedDep x
Generic)

-- | Specify the scope of a relaxation, i.e. limit which depending
-- packages are allowed to have their version constraints relaxed.
data RelaxDepScope = RelaxDepScopeAll
                     -- ^ Apply relaxation in any package
                   | RelaxDepScopePackage !PackageName
                     -- ^ Apply relaxation to in all versions of a package
                   | RelaxDepScopePackageId !PackageId
                     -- ^ Apply relaxation to a specific version of a package only
                   deriving (RelaxDepScope -> RelaxDepScope -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelaxDepScope -> RelaxDepScope -> Bool
$c/= :: RelaxDepScope -> RelaxDepScope -> Bool
== :: RelaxDepScope -> RelaxDepScope -> Bool
$c== :: RelaxDepScope -> RelaxDepScope -> Bool
Eq, ReadPrec [RelaxDepScope]
ReadPrec RelaxDepScope
Int -> ReadS RelaxDepScope
ReadS [RelaxDepScope]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelaxDepScope]
$creadListPrec :: ReadPrec [RelaxDepScope]
readPrec :: ReadPrec RelaxDepScope
$creadPrec :: ReadPrec RelaxDepScope
readList :: ReadS [RelaxDepScope]
$creadList :: ReadS [RelaxDepScope]
readsPrec :: Int -> ReadS RelaxDepScope
$creadsPrec :: Int -> ReadS RelaxDepScope
Read, Int -> RelaxDepScope -> ShowS
[RelaxDepScope] -> ShowS
RelaxDepScope -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelaxDepScope] -> ShowS
$cshowList :: [RelaxDepScope] -> ShowS
show :: RelaxDepScope -> String
$cshow :: RelaxDepScope -> String
showsPrec :: Int -> RelaxDepScope -> ShowS
$cshowsPrec :: Int -> RelaxDepScope -> ShowS
Show, forall x. Rep RelaxDepScope x -> RelaxDepScope
forall x. RelaxDepScope -> Rep RelaxDepScope x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelaxDepScope x -> RelaxDepScope
$cfrom :: forall x. RelaxDepScope -> Rep RelaxDepScope x
Generic)

-- | Modifier for dependency relaxation
data RelaxDepMod = RelaxDepModNone  -- ^ Default semantics
                 | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints
                 deriving (RelaxDepMod -> RelaxDepMod -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelaxDepMod -> RelaxDepMod -> Bool
$c/= :: RelaxDepMod -> RelaxDepMod -> Bool
== :: RelaxDepMod -> RelaxDepMod -> Bool
$c== :: RelaxDepMod -> RelaxDepMod -> Bool
Eq, ReadPrec [RelaxDepMod]
ReadPrec RelaxDepMod
Int -> ReadS RelaxDepMod
ReadS [RelaxDepMod]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelaxDepMod]
$creadListPrec :: ReadPrec [RelaxDepMod]
readPrec :: ReadPrec RelaxDepMod
$creadPrec :: ReadPrec RelaxDepMod
readList :: ReadS [RelaxDepMod]
$creadList :: ReadS [RelaxDepMod]
readsPrec :: Int -> ReadS RelaxDepMod
$creadsPrec :: Int -> ReadS RelaxDepMod
Read, Int -> RelaxDepMod -> ShowS
[RelaxDepMod] -> ShowS
RelaxDepMod -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelaxDepMod] -> ShowS
$cshowList :: [RelaxDepMod] -> ShowS
show :: RelaxDepMod -> String
$cshow :: RelaxDepMod -> String
showsPrec :: Int -> RelaxDepMod -> ShowS
$cshowsPrec :: Int -> RelaxDepMod -> ShowS
Show, forall x. Rep RelaxDepMod x -> RelaxDepMod
forall x. RelaxDepMod -> Rep RelaxDepMod x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelaxDepMod x -> RelaxDepMod
$cfrom :: forall x. RelaxDepMod -> Rep RelaxDepMod x
Generic)

-- | Express whether to relax bounds /on/ @all@ packages, or a single package
data RelaxDepSubject = RelaxDepSubjectAll
                     | RelaxDepSubjectPkg !PackageName
                     deriving (RelaxDepSubject -> RelaxDepSubject -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelaxDepSubject -> RelaxDepSubject -> Bool
$c/= :: RelaxDepSubject -> RelaxDepSubject -> Bool
== :: RelaxDepSubject -> RelaxDepSubject -> Bool
$c== :: RelaxDepSubject -> RelaxDepSubject -> Bool
Eq, Eq RelaxDepSubject
RelaxDepSubject -> RelaxDepSubject -> Bool
RelaxDepSubject -> RelaxDepSubject -> Ordering
RelaxDepSubject -> RelaxDepSubject -> RelaxDepSubject
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RelaxDepSubject -> RelaxDepSubject -> RelaxDepSubject
$cmin :: RelaxDepSubject -> RelaxDepSubject -> RelaxDepSubject
max :: RelaxDepSubject -> RelaxDepSubject -> RelaxDepSubject
$cmax :: RelaxDepSubject -> RelaxDepSubject -> RelaxDepSubject
>= :: RelaxDepSubject -> RelaxDepSubject -> Bool
$c>= :: RelaxDepSubject -> RelaxDepSubject -> Bool
> :: RelaxDepSubject -> RelaxDepSubject -> Bool
$c> :: RelaxDepSubject -> RelaxDepSubject -> Bool
<= :: RelaxDepSubject -> RelaxDepSubject -> Bool
$c<= :: RelaxDepSubject -> RelaxDepSubject -> Bool
< :: RelaxDepSubject -> RelaxDepSubject -> Bool
$c< :: RelaxDepSubject -> RelaxDepSubject -> Bool
compare :: RelaxDepSubject -> RelaxDepSubject -> Ordering
$ccompare :: RelaxDepSubject -> RelaxDepSubject -> Ordering
Ord, ReadPrec [RelaxDepSubject]
ReadPrec RelaxDepSubject
Int -> ReadS RelaxDepSubject
ReadS [RelaxDepSubject]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RelaxDepSubject]
$creadListPrec :: ReadPrec [RelaxDepSubject]
readPrec :: ReadPrec RelaxDepSubject
$creadPrec :: ReadPrec RelaxDepSubject
readList :: ReadS [RelaxDepSubject]
$creadList :: ReadS [RelaxDepSubject]
readsPrec :: Int -> ReadS RelaxDepSubject
$creadsPrec :: Int -> ReadS RelaxDepSubject
Read, Int -> RelaxDepSubject -> ShowS
[RelaxDepSubject] -> ShowS
RelaxDepSubject -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelaxDepSubject] -> ShowS
$cshowList :: [RelaxDepSubject] -> ShowS
show :: RelaxDepSubject -> String
$cshow :: RelaxDepSubject -> String
showsPrec :: Int -> RelaxDepSubject -> ShowS
$cshowsPrec :: Int -> RelaxDepSubject -> ShowS
Show, forall x. Rep RelaxDepSubject x -> RelaxDepSubject
forall x. RelaxDepSubject -> Rep RelaxDepSubject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelaxDepSubject x -> RelaxDepSubject
$cfrom :: forall x. RelaxDepSubject -> Rep RelaxDepSubject x
Generic)

instance Pretty RelaxedDep where
  pretty :: RelaxedDep -> Doc
pretty (RelaxedDep RelaxDepScope
scope RelaxDepMod
rdmod RelaxDepSubject
subj) = case RelaxDepScope
scope of
      RelaxDepScope
RelaxDepScopeAll          -> String -> Doc
Disp.text String
"*:"               Doc -> Doc -> Doc
Disp.<> Doc
modDep
      RelaxDepScopePackage   PackageName
p0 -> forall a. Pretty a => a -> Doc
pretty PackageName
p0 Doc -> Doc -> Doc
Disp.<> Doc
Disp.colon Doc -> Doc -> Doc
Disp.<> Doc
modDep
      RelaxDepScopePackageId PackageId
p0 -> forall a. Pretty a => a -> Doc
pretty PackageId
p0 Doc -> Doc -> Doc
Disp.<> Doc
Disp.colon Doc -> Doc -> Doc
Disp.<> Doc
modDep
    where
      modDep :: Doc
modDep = case RelaxDepMod
rdmod of
               RelaxDepMod
RelaxDepModNone  -> forall a. Pretty a => a -> Doc
pretty RelaxDepSubject
subj
               RelaxDepMod
RelaxDepModCaret -> Char -> Doc
Disp.char Char
'^' Doc -> Doc -> Doc
Disp.<> forall a. Pretty a => a -> Doc
pretty RelaxDepSubject
subj

instance Parsec RelaxedDep where
    parsec :: forall (m :: * -> *). CabalParsing m => m RelaxedDep
parsec = forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'*' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). CabalParsing m => m RelaxedDep
relaxedDepStarP forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). CabalParsing m => PackageId -> m RelaxedDep
relaxedDepPkgidP)

-- continuation after *
relaxedDepStarP :: CabalParsing m => m RelaxedDep
relaxedDepStarP :: forall (m :: * -> *). CabalParsing m => m RelaxedDep
relaxedDepStarP =
    RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep RelaxDepScope
RelaxDepScopeAll forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). CharParsing m => m RelaxDepMod
modP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep RelaxDepScope
RelaxDepScopeAll RelaxDepMod
RelaxDepModNone RelaxDepSubject
RelaxDepSubjectAll)

-- continuation after package identifier
relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep
relaxedDepPkgidP :: forall (m :: * -> *). CabalParsing m => PackageId -> m RelaxedDep
relaxedDepPkgidP pid :: PackageId
pid@(PackageIdentifier PackageName
pn Version
v)
    | PackageName
pn forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"all"
    , Version
v forall a. Eq a => a -> a -> Bool
== Version
nullVersion
    =  RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep RelaxDepScope
RelaxDepScopeAll forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). CharParsing m => m RelaxDepMod
modP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep RelaxDepScope
RelaxDepScopeAll RelaxDepMod
RelaxDepModNone RelaxDepSubject
RelaxDepSubjectAll)

    | Version
v forall a. Eq a => a -> a -> Bool
== Version
nullVersion
    = RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep (PackageName -> RelaxDepScope
RelaxDepScopePackage PackageName
pn) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). CharParsing m => m RelaxDepMod
modP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep RelaxDepScope
RelaxDepScopeAll RelaxDepMod
RelaxDepModNone (PackageName -> RelaxDepSubject
RelaxDepSubjectPkg PackageName
pn))

    | Bool
otherwise
    = RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep (PackageId -> RelaxDepScope
RelaxDepScopePackageId PackageId
pid) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). CharParsing m => m RelaxDepMod
modP forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec

modP :: P.CharParsing m => m RelaxDepMod
modP :: forall (m :: * -> *). CharParsing m => m RelaxDepMod
modP = RelaxDepMod
RelaxDepModCaret forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'^' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure RelaxDepMod
RelaxDepModNone

instance Pretty RelaxDepSubject where
  pretty :: RelaxDepSubject -> Doc
pretty RelaxDepSubject
RelaxDepSubjectAll      = String -> Doc
Disp.text String
"*"
  pretty (RelaxDepSubjectPkg PackageName
pn) = forall a. Pretty a => a -> Doc
pretty PackageName
pn

instance Parsec RelaxDepSubject where
  parsec :: forall (m :: * -> *). CabalParsing m => m RelaxDepSubject
parsec = RelaxDepSubject
RelaxDepSubjectAll forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'*' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m RelaxDepSubject
pkgn
    where
      pkgn :: m RelaxDepSubject
pkgn = do
          PackageName
pn <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if PackageName
pn forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"all"
              then RelaxDepSubject
RelaxDepSubjectAll
              else PackageName -> RelaxDepSubject
RelaxDepSubjectPkg PackageName
pn

instance Pretty RelaxDeps where
  pretty :: RelaxDeps -> Doc
pretty RelaxDeps
rd | Bool -> Bool
not (RelaxDeps -> Bool
isRelaxDeps RelaxDeps
rd) = String -> Doc
Disp.text String
"none"
  pretty (RelaxDepsSome [RelaxedDep]
pkgs)      = [Doc] -> Doc
Disp.fsep forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   Doc -> [Doc] -> [Doc]
Disp.punctuate Doc
Disp.comma forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty forall a b. (a -> b) -> a -> b
$ [RelaxedDep]
pkgs
  pretty RelaxDeps
RelaxDepsAll              = String -> Doc
Disp.text String
"all"

-- |
--
-- >>> simpleParsec "all" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "none" :: Maybe RelaxDeps
-- Just (RelaxDepsSome [])
--
-- >>> simpleParsec "*, *" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "*:*" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "foo:bar, quu:puu" :: Maybe RelaxDeps
-- Just (RelaxDepsSome [RelaxedDep (RelaxDepScopePackage (PackageName "foo")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "bar")),RelaxedDep (RelaxDepScopePackage (PackageName "quu")) RelaxDepModNone (RelaxDepSubjectPkg (PackageName "puu"))])
--
-- This is not a glitch, even it looks like:
--
-- >>> simpleParsec ", all" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
-- >>> simpleParsec "" :: Maybe RelaxDeps
-- Nothing
--
instance Parsec RelaxDeps where
    parsec :: forall (m :: * -> *). CabalParsing m => m RelaxDeps
parsec = do
        NonEmpty RelaxedDep
xs <- forall (m :: * -> *) a. CabalParsing m => m a -> m (NonEmpty a)
parsecLeadingCommaNonEmpty forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty RelaxedDep
xs of
            [RelaxedDep RelaxDepScope
RelaxDepScopeAll RelaxDepMod
RelaxDepModNone RelaxDepSubject
RelaxDepSubjectAll]
                -> RelaxDeps
RelaxDepsAll
            [RelaxedDep RelaxDepScope
RelaxDepScopeAll RelaxDepMod
RelaxDepModNone (RelaxDepSubjectPkg PackageName
pn)]
                | PackageName
pn forall a. Eq a => a -> a -> Bool
== String -> PackageName
mkPackageName String
"none"
                -> forall a. Monoid a => a
mempty
            [RelaxedDep]
xs' -> [RelaxedDep] -> RelaxDeps
mkRelaxDepSome [RelaxedDep]
xs'

instance Binary RelaxDeps
instance Binary RelaxDepMod
instance Binary RelaxDepScope
instance Binary RelaxDepSubject
instance Binary RelaxedDep
instance Binary AllowNewer
instance Binary AllowOlder

instance Structured RelaxDeps
instance Structured RelaxDepMod
instance Structured RelaxDepScope
instance Structured RelaxDepSubject
instance Structured RelaxedDep
instance Structured AllowNewer
instance Structured AllowOlder

-- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations
--
-- Equivalent to @isRelaxDeps = (/= 'mempty')@
isRelaxDeps :: RelaxDeps -> Bool
isRelaxDeps :: RelaxDeps -> Bool
isRelaxDeps (RelaxDepsSome [])    = Bool
False
isRelaxDeps (RelaxDepsSome (RelaxedDep
_:[RelaxedDep]
_)) = Bool
True
isRelaxDeps RelaxDeps
RelaxDepsAll          = Bool
True

-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.
mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
mkRelaxDepSome [RelaxedDep]
xs
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== RelaxDepScope -> RelaxDepMod -> RelaxDepSubject -> RelaxedDep
RelaxedDep RelaxDepScope
RelaxDepScopeAll RelaxDepMod
RelaxDepModNone RelaxDepSubject
RelaxDepSubjectAll) [RelaxedDep]
xs
    = RelaxDeps
RelaxDepsAll

    | Bool
otherwise
    = [RelaxedDep] -> RelaxDeps
RelaxDepsSome [RelaxedDep]
xs

-- | 'RelaxDepsAll' is the /absorbing element/
instance Semigroup RelaxDeps where
    -- identity element
    RelaxDepsSome []    <> :: RelaxDeps -> RelaxDeps -> RelaxDeps
<> RelaxDeps
r                   = RelaxDeps
r
    l :: RelaxDeps
l@(RelaxDepsSome [RelaxedDep]
_) <> RelaxDepsSome []    = RelaxDeps
l
    -- absorbing element
    l :: RelaxDeps
l@RelaxDeps
RelaxDepsAll      <> RelaxDeps
_                   = RelaxDeps
l
    (RelaxDepsSome   [RelaxedDep]
_) <> r :: RelaxDeps
r@RelaxDeps
RelaxDepsAll      = RelaxDeps
r
    -- combining non-{identity,absorbing} elements
    (RelaxDepsSome   [RelaxedDep]
a) <> (RelaxDepsSome [RelaxedDep]
b)   = [RelaxedDep] -> RelaxDeps
RelaxDepsSome ([RelaxedDep]
a forall a. [a] -> [a] -> [a]
++ [RelaxedDep]
b)

-- | @'RelaxDepsSome' []@ is the /identity element/
instance Monoid RelaxDeps where
  mempty :: RelaxDeps
mempty  = [RelaxedDep] -> RelaxDeps
RelaxDepsSome []
  mappend :: RelaxDeps -> RelaxDeps -> RelaxDeps
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup AllowNewer where
  AllowNewer RelaxDeps
x <> :: AllowNewer -> AllowNewer -> AllowNewer
<> AllowNewer RelaxDeps
y = RelaxDeps -> AllowNewer
AllowNewer (RelaxDeps
x forall a. Semigroup a => a -> a -> a
<> RelaxDeps
y)

instance Semigroup AllowOlder where
  AllowOlder RelaxDeps
x <> :: AllowOlder -> AllowOlder -> AllowOlder
<> AllowOlder RelaxDeps
y = RelaxDeps -> AllowOlder
AllowOlder (RelaxDeps
x forall a. Semigroup a => a -> a -> a
<> RelaxDeps
y)

instance Monoid AllowNewer where
  mempty :: AllowNewer
mempty  = RelaxDeps -> AllowNewer
AllowNewer forall a. Monoid a => a
mempty
  mappend :: AllowNewer -> AllowNewer -> AllowNewer
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid AllowOlder where
  mempty :: AllowOlder
mempty  = RelaxDeps -> AllowOlder
AllowOlder forall a. Monoid a => a
mempty
  mappend :: AllowOlder -> AllowOlder -> AllowOlder
mappend = forall a. Semigroup a => a -> a -> a
(<>)