Put Arbitrary instances for Cabal types in their own package.

This is with the intention of the new package,
cabal-quickcheck-instances, being the blessed location for these
orphans, as QuickCheck acquiring a Cabal dependency or vice-versa
would be unsuitable.

This reduces some duplication (some presumably deliberate, and some
apparently accidental) and then some drift between the versions of
these instances.

Due to haskell#1575, some tests have had to move from the Cabal package to
cabal-install.

Author: quasicomputational

Cabal/Cabal.cabal

@@ -490,21 +490,17 @@ test-suite unit-tests
   hs-source-dirs: tests
   other-modules:
     Test.Laws
-    Test.QuickCheck.Utils
     UnitTests.Distribution.Compat.CreatePipe
     UnitTests.Distribution.Compat.ReadP
     UnitTests.Distribution.Compat.Time
     UnitTests.Distribution.Compat.Graph
     UnitTests.Distribution.Simple.Glob
     UnitTests.Distribution.Simple.Program.Internal
     UnitTests.Distribution.Simple.Utils
-    UnitTests.Distribution.SPDX
-    UnitTests.Distribution.System
     UnitTests.Distribution.Types.GenericPackageDescription
     UnitTests.Distribution.Utils.Generic
     UnitTests.Distribution.Utils.NubList
     UnitTests.Distribution.Utils.ShortText
-    UnitTests.Distribution.Version
   main-is: UnitTests.hs
   build-depends:
     array,

Cabal/tests/Test/QuickCheck/Utils.hs

@@ -20,12 +20,9 @@ import qualified UnitTests.Distribution.Compat.Graph
 import qualified UnitTests.Distribution.Simple.Glob
 import qualified UnitTests.Distribution.Simple.Program.Internal
 import qualified UnitTests.Distribution.Simple.Utils
-import qualified UnitTests.Distribution.System
 import qualified UnitTests.Distribution.Utils.Generic
 import qualified UnitTests.Distribution.Utils.NubList
 import qualified UnitTests.Distribution.Utils.ShortText
-import qualified UnitTests.Distribution.Version (versionTests)
-import qualified UnitTests.Distribution.SPDX (spdxTests)
 import qualified UnitTests.Distribution.Types.GenericPackageDescription
 
 tests :: Int -> TestTree
@@ -56,14 +53,8 @@ tests mtimeChangeCalibrated =
         UnitTests.Distribution.Utils.NubList.tests
     , testGroup "Distribution.Utils.ShortText"
         UnitTests.Distribution.Utils.ShortText.tests
-    , testGroup "Distribution.System"
-        UnitTests.Distribution.System.tests
     , testGroup "Distribution.Types.GenericPackageDescription"
         UnitTests.Distribution.Types.GenericPackageDescription.tests
-    , testGroup "Distribution.Version"
-        UnitTests.Distribution.Version.versionTests
-    , testGroup "Distribution.SPDX"
-        UnitTests.Distribution.SPDX.spdxTests
     ]
 
 extraOptions :: [OptionDescription]

Cabal/tests/UnitTests.hs

@@ -525,13 +525,23 @@
     UnitTests.Distribution.Solver.Modular.WeightedPSQ
     UnitTests.Options
     UnitTests.TempTestDir
+
+    -- These are tests that would live in the Cabal package, except
+    -- that they need Arbitrary instances from
+    -- cabal-quickcheck-instances and then we run into #1575. If/when
+    -- that's fixed, these modules can go back there.
+    UnitTests.Distribution.SPDX
+    UnitTests.Distribution.System
+    UnitTests.Distribution.Version
+
   build-depends:
         array,
         base,
         async,
         bytestring,
         cabal-lib-client,
         cabal-install-solver-dsl,
+        cabal-quickcheck-instances,
         Cabal,
         containers,
         deepseq,

cabal-install/cabal-install.cabal.pp

@@ -28,6 +28,9 @@ import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
 import qualified UnitTests.Distribution.Client.InstallPlan
 import qualified UnitTests.Distribution.Client.VCS
 import qualified UnitTests.Distribution.Client.Get
+import qualified UnitTests.Distribution.SPDX
+import qualified UnitTests.Distribution.System
+import qualified UnitTests.Distribution.Version
 
 import UnitTests.Options
 
@@ -78,6 +81,12 @@ tests mtimeChangeCalibrated =
        UnitTests.Distribution.Client.VCS.tests mtimeChange
   , testGroup "UnitTests.Distribution.Client.Get"
        UnitTests.Distribution.Client.Get.tests
+  , testGroup "UnitTests.Distribution.SPDX"
+       UnitTests.Distribution.SPDX.spdxTests
+  , testGroup "UnitTests.Distribution.System"
+       UnitTests.Distribution.System.tests
+  , testGroup "UnitTestsDistribution.Version"
+       UnitTests.Distribution.Version.versionTests
   ]
 
 main :: IO ()

cabal-install/tests/UnitTests.hs

@@ -3,11 +3,7 @@
 
 module UnitTests.Distribution.Client.ArbitraryInstances (
     adjustSize,
-    shortListOf,
-    shortListOf1,
     arbitraryFlag,
-    ShortToken(..),
-    arbitraryShortToken,
     NonMEmpty(..),
     NoShrink(..),
   ) where
@@ -39,144 +35,14 @@ import Distribution.Client.IndexUtils.Timestamp
 import Test.QuickCheck
 
 
-adjustSize :: (Int -> Int) -> Gen a -> Gen a
-adjustSize adjust gen = sized (\n -> resize (adjust n) gen)
-
-shortListOf :: Int -> Gen a -> Gen [a]
-shortListOf bound gen =
-    sized $ \n -> do
-      k <- choose (0, (n `div` 2) `min` bound)
-      vectorOf k gen
-
-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
-
-newtype ShortToken = ShortToken { getShortToken :: String }
-  deriving Show
-
-instance Arbitrary ShortToken where
-  arbitrary =
-    ShortToken <$>
-      (shortListOf1 5 (choose ('#', '~'))
-       `suchThat` (not . ("[]" `isPrefixOf`)))
-    --TODO: [code cleanup] need to replace parseHaskellString impl to stop
-    -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.
-    -- Workaround, don't generate [] as this does not round trip.
-
-
-  shrink (ShortToken cs) =
-    [ ShortToken cs' | cs' <- shrink cs, not (null cs') ]
-
-arbitraryShortToken :: Gen String
-arbitraryShortToken = getShortToken <$> arbitrary
-
-instance Arbitrary Version where
-  arbitrary = do
-    branch <- shortListOf1 4 $
-                frequency [(3, return 0)
-                          ,(3, return 1)
-                          ,(2, return 2)
-                          ,(1, return 3)]
-    return (mkVersion branch)
-    where
-
-  shrink ver = [ mkVersion branch' | branch' <- shrink (versionNumbers ver)
-                                   , not (null branch') ]
-
-instance Arbitrary VersionRange where
-  arbitrary = canonicaliseVersionRange <$> sized verRangeExp
-    where
-      verRangeExp n = frequency $
-        [ (2, return anyVersion)
-        , (1, liftM thisVersion arbitrary)
-        , (1, liftM laterVersion arbitrary)
-        , (1, liftM orLaterVersion arbitrary)
-        , (1, liftM orLaterVersion' arbitrary)
-        , (1, liftM earlierVersion arbitrary)
-        , (1, liftM orEarlierVersion arbitrary)
-        , (1, liftM orEarlierVersion' arbitrary)
-        , (1, liftM withinVersion arbitrary)
-        , (2, liftM VersionRangeParens arbitrary)
-        ] ++ if n == 0 then [] else
-        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)
-        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
-        ]
-        where
-          verRangeExp2 = verRangeExp (n `div` 2)
-
-      orLaterVersion'   v =
-        unionVersionRanges (laterVersion v)   (thisVersion v)
-      orEarlierVersion' v =
-        unionVersionRanges (earlierVersion v) (thisVersion v)
-
-      canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals
-
-instance Arbitrary PackageName where
-    arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent
-      where
-        nameComponent = shortListOf1 5 (elements packageChars)
-                        `suchThat` (not . all isDigit)
-        packageChars  = filter isAlphaNum ['\0'..'\127']
-
-instance Arbitrary Dependency where
-    arbitrary = Dependency <$> arbitrary <*> arbitrary <*> fmap getNonMEmpty arbitrary
-
 instance Arbitrary PackageVersionConstraint where
     arbitrary = PackageVersionConstraint <$> arbitrary <*> arbitrary
 
-instance Arbitrary UnqualComponentName where
-    -- same rules as package names
-    arbitrary = packageNameToUnqualComponentName <$> arbitrary
-
-instance Arbitrary LibraryName where
-    arbitrary = elements =<< sequenceA [LSubLibName <$> arbitrary, pure LMainLibName]
-
-instance Arbitrary OS where
-    arbitrary = elements knownOSs
-
-instance Arbitrary Arch where
-    arbitrary = elements knownArches
-
-instance Arbitrary Platform where
-    arbitrary = Platform <$> arbitrary <*> arbitrary
-
-instance Arbitrary a => Arbitrary (Flag a) where
-    arbitrary = arbitraryFlag arbitrary
-    shrink NoFlag   = []
-    shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ]
-
-arbitraryFlag :: Gen a -> Gen (Flag a)
-arbitraryFlag genA =
-    sized $ \sz ->
-      case sz of
-        0 -> pure NoFlag
-        _ -> frequency [ (1, pure NoFlag)
-                       , (3, Flag <$> genA) ]
-
-
 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 Verbosity where
-    arbitrary = elements [minBound..maxBound]
-
-instance Arbitrary PathTemplate where
-    arbitrary = toPathTemplate <$> arbitraryShortToken
-    shrink t  = [ toPathTemplate s | s <- shrink (show t), not (null s) ]
-
-
-newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a }
-  deriving (Eq, Ord, Show)
-
-instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where
-  arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))
-  shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ]
-
 newtype NoShrink a = NoShrink { getNoShrink :: a }
   deriving (Eq, Ord, Show)
 

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

@@ -790,13 +790,6 @@ instance Arbitrary PackageProperty where
 instance Arbitrary OptionalStanza where
     arbitrary = elements [minBound..maxBound]
 
-instance Arbitrary FlagName where
-    arbitrary = mkFlagName <$> flagident
-      where
-        flagident   = lowercase <$> shortListOf1 5 (elements flagChars)
-                      `suchThat` (("-" /=) . take 1)
-        flagChars   = "-_" ++ ['a'..'z']
-
 instance Arbitrary PreSolver where
     arbitrary = elements [minBound..maxBound]
 

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

@@ -1,4 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
 module UnitTests.Distribution.SPDX (spdxTests) where
 
 import Distribution.Compat.Prelude.Internal
@@ -8,6 +7,8 @@ import Distribution.SPDX
 import Distribution.Parsec.Class (eitherParsec)
 import Distribution.Pretty (prettyShow)
 
+import Distribution.Instances.Arbitrary ()
+
 import Test.Tasty
 import Test.Tasty.QuickCheck
 
@@ -113,46 +114,3 @@ shouldAcceptProp = conjoin $
 shouldRejectProp :: Property
 shouldRejectProp = conjoin $
     map (\l -> counterexample (prettyShow l) (not $ isAcceptableLicense l)) shouldReject
-
--------------------------------------------------------------------------------
--- Instances
--------------------------------------------------------------------------------
-
-instance Arbitrary LicenseId where
-    arbitrary = elements $ licenseIdList LicenseListVersion_3_2
-
-instance Arbitrary LicenseExceptionId where
-    arbitrary = elements $ licenseExceptionIdList LicenseListVersion_3_2
-
-instance Arbitrary LicenseRef where
-    arbitrary = mkLicenseRef' <$> ids' <*> ids
-      where
-        ids = listOf1 $ elements $ ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0'..'9'] ++ "_-"
-        ids' = oneof [ pure Nothing, Just <$> ids ]
-
-instance Arbitrary SimpleLicenseExpression where
-    arbitrary = oneof
-        [ ELicenseId <$> arbitrary
-        , ELicenseIdPlus <$> arbitrary
-        , ELicenseRef <$> arbitrary
-        ]
-
-instance Arbitrary LicenseExpression where
-    arbitrary = sized arb
-      where
-        arb n
-            | n <= 0     = ELicense <$> arbitrary <*> pure Nothing
-            | otherwise = oneof
-                [ ELicense <$> arbitrary <*> arbitrary
-                , EAnd <$> arbA <*> arbB
-                , EOr <$> arbA <*> arbB
-                ]
-              where
-                m = n `div` 2
-                arbA = arb m 
-                arbB = arb (n - m)
-
-    shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b))
-    shrink (EOr a b)  = a : b : map (uncurry EOr) (shrink (a, b))
-    shrink _          = []
-