diff --git a/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal b/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal index 1f257a541af..8f392d12f55 100644 --- a/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal +++ b/Cabal/Cabal-QuickCheck/Cabal-QuickCheck.cabal @@ -12,6 +12,7 @@ library ghc-options: -Wall build-depends: , base + , bytestring , Cabal ^>=3.3.0.0 , QuickCheck ^>=2.13.2 || ^>=2.14 diff --git a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs b/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs index f2e3059f69f..419243ab1be 100644 --- a/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs +++ b/Cabal/Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs @@ -5,7 +5,7 @@ module Test.QuickCheck.Instances.Cabal () where import Control.Applicative (liftA2) import Data.Char (isAlphaNum, isDigit) -import Data.List (intercalate) +import Data.List (intercalate, isPrefixOf) import Data.List.NonEmpty (NonEmpty (..)) import Distribution.Utils.Generic (lowercase) import Test.QuickCheck @@ -15,26 +15,34 @@ import Distribution.Compat.NonEmptySet (NonEmptySet) import Distribution.Compiler import Distribution.FieldGrammar.Newtypes import Distribution.ModuleName +import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..), knownProfDetailLevels) import Distribution.Simple.Flag (Flag (..)) +import Distribution.Simple.InstallDirs +import Distribution.Simple.Setup (HaddockTarget (..), TestShowDetails (..)) import Distribution.SPDX import Distribution.System import Distribution.Types.Dependency import Distribution.Types.Flag (FlagAssignment, FlagName, mkFlagAssignment, mkFlagName, unFlagAssignment) import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName +import Distribution.Types.LibraryVisibility import Distribution.Types.Mixin import Distribution.Types.ModuleRenaming import Distribution.Types.PackageId import Distribution.Types.PackageName import Distribution.Types.PackageVersionConstraint +import Distribution.Types.PkgconfigVersion +import Distribution.Types.PkgconfigVersionRange import Distribution.Types.SourceRepo import Distribution.Types.UnqualComponentName import Distribution.Types.VersionRange.Internal +import Distribution.Utils.NubList import Distribution.Verbosity import Distribution.Version import Test.QuickCheck.GenericArbitrary +import qualified Data.ByteString.Char8 as BS8 import qualified Distribution.Compat.NonEmptySet as NES #if !MIN_VERSION_base(4,8,0) @@ -179,6 +187,16 @@ instance Arbitrary ModuleRenaming where arbitrary = genericArbitrary shrink = genericShrink +------------------------------------------------------------------------------- +-- +------------------------------------------------------------------------------- + +instance Arbitrary LibraryVisibility where + arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] + + shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] + shrink LibraryVisibilityPrivate = [] + ------------------------------------------------------------------------------- -- ModuleName ------------------------------------------------------------------------------- @@ -355,6 +373,15 @@ instance Arbitrary CompilerId where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary ProfDetailLevel where + arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] + +instance Arbitrary OptimisationLevel where + arbitrary = elements [minBound..maxBound] + +instance Arbitrary DebugInfoLevel where + arbitrary = elements [minBound..maxBound] + ------------------------------------------------------------------------------- -- NonEmptySet ------------------------------------------------------------------------------- @@ -368,6 +395,97 @@ instance (Arbitrary a, Ord a) => Arbitrary (NonEmptySet a) where where mk (x,xs) = NES.fromNonEmpty (x :| xs) +------------------------------------------------------------------------------- +-- NubList +------------------------------------------------------------------------------- + +instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where + arbitrary = toNubList <$> arbitrary + shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] + -- try empty, otherwise don't shrink as it can loop + +------------------------------------------------------------------------------- +-- InstallDirs +------------------------------------------------------------------------------- + +instance Arbitrary a => Arbitrary (InstallDirs a) where + arbitrary = InstallDirs + <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 + <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 + +instance Arbitrary PathTemplate where + arbitrary = toPathTemplate <$> arbitraryShortToken + shrink t = [ toPathTemplate s + | s <- shrink (fromPathTemplate t) + , not (null s) ] + +------------------------------------------------------------------------------- +-- Pkgconfig +------------------------------------------------------------------------------- + +instance Arbitrary PkgconfigVersion where + arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems where + elems = frequency + [ (2, pure ".") + , (1, pure "-") + , (5, listOf1 $ elements ['0' .. '9']) + , (1, listOf1 $ elements ['A' .. 'Z']) + , (1, listOf1 $ elements ['a' .. 'z']) + ] + + -- disallow versions starting with dash + dropDash = notEmpty . dropWhile (== '-') + notEmpty x + | null x = "0" + | otherwise = x + +instance Arbitrary PkgconfigVersionRange where + arbitrary = sized verRangeExp + where + verRangeExp n = frequency $ + [ (2, return PcAnyVersion) + , (1, fmap PcThisVersion arbitrary) + , (1, fmap PcLaterVersion arbitrary) + , (1, fmap PcOrLaterVersion arbitrary) + , (1, fmap orLaterVersion' arbitrary) + , (1, fmap PcEarlierVersion arbitrary) + , (1, fmap PcOrEarlierVersion arbitrary) + , (1, fmap orEarlierVersion' arbitrary) + ] ++ if n == 0 then [] else + [ (2, liftA2 PcUnionVersionRanges verRangeExp2 verRangeExp2) + , (2, liftA2 PcIntersectVersionRanges verRangeExp2 verRangeExp2) + ] + where + verRangeExp2 = verRangeExp (n `div` 2) + + orLaterVersion' v = + PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) + orEarlierVersion' v = + PcUnionVersionRanges (PcEarlierVersion v) (PcThisVersion v) + +------------------------------------------------------------------------------- +-- Setup +------------------------------------------------------------------------------- + +instance Arbitrary HaddockTarget where + arbitrary = elements [ForHackage, ForDevelopment] + +instance Arbitrary TestShowDetails where + arbitrary = arbitraryBoundedEnum + +------------------------------------------------------------------------------- +-- PackageDB +------------------------------------------------------------------------------- + +instance Arbitrary PackageDB where + arbitrary = oneof [ pure GlobalPackageDB + , pure UserPackageDB + , SpecificPackageDB <$> arbitraryShortToken + ] + + ------------------------------------------------------------------------------- -- Helpers ------------------------------------------------------------------------------- @@ -376,3 +494,7 @@ shortListOf1 :: Int -> Gen a -> Gen [a] shortListOf1 bound gen = sized $ \n -> do k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) vectorOf k gen + +arbitraryShortToken :: Gen String +arbitraryShortToken = + shortListOf1 5 (choose ('#', '~')) `suchThat` (not . ("[]" `isPrefixOf`)) diff --git a/Cabal/tests/UnitTests/Distribution/PkgconfigVersion.hs b/Cabal/tests/UnitTests/Distribution/PkgconfigVersion.hs index 848fc66a1f7..bccc25f7a72 100644 --- a/Cabal/tests/UnitTests/Distribution/PkgconfigVersion.hs +++ b/Cabal/tests/UnitTests/Distribution/PkgconfigVersion.hs @@ -1,23 +1,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans - -fno-warn-deprecations - -fno-warn-incomplete-patterns #-} module UnitTests.Distribution.PkgconfigVersion (pkgconfigVersionTests) where -import Distribution.Compat.Prelude.Internal -import Prelude () - import Test.Tasty import Test.Tasty.QuickCheck -import qualified Data.ByteString.Char8 as BS8 - import Distribution.Parsec (eitherParsec) import Distribution.Pretty -import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange +import Test.QuickCheck.Instances.Cabal () + pkgconfigVersionTests :: [TestTree] pkgconfigVersionTests = [ testProperty "simpleParsec . prettyShow = Just" prop_parse_disp @@ -26,47 +19,3 @@ pkgconfigVersionTests = prop_parse_disp :: PkgconfigVersionRange -> Property prop_parse_disp vr = counterexample (show (prettyShow vr)) $ eitherParsec (prettyShow vr) === Right vr - -------------------------------------------------------------------------------- --- Arbitrary instances -------------------------------------------------------------------------------- - -instance Arbitrary PkgconfigVersion where - arbitrary = PkgconfigVersion . BS8.pack . dropDash . concat <$> listOf1 elems where - elems = frequency - [ (2, pure ".") - , (1, pure "-") - , (5, listOf1 $ elements ['0' .. '9']) - , (1, listOf1 $ elements ['A' .. 'Z']) - , (1, listOf1 $ elements ['a' .. 'z']) - ] - - -- disallow versions starting with dash - dropDash = notEmpty . dropWhile (== '-') - notEmpty x - | null x = "0" - | otherwise = x - -instance Arbitrary PkgconfigVersionRange where - arbitrary = sized verRangeExp - where - verRangeExp n = frequency $ - [ (2, return PcAnyVersion) - , (1, liftM PcThisVersion arbitrary) - , (1, liftM PcLaterVersion arbitrary) - , (1, liftM PcOrLaterVersion arbitrary) - , (1, liftM orLaterVersion' arbitrary) - , (1, liftM PcEarlierVersion arbitrary) - , (1, liftM PcOrEarlierVersion arbitrary) - , (1, liftM orEarlierVersion' arbitrary) - ] ++ if n == 0 then [] else - [ (2, liftM2 PcUnionVersionRanges verRangeExp2 verRangeExp2) - , (2, liftM2 PcIntersectVersionRanges verRangeExp2 verRangeExp2) - ] - where - verRangeExp2 = verRangeExp (n `div` 2) - - orLaterVersion' v = - PcUnionVersionRanges (PcLaterVersion v) (PcThisVersion v) - orEarlierVersion' v = - PcUnionVersionRanges (PcEarlierVersion v) (PcThisVersion v) diff --git a/cabal-install/cabal-install.cabal.dev b/cabal-install/cabal-install.cabal.dev index b2cce1c555a..9a00a594a31 100644 --- a/cabal-install/cabal-install.cabal.dev +++ b/cabal-install/cabal-install.cabal.dev @@ -542,6 +542,7 @@ Test-Suite solver-quickcheck base, async, Cabal, + Cabal-QuickCheck, cabal-lib-client, cabal-install-solver-dsl, containers, diff --git a/cabal-install/cabal-install.cabal.zinza b/cabal-install/cabal-install.cabal.zinza index a714e8c5473..d1d8a14b3ce 100644 --- a/cabal-install/cabal-install.cabal.zinza +++ b/cabal-install/cabal-install.cabal.zinza @@ -570,6 +570,7 @@ Test-Suite solver-quickcheck base, async, Cabal, + Cabal-QuickCheck, cabal-lib-client, cabal-install-solver-dsl, containers, diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index f3bc90655f1..e4a34d35a4a 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -25,12 +25,9 @@ import Prelude () import Data.Char (isLetter) import Data.List ((\\)) -import Distribution.Simple.InstallDirs import Distribution.Simple.Setup import Distribution.Types.Flag (mkFlagAssignment) -import Distribution.Utils.NubList - import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod) import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..)) @@ -149,19 +146,6 @@ instance Arbitrary ShortToken where arbitraryShortToken :: Gen String arbitraryShortToken = getShortToken <$> arbitrary -instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where - arbitrary = toNubList <$> arbitrary - shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] - -- try empty, otherwise don't shrink as it can loop - - -instance Arbitrary PathTemplate where - arbitrary = toPathTemplate <$> arbitraryShortToken - shrink t = [ toPathTemplate s - | s <- shrink (fromPathTemplate t) - , not (null s) ] - - newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a } deriving (Eq, Ord, Show) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index e9f73b0eb1b..0481addd548 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -729,11 +729,7 @@ instance Arbitrary PackageConfig where . Map.map (map getNonEmpty . getNonEmpty) . Map.mapKeys getNoShrink -instance Arbitrary HaddockTarget where - arbitrary = elements [ForHackage, ForDevelopment] -instance Arbitrary TestShowDetails where - arbitrary = arbitraryBoundedEnum instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where arbitrary = SourceRepositoryPackage @@ -754,20 +750,6 @@ instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where (x1, ShortToken x2, fmap ShortToken x3, fmap ShortToken x4, fmap ShortToken x5) ] -instance Arbitrary a => Arbitrary (InstallDirs a) where - arbitrary = - InstallDirs - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 - -instance Arbitrary PackageDB where - arbitrary = oneof [ pure GlobalPackageDB - , pure UserPackageDB - , SpecificPackageDB . getShortToken <$> arbitrary - ] - instance Arbitrary RemoteRepo where arbitrary = RemoteRepo @@ -816,12 +798,3 @@ instance Arbitrary OnlyConstrained where arbitrary = oneof [ pure OnlyConstrainedAll , pure OnlyConstrainedNone ] - -instance Arbitrary ProfDetailLevel where - arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] - -instance Arbitrary OptimisationLevel where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary DebugInfoLevel where - arbitrary = elements [minBound..maxBound] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index 6abff178e5e..c06545c8111 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -16,7 +16,8 @@ import Data.List (groupBy, isInfixOf) import Text.Show.Pretty (parseValue, valToStr) import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck +import Test.QuickCheck (Arbitrary (..), Gen, Positive (..), frequency, oneof, shrinkList, shuffle, listOf, shrinkNothing, vectorOf, elements, sublistOf, counterexample, (===), (==>), Blind (..)) +import Test.QuickCheck.Instances.Cabal () import Distribution.Types.Flag (FlagName) import Distribution.Utils.ShortText (ShortText) @@ -437,33 +438,27 @@ instance Arbitrary IndependentGoals where shrink (IndependentGoals indep) = [IndependentGoals False | indep] -instance Arbitrary LibraryVisibility where - arbitrary = elements [LibraryVisibilityPrivate, LibraryVisibilityPublic] - - shrink LibraryVisibilityPublic = [LibraryVisibilityPrivate] - shrink LibraryVisibilityPrivate = [] - -instance Arbitrary UnqualComponentName where - -- The "component-" prefix prevents component names and build-depends - -- dependency names from overlapping. - -- TODO: Remove the prefix once the QuickCheck tests support dependencies on - -- internal libraries. - arbitrary = - mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC" - instance Arbitrary Component where arbitrary = oneof [ return ComponentLib - , ComponentSubLib <$> arbitrary - , ComponentExe <$> arbitrary - , ComponentFLib <$> arbitrary - , ComponentTest <$> arbitrary - , ComponentBench <$> arbitrary + , ComponentSubLib <$> arbitraryUQN + , ComponentExe <$> arbitraryUQN + , ComponentFLib <$> arbitraryUQN + , ComponentTest <$> arbitraryUQN + , ComponentBench <$> arbitraryUQN , return ComponentSetup ] shrink ComponentLib = [] shrink _ = [ComponentLib] +-- The "component-" prefix prevents component names and build-depends +-- dependency names from overlapping. +-- TODO: Remove the prefix once the QuickCheck tests support dependencies on +-- internal libraries. +arbitraryUQN :: Gen UnqualComponentName +arbitraryUQN = + mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC" + instance Arbitrary ExampleInstalled where arbitrary = error "arbitrary not implemented: ExampleInstalled" @@ -522,11 +517,6 @@ instance Arbitrary OptionalStanza where shrink BenchStanzas = [TestStanzas] shrink TestStanzas = [] -instance Arbitrary VersionRange where - arbitrary = error "arbitrary not implemented: VersionRange" - - shrink vr = [noVersion | vr /= noVersion] - -- Randomly sorts solver variables using 'hash'. -- TODO: Sorting goals with this function is very slow. instance Arbitrary VarOrdering where