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

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE TypeOperators #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5
   6 module UnitTests.Distribution.Client.ArbitraryInstances
   7   ( adjustSize
   8   , shortListOf
   9   , shortListOf1
  10   , arbitraryFlag
  11   , ShortToken (..)
  12   , arbitraryShortToken
  13   , NonMEmpty (..)
  14   , NoShrink (..)
  15
  16     -- * Shrinker
  17   , Shrinker
  18   , runShrinker
  19   , shrinker
  20   , shrinkerPP
  21   , shrinkerAla
  22   ) where
  23
  24 import Distribution.Client.Compat.Prelude
  25 import Prelude ()
  26
  27 import Data.Char (isLetter)
  28 import Data.List ((\\))
  29
  30 import Distribution.Simple.Setup
  31 import Distribution.Types.Flag (mkFlagAssignment)
  32
  33 import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..))
  34 import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
  35 import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..))
  36 import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
  37 import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
  38 import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
  39 import Distribution.Client.Targets
  40 import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy)
  41 import Distribution.Client.Types.AllowNewer
  42 import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
  43 import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate)
  44 import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
  45
  46 import Data.Coerce (Coercible, coerce)
  47 import Network.URI (URI (..), URIAuth (..), isUnreserved)
  48 import Test.QuickCheck
  49   ( Arbitrary (..)
  50   , Gen
  51   , NonEmptyList (..)
  52   , arbitraryBoundedEnum
  53   , choose
  54   , elements
  55   , frequency
  56   , genericShrink
  57   , liftArbitrary
  58   , listOf
  59   , oneof
  60   , resize
  61   , shrinkBoundedEnum
  62   , sized
  63   , suchThat
  64   , vectorOf
  65   )
  66 import Test.QuickCheck.GenericArbitrary (genericArbitrary)
  67 import Test.QuickCheck.Instances.Cabal ()
  68
  69 -- note: there are plenty of instances defined in ProjectConfig test file.
  70 -- they should be moved here or into Cabal-quickcheck
  71
  72 -------------------------------------------------------------------------------
  73 -- Utilities
  74 -------------------------------------------------------------------------------
  75
  76 data Shrinker a = Shrinker a [a]
  77
  78 instance Functor Shrinker where
  79   fmap f (Shrinker x xs) = Shrinker (f x) (map f xs)
  80
  81 instance Applicative Shrinker where
  82   pure x = Shrinker x []
  83
  84   Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs)
  85
  86 runShrinker :: Shrinker a -> [a]
  87 runShrinker (Shrinker _ xs) = xs
  88
  89 shrinker :: Arbitrary a => a -> Shrinker a
  90 shrinker x = Shrinker x (shrink x)
  91
  92 shrinkerAla :: (Coercible a b, Arbitrary b) => (a -> b) -> a -> Shrinker a
  93 shrinkerAla pack = shrinkerPP pack coerce
  94
  95 -- | shrinker with pre and post functions.
  96 shrinkerPP :: Arbitrary b => (a -> b) -> (b -> a) -> a -> Shrinker a
  97 shrinkerPP pack unpack x = Shrinker x (map unpack (shrink (pack x)))
  98
  99 -------------------------------------------------------------------------------
 100 -- Non-Cabal instances
 101 -------------------------------------------------------------------------------
 102
 103 instance Arbitrary URI where
 104   arbitrary =
 105     URI
 106       <$> elements ["file:", "http:", "https:"]
 107       <*> (Just <$> arbitrary)
 108       <*> (('/' :) <$> arbitraryURIToken)
 109       <*> (('?' :) <$> arbitraryURIToken)
 110       <*> pure ""
 111
 112 instance Arbitrary URIAuth where
 113   arbitrary =
 114     URIAuth
 115       <$> pure "" -- no password as this does not roundtrip
 116       <*> arbitraryURIToken
 117       <*> arbitraryURIPort
 118
 119 arbitraryURIToken :: Gen String
 120 arbitraryURIToken =
 121   shortListOf1 6 (elements (filter isUnreserved ['\0' .. '\255']))
 122
 123 arbitraryURIPort :: Gen String
 124 arbitraryURIPort =
 125   oneof [pure "", (':' :) <$> shortListOf1 4 (choose ('0', '9'))]
 126
 127 -------------------------------------------------------------------------------
 128 -- cabal-install (and Cabal) types
 129 -------------------------------------------------------------------------------
 130
 131 adjustSize :: (Int -> Int) -> Gen a -> Gen a
 132 adjustSize adjust gen = sized (\n -> resize (adjust n) gen)
 133
 134 shortListOf :: Int -> Gen a -> Gen [a]
 135 shortListOf bound gen =
 136   sized $ \n -> do
 137     k <- choose (0, (n `div` 2) `min` bound)
 138     vectorOf k gen
 139
 140 shortListOf1 :: Int -> Gen a -> Gen [a]
 141 shortListOf1 bound gen =
 142   sized $ \n -> do
 143     k <- choose (1, 1 `max` ((n `div` 2) `min` bound))
 144     vectorOf k gen
 145
 146 newtype ShortToken = ShortToken {getShortToken :: String}
 147   deriving (Show)
 148
 149 instance Arbitrary ShortToken where
 150   arbitrary =
 151     ShortToken
 152       <$> ( shortListOf1 5 (choose ('#', '~'))
 153               `suchThat` (all (`notElem` "{}"))
 154               `suchThat` (not . ("[]" `isPrefixOf`))
 155           )
 156
 157   -- TODO: [code cleanup] need to replace parseHaskellString impl to stop
 158   -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.
 159   -- Workaround, don't generate [] as this does not round trip.
 160
 161   shrink (ShortToken cs) =
 162     [ShortToken cs' | cs' <- shrink cs, not (null cs')]
 163
 164 arbitraryShortToken :: Gen String
 165 arbitraryShortToken = getShortToken <$> arbitrary
 166
 167 newtype NonMEmpty a = NonMEmpty {getNonMEmpty :: a}
 168   deriving (Eq, Ord, Show)
 169
 170 instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where
 171   arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))
 172   shrink (NonMEmpty x) = [NonMEmpty x' | x' <- shrink x, x' /= mempty]
 173
 174 newtype NoShrink a = NoShrink {getNoShrink :: a}
 175   deriving (Eq, Ord, Show)
 176
 177 instance Arbitrary a => Arbitrary (NoShrink a) where
 178   arbitrary = NoShrink <$> arbitrary
 179   shrink _ = []
 180
 181 instance Arbitrary Timestamp where
 182   -- note: no negative timestamps
 183   --
 184   -- >>> utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 100000 01 01) 0
 185   -- >>> 3093527980800s
 186   --
 187   arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary
 188
 189 instance Arbitrary RepoIndexState where
 190   arbitrary =
 191     frequency
 192       [ (1, pure IndexStateHead)
 193       , (50, IndexStateTime <$> arbitrary)
 194       ]
 195
 196 instance Arbitrary TotalIndexState where
 197   arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary
 198
 199 instance Arbitrary WriteGhcEnvironmentFilesPolicy where
 200   arbitrary = arbitraryBoundedEnum
 201
 202 arbitraryFlag :: Gen a -> Gen (Flag a)
 203 arbitraryFlag = liftArbitrary
 204
 205 instance Arbitrary RepoName where
 206   -- TODO: rename refinement?
 207   arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x)
 208     where
 209       mk = (:) <$> lead <*> rest
 210       lead =
 211         elements
 212           [c | c <- ['\NUL' .. '\255'], isAlpha c || c `elem` "_-."]
 213       rest =
 214         listOf
 215           ( elements
 216               [c | c <- ['\NUL' .. '\255'], isAlphaNum c || c `elem` "_-."]
 217           )
 218
 219 instance Arbitrary ReportLevel where
 220   arbitrary = arbitraryBoundedEnum
 221
 222 instance Arbitrary OverwritePolicy where
 223   arbitrary = arbitraryBoundedEnum
 224
 225 instance Arbitrary InstallMethod where
 226   arbitrary = arbitraryBoundedEnum
 227
 228 -------------------------------------------------------------------------------
 229 -- ActiveRepos
 230 -------------------------------------------------------------------------------
 231
 232 instance Arbitrary ActiveRepos where
 233   arbitrary = ActiveRepos <$> shortListOf 5 arbitrary
 234
 235 instance Arbitrary ActiveRepoEntry where
 236   arbitrary =
 237     frequency
 238       [ (10, ActiveRepo <$> arbitrary <*> arbitrary)
 239       , (1, ActiveRepoRest <$> arbitrary)
 240       ]
 241
 242 instance Arbitrary CombineStrategy where
 243   arbitrary = arbitraryBoundedEnum
 244   shrink = shrinkBoundedEnum
 245
 246 -------------------------------------------------------------------------------
 247 -- AllowNewer
 248 -------------------------------------------------------------------------------
 249
 250 instance Arbitrary AllowNewer where
 251   arbitrary = AllowNewer <$> arbitrary
 252
 253 instance Arbitrary AllowOlder where
 254   arbitrary = AllowOlder <$> arbitrary
 255
 256 instance Arbitrary RelaxDeps where
 257   arbitrary =
 258     oneof
 259       [ pure mempty
 260       , mkRelaxDepSome <$> shortListOf1 3 arbitrary
 261       , pure RelaxDepsAll
 262       ]
 263
 264 instance Arbitrary RelaxDepMod where
 265   arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
 266
 267   shrink RelaxDepModCaret = [RelaxDepModNone]
 268   shrink _ = []
 269
 270 instance Arbitrary RelaxDepScope where
 271   arbitrary = genericArbitrary
 272   shrink = genericShrink
 273
 274 instance Arbitrary RelaxDepSubject where
 275   arbitrary = genericArbitrary
 276   shrink = genericShrink
 277
 278 instance Arbitrary RelaxedDep where
 279   arbitrary = genericArbitrary
 280   shrink = genericShrink
 281
 282 -------------------------------------------------------------------------------
 283 -- UserConstraint
 284 -------------------------------------------------------------------------------
 285
 286 instance Arbitrary UserConstraintScope where
 287   arbitrary = genericArbitrary
 288   shrink = genericShrink
 289
 290 instance Arbitrary UserQualifier where
 291   arbitrary =
 292     oneof
 293       [ pure UserQualToplevel
 294       , UserQualSetup <$> arbitrary
 295       -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
 296       -- , UserQualExe <$> arbitrary <*> arbitrary
 297       ]
 298
 299 instance Arbitrary UserConstraint where
 300   arbitrary = genericArbitrary
 301   shrink = genericShrink
 302
 303 instance Arbitrary PackageProperty where
 304   arbitrary =
 305     oneof
 306       [ PackagePropertyVersion <$> arbitrary
 307       , pure PackagePropertyInstalled
 308       , pure PackagePropertySource
 309       , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary
 310       , PackagePropertyStanzas . (\x -> [x]) <$> arbitrary
 311       ]
 312
 313 instance Arbitrary OptionalStanza where
 314   arbitrary = elements [minBound .. maxBound]
 315
 316 instance Arbitrary OptionalStanzaSet where
 317   arbitrary = fmap optStanzaSetFromList arbitrary
 318
 319 instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where
 320   arbitrary = do
 321     x1 <- arbitrary
 322     x2 <- arbitrary
 323     return $ optStanzaTabulate $ \x -> case x of
 324       TestStanzas -> x1
 325       BenchStanzas -> x2
 326
 327 -------------------------------------------------------------------------------
 328 -- BuildReport
 329 -------------------------------------------------------------------------------
 330
 331 instance Arbitrary BuildReport where
 332   arbitrary = genericArbitrary
 333   shrink = genericShrink
 334
 335 instance Arbitrary InstallOutcome where
 336   arbitrary = genericArbitrary
 337   shrink = genericShrink
 338
 339 instance Arbitrary Outcome where
 340   arbitrary = genericArbitrary
 341   shrink = genericShrink
 342
 343 -------------------------------------------------------------------------------
 344 -- Glob
 345 -------------------------------------------------------------------------------
 346
 347 instance Arbitrary FilePathGlob where
 348   arbitrary =
 349     (FilePathGlob <$> arbitrary <*> arbitrary)
 350       `suchThat` validFilePathGlob
 351
 352   shrink (FilePathGlob root pathglob) =
 353     [ FilePathGlob root' pathglob'
 354     | (root', pathglob') <- shrink (root, pathglob)
 355     , validFilePathGlob (FilePathGlob root' pathglob')
 356     ]
 357
 358 validFilePathGlob :: FilePathGlob -> Bool
 359 validFilePathGlob (FilePathGlob FilePathRelative pathglob) =
 360   case pathglob of
 361     GlobDirTrailing -> False
 362     GlobDir [Literal "~"] _ -> False
 363     GlobDir [Literal (d : ":")] _
 364       | isLetter d -> False
 365     _ -> True
 366 validFilePathGlob _ = True
 367
 368 instance Arbitrary FilePathRoot where
 369   arbitrary =
 370     frequency
 371       [ (3, pure FilePathRelative)
 372       , (1, pure (FilePathRoot unixroot))
 373       , (1, FilePathRoot <$> windrive)
 374       , (1, pure FilePathHomeDir)
 375       ]
 376     where
 377       unixroot = "/"
 378       windrive = do d <- choose ('A', 'Z'); return (d : ":\\")
 379
 380   shrink FilePathRelative = []
 381   shrink (FilePathRoot _) = [FilePathRelative]
 382   shrink FilePathHomeDir = [FilePathRelative]
 383
 384 instance Arbitrary FilePathGlobRel where
 385   arbitrary = sized $ \sz ->
 386     oneof $
 387       take
 388         (max 1 sz)
 389         [ pure GlobDirTrailing
 390         , GlobFile <$> (getGlobPieces <$> arbitrary)
 391         , GlobDir
 392             <$> (getGlobPieces <$> arbitrary)
 393             <*> resize (sz `div` 2) arbitrary
 394         ]
 395
 396   shrink GlobDirTrailing = []
 397   shrink (GlobFile glob) =
 398     GlobDirTrailing
 399       : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)]
 400   shrink (GlobDir glob pathglob) =
 401     pathglob
 402       : GlobFile glob
 403       : [ GlobDir (getGlobPieces glob') pathglob'
 404         | (glob', pathglob') <- shrink (GlobPieces glob, pathglob)
 405         ]
 406
 407 newtype GlobPieces = GlobPieces {getGlobPieces :: [GlobPiece]}
 408   deriving (Eq)
 409
 410 instance Arbitrary GlobPieces where
 411   arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary
 412
 413   shrink (GlobPieces glob) =
 414     [ GlobPieces (mergeLiterals (getNonEmpty glob'))
 415     | glob' <- shrink (NonEmpty glob)
 416     ]
 417
 418 mergeLiterals :: [GlobPiece] -> [GlobPiece]
 419 mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps)
 420 mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps
 421 mergeLiterals (p : ps) = p : mergeLiterals ps
 422 mergeLiterals [] = []
 423
 424 instance Arbitrary GlobPiece where
 425   arbitrary = sized $ \sz ->
 426     frequency
 427       [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars))
 428       , (1, pure WildCard)
 429       , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary)))
 430       ]
 431
 432   shrink (Literal str) =
 433     [ Literal str'
 434     | str' <- shrink str
 435     , not (null str')
 436     , all (`elem` globLiteralChars) str'
 437     ]
 438   shrink WildCard = []
 439   shrink (Union as) =
 440     [ Union (map getGlobPieces (getNonEmpty as'))
 441     | as' <- shrink (NonEmpty (map GlobPieces as))
 442     ]
 443
 444 globLiteralChars :: [Char]
 445 globLiteralChars = ['\0' .. '\128'] \\ "*{},/\\"