Issue 6882 move arbitrary instances

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
 

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`))

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)

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,

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,

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)
 

cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

@@ -26,9 +26,6 @@ import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.Compiler
 import Distribution.Version
-import Distribution.Simple.Compiler
-import Distribution.Simple.Setup
-import Distribution.Simple.InstallDirs
 import Distribution.Simple.Program.Types
 import Distribution.Simple.Program.Db
 import Distribution.Types.PackageVersionConstraint
@@ -729,11 +726,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 +747,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 +795,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]