Commit 97db2d94 authored by Oleg Grenrus's avatar Oleg Grenrus

Add Described PackageIdentifier and RelaxDeps

parent 4125d520
......@@ -15,9 +15,9 @@ import Distribution.Simple.Flag (Flag (..))
import Distribution.SPDX
import Distribution.System
import Distribution.Types.Dependency
import Distribution.Types.Flag
(FlagAssignment, FlagName, mkFlagAssignment, mkFlagName)
import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName)
import Distribution.Types.LibraryName
import Distribution.Types.PackageId
import Distribution.Types.PackageName
import Distribution.Types.PackageVersionConstraint
import Distribution.Types.SourceRepo
......@@ -41,7 +41,7 @@ instance Arbitrary SpecVersion where
arbitrary = fmap SpecVersion arbitrary
-------------------------------------------------------------------------------
-- PackageName
-- PackageName and PackageIdentifier
-------------------------------------------------------------------------------
instance Arbitrary PackageName where
......@@ -51,10 +51,16 @@ instance Arbitrary PackageName where
`suchThat` (not . all isDigit)
packageChars = filter isAlphaNum ['\0'..'\127']
instance Arbitrary PackageIdentifier where
arbitrary = PackageIdentifier <$> arbitrary <*> arbitrary
shrink (PackageIdentifier pn vr) = uncurry PackageIdentifier <$> shrink (pn, vr)
-------------------------------------------------------------------------------
-- Version
-------------------------------------------------------------------------------
-- | Does *NOT* generate 'nullVersion'
instance Arbitrary Version where
arbitrary = do
branch <- smallListOf1 $
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Types.PackageId
( PackageIdentifier(..)
, PackageId
......@@ -8,10 +8,11 @@ module Distribution.Types.PackageId
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Parsec (Parsec (..), simpleParsec)
import Distribution.FieldGrammar.Described (Described (..))
import Distribution.Parsec (Parsec (..), simpleParsec)
import Distribution.Pretty
import Distribution.Types.PackageName
import Distribution.Version (Version, nullVersion)
import Distribution.Version (Version, nullVersion)
import qualified Data.List.NonEmpty as NE
import qualified Distribution.Compat.CharParsing as P
......@@ -36,6 +37,9 @@ instance Pretty PackageIdentifier where
| v == nullVersion = pretty n -- if no version, don't show version.
| otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
instance Described PackageIdentifier where
describe _ = describe (Proxy :: Proxy PackageName) <> fromString "-" <> describe (Proxy :: Proxy Version)
-- |
--
-- >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier
......
......@@ -21,6 +21,7 @@ import qualified Distribution.Utils.CharSet as CS
import Distribution.ModuleName (ModuleName)
import Distribution.Types.Dependency (Dependency)
import Distribution.Types.Flag (FlagName)
import Distribution.Types.PackageId (PackageIdentifier)
import Distribution.Types.PackageName (PackageName)
import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint)
import Distribution.Types.Version (Version)
......@@ -36,6 +37,7 @@ tests :: TestTree
tests = testGroup "Described"
[ testDescribed (Proxy :: Proxy Dependency)
, testDescribed (Proxy :: Proxy PackageName)
, testDescribed (Proxy :: Proxy PackageIdentifier)
, testDescribed (Proxy :: Proxy PackageVersionConstraint)
, testDescribed (Proxy :: Proxy Version)
, testDescribed (Proxy :: Proxy VersionRange)
......
......@@ -14,16 +14,16 @@ module Distribution.Client.Types.AllowNewer (
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Types.PackageId (PackageId, PackageIdentifier (..))
import Distribution.Types.PackageName (PackageName, mkPackageName)
import Distribution.Types.Version (nullVersion)
import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..))
import Distribution.Parsec (CabalParsing, Parsec (..), parsecLeadingCommaNonEmpty)
import Distribution.Pretty (Pretty (..))
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
import Distribution.Parsec (CabalParsing, Parsec (..), parsecLeadingCommaList)
import Distribution.Pretty (Pretty (..))
-- $setup
-- >>> import Distribution.Parsec
......@@ -99,6 +99,18 @@ instance Pretty RelaxedDep where
instance Parsec RelaxedDep where
parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
instance Described RelaxedDep where
describe _ =
REOpt (describeRelaxDepScope <> fromString ":" <> REOpt (fromString "^"))
<> describe (Proxy :: Proxy RelaxDepSubject)
where
describeRelaxDepScope = REUnion
[ fromString "*"
, fromString "all"
, RENamed "package-name" (describe (Proxy :: Proxy PackageName))
, RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))
]
-- continuation after *
relaxedDepStarP :: CabalParsing m => m RelaxedDep
relaxedDepStarP =
......@@ -136,6 +148,13 @@ instance Parsec RelaxDepSubject where
then RelaxDepSubjectAll
else RelaxDepSubjectPkg pn
instance Described RelaxDepSubject where
describe _ = REUnion
[ fromString "*"
, fromString "all"
, RENamed "package-name" (describe (Proxy :: Proxy PackageName))
]
instance Pretty RelaxDeps where
pretty rd | not (isRelaxDeps rd) = Disp.text "none"
pretty (RelaxDepsSome pkgs) = Disp.fsep .
......@@ -164,17 +183,28 @@ instance Pretty RelaxDeps where
--
-- >>> simpleParsec ", all" :: Maybe RelaxDeps
-- Just RelaxDepsAll
--
--
-- >>> simpleParsec "" :: Maybe RelaxDeps
-- Nothing
--
instance Parsec RelaxDeps where
parsec = do
xs <- parsecLeadingCommaList parsec
pure $ case xs of
xs <- parsecLeadingCommaNonEmpty parsec
pure $ case toList xs of
[RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
-> RelaxDepsAll
[RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
| pn == mkPackageName "none"
| pn == mkPackageName "none"
-> mempty
_ -> mkRelaxDepSome xs
xs' -> mkRelaxDepSome xs'
instance Described RelaxDeps where
describe _ = REUnion
[ fromString "*"
, fromString "all"
, fromString "none"
, RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))
]
instance Binary RelaxDeps
instance Binary RelaxDepMod
......@@ -205,7 +235,7 @@ mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
mkRelaxDepSome xs
| any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs
= RelaxDepsAll
| otherwise
= RelaxDepsSome xs
......
......@@ -27,11 +27,12 @@ import Distribution.Utils.NubList
import Distribution.Client.BuildReports.Types (ReportLevel (..))
import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos (..), ActiveRepoEntry (..), CombineStrategy (..))
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
import Distribution.Client.InstallSymlink (OverwritePolicy)
import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy)
import Distribution.Client.Types.AllowNewer
import Test.QuickCheck
import Test.QuickCheck.Instances.Cabal ()
......@@ -215,3 +216,33 @@ instance Arbitrary ActiveRepoEntry where
instance Arbitrary CombineStrategy where
arbitrary = arbitraryBoundedEnum
shrink = shrinkBoundedEnum
instance Arbitrary AllowNewer where
arbitrary = AllowNewer <$> arbitrary
instance Arbitrary AllowOlder where
arbitrary = AllowOlder <$> arbitrary
instance Arbitrary RelaxDeps where
arbitrary = oneof [ pure mempty
, mkRelaxDepSome <$> shortListOf1 3 arbitrary
, pure RelaxDepsAll
]
instance Arbitrary RelaxDepMod where
arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
instance Arbitrary RelaxDepScope where
arbitrary = oneof [ pure RelaxDepScopeAll
, RelaxDepScopePackage <$> arbitrary
, RelaxDepScopePackageId <$> arbitrary
]
instance Arbitrary RelaxDepSubject where
arbitrary = oneof [ pure RelaxDepSubjectAll
, RelaxDepSubjectPkg <$> arbitrary
]
instance Arbitrary RelaxedDep where
arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary
......@@ -11,8 +11,7 @@ import Test.QuickCheck (Arbitrary (..), Gen, Property, choose, counterexam
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
import Distribution.FieldGrammar.Described
(Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList)
import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList)
import Distribution.Parsec (eitherParsec)
import Distribution.Pretty (prettyShow)
......@@ -22,6 +21,7 @@ import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos)
import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp)
import Distribution.Client.Types (RepoName)
import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep)
import qualified RERE as RE
import qualified RERE.CharSet as RE
......@@ -36,6 +36,9 @@ tests = testGroup "Described"
, testDescribed (Proxy :: Proxy TotalIndexState)
, testDescribed (Proxy :: Proxy RepoName)
, testDescribed (Proxy :: Proxy ActiveRepos)
, testDescribed (Proxy :: Proxy RelaxDepSubject)
, testDescribed (Proxy :: Proxy RelaxedDep)
, testDescribed (Proxy :: Proxy RelaxDeps)
]
-------------------------------------------------------------------------------
......
......@@ -843,35 +843,6 @@ instance Arbitrary OnlyConstrained where
, pure OnlyConstrainedNone
]
instance Arbitrary AllowNewer where
arbitrary = AllowNewer <$> arbitrary
instance Arbitrary AllowOlder where
arbitrary = AllowOlder <$> arbitrary
instance Arbitrary RelaxDeps where
arbitrary = oneof [ pure mempty
, mkRelaxDepSome <$> shortListOf1 3 arbitrary
, pure RelaxDepsAll
]
instance Arbitrary RelaxDepMod where
arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
instance Arbitrary RelaxDepScope where
arbitrary = oneof [ pure RelaxDepScopeAll
, RelaxDepScopePackage <$> arbitrary
, RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary)
]
instance Arbitrary RelaxDepSubject where
arbitrary = oneof [ pure RelaxDepSubjectAll
, RelaxDepSubjectPkg <$> arbitrary
]
instance Arbitrary RelaxedDep where
arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary ProfDetailLevel where
arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment