{-# 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 { unAllowNewer :: RelaxDeps } deriving (Eq, Read, Show, Generic) -- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag) newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps } deriving (Eq, Read, Show, 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 (Eq, Read, Show, 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 (Eq, Read, Show, 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 (Eq, Read, Show, Generic) -- | Modifier for dependency relaxation data RelaxDepMod = RelaxDepModNone -- ^ Default semantics | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints deriving (Eq, Read, Show, Generic) -- | Express whether to relax bounds /on/ @all@ packages, or a single package data RelaxDepSubject = RelaxDepSubjectAll | RelaxDepSubjectPkg !PackageName deriving (Eq, Ord, Read, Show, Generic) instance Pretty RelaxedDep where pretty (RelaxedDep scope rdmod subj) = case scope of RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep where modDep = case rdmod of RelaxDepModNone -> pretty subj RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj instance Parsec RelaxedDep where parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP) -- continuation after * relaxedDepStarP :: CabalParsing m => m RelaxedDep relaxedDepStarP = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) -- continuation after package identifier relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep relaxedDepPkgidP pid@(PackageIdentifier pn v) | pn == mkPackageName "all" , v == nullVersion = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) | v == nullVersion = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)) | otherwise = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec modP :: P.CharParsing m => m RelaxDepMod modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone instance Pretty RelaxDepSubject where pretty RelaxDepSubjectAll = Disp.text "*" pretty (RelaxDepSubjectPkg pn) = pretty pn instance Parsec RelaxDepSubject where parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn where pkgn = do pn <- parsec pure $ if pn == mkPackageName "all" then RelaxDepSubjectAll else RelaxDepSubjectPkg pn instance Pretty RelaxDeps where pretty rd | not (isRelaxDeps rd) = Disp.text "none" pretty (RelaxDepsSome pkgs) = Disp.fsep . Disp.punctuate Disp.comma . map pretty $ pkgs pretty RelaxDepsAll = Disp.text "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 = do xs <- parsecLeadingCommaNonEmpty parsec pure $ case toList xs of [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] -> RelaxDepsAll [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)] | pn == mkPackageName "none" -> mempty xs' -> mkRelaxDepSome 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 (RelaxDepsSome []) = False isRelaxDeps (RelaxDepsSome (_:_)) = True isRelaxDeps RelaxDepsAll = True -- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@. mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps mkRelaxDepSome xs | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs = RelaxDepsAll | otherwise = RelaxDepsSome xs -- | 'RelaxDepsAll' is the /absorbing element/ instance Semigroup RelaxDeps where -- identity element RelaxDepsSome [] <> r = r l@(RelaxDepsSome _) <> RelaxDepsSome [] = l -- absorbing element l@RelaxDepsAll <> _ = l (RelaxDepsSome _) <> r@RelaxDepsAll = r -- combining non-{identity,absorbing} elements (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b) -- | @'RelaxDepsSome' []@ is the /identity element/ instance Monoid RelaxDeps where mempty = RelaxDepsSome [] mappend = (<>) instance Semigroup AllowNewer where AllowNewer x <> AllowNewer y = AllowNewer (x <> y) instance Semigroup AllowOlder where AllowOlder x <> AllowOlder y = AllowOlder (x <> y) instance Monoid AllowNewer where mempty = AllowNewer mempty mappend = (<>) instance Monoid AllowOlder where mempty = AllowOlder mempty mappend = (<>)