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

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5
   6 -- simplifier goes nuts otherwise
   7 #if __GLASGOW_HASKELL__ < 806
   8 {-# OPTIONS_GHC -funfolding-use-threshold=30 #-}
   9 #endif
  10
  11 module UnitTests.Distribution.Client.ProjectConfig (tests) where
  12
  13 import Control.Monad
  14 import Data.Either (isRight)
  15 import Data.Foldable (for_)
  16 import Data.List (intercalate, isPrefixOf, (\\))
  17 import Data.List.NonEmpty (NonEmpty (..))
  18 import Data.Map (Map)
  19 import qualified Data.Map as Map
  20 import Data.Maybe (fromMaybe)
  21 import Network.URI (URI)
  22 import System.Directory (canonicalizePath, withCurrentDirectory)
  23 import System.FilePath
  24 import System.IO.Unsafe (unsafePerformIO)
  25
  26 import Distribution.Deprecated.ParseUtils
  27 import qualified Distribution.Deprecated.ReadP as Parse
  28
  29 import Distribution.Compiler
  30 import Distribution.Package
  31 import Distribution.PackageDescription
  32 import qualified Distribution.Simple.InstallDirs as InstallDirs
  33 import Distribution.Simple.Program.Db
  34 import Distribution.Simple.Program.Types
  35 import Distribution.Simple.Utils (toUTF8BS)
  36 import Distribution.Types.PackageVersionConstraint
  37 import Distribution.Version
  38
  39 import Distribution.Parsec
  40 import Distribution.Pretty
  41
  42 import Distribution.Client.CmdInstall.ClientInstallFlags
  43 import Distribution.Client.Dependency.Types
  44 import Distribution.Client.DistDirLayout (defaultProjectFile)
  45 import Distribution.Client.Targets
  46 import Distribution.Client.Types
  47 import Distribution.Client.Types.SourceRepo
  48 import Distribution.Utils.NubList
  49 import Distribution.Verbosity (silent)
  50
  51 import Distribution.Solver.Types.ConstraintSource
  52 import Distribution.Solver.Types.PackageConstraint
  53 import Distribution.Solver.Types.ProjectConfigPath
  54 import Distribution.Solver.Types.Settings
  55
  56 import Distribution.Client.ProjectConfig
  57 import Distribution.Client.ProjectConfig.Legacy
  58
  59 import UnitTests.Distribution.Client.ArbitraryInstances
  60 import UnitTests.Distribution.Client.TreeDiffInstances ()
  61
  62 import Data.TreeDiff.Class
  63 import Data.TreeDiff.QuickCheck
  64 import Test.Tasty
  65 import Test.Tasty.HUnit
  66 import Test.Tasty.QuickCheck
  67
  68 tests :: [TestTree]
  69 tests =
  70   [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $
  71       [ testProperty "packages" prop_roundtrip_legacytypes_packages
  72       , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly
  73       , testProperty "specific" prop_roundtrip_legacytypes_specific
  74       ]
  75         ++
  76         -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older
  77         -- unclear why as of yet
  78         concat
  79           [ [ testProperty "shared" prop_roundtrip_legacytypes_shared
  80             , testProperty "local" prop_roundtrip_legacytypes_local
  81             , testProperty "all" prop_roundtrip_legacytypes_all
  82             ]
  83           | not usingGhc76orOlder
  84           ]
  85   , testGroup
  86       "individual parser tests"
  87       [ testProperty "package location" prop_parsePackageLocationTokenQ
  88       , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep
  89       , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps
  90       , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps'
  91       ]
  92   , testGroup
  93       "ProjectConfig printing/parsing round trip"
  94       [ testProperty "packages" prop_roundtrip_printparse_packages
  95       , testProperty "buildonly" prop_roundtrip_printparse_buildonly
  96       , testProperty "shared" prop_roundtrip_printparse_shared
  97       , testProperty "local" prop_roundtrip_printparse_local
  98       , testProperty "specific" prop_roundtrip_printparse_specific
  99       , testProperty "all" prop_roundtrip_printparse_all
 100       ]
 101   , testFindProjectRoot
 102   ]
 103   where
 104     usingGhc76orOlder =
 105       case buildCompilerId of
 106         CompilerId GHC v -> v < mkVersion [7, 7]
 107         _ -> False
 108
 109 testFindProjectRoot :: TestTree
 110 testFindProjectRoot =
 111   testGroup
 112     "findProjectRoot"
 113     [ test "defaults" (cd dir) Nothing Nothing (succeeds dir file)
 114     , test "defaults in lib" (cd libDir) Nothing Nothing (succeeds dir file)
 115     , test "explicit file" (cd dir) Nothing (Just file) (succeeds dir file)
 116     , test "explicit file in lib" (cd libDir) Nothing (Just file) (succeeds dir file)
 117     , test "other file" (cd dir) Nothing (Just fileOther) (succeeds dir fileOther)
 118     , test "other file in lib" (cd libDir) Nothing (Just fileOther) (succeeds dir fileOther)
 119     , -- Deprecated use-case
 120       test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file)
 121     , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile)
 122     , test "nested file in lib" (cd libDir) Nothing (Just nixFile) (succeeds dir nixFile)
 123     , test "explicit dir" Nothing (Just dir) Nothing (succeeds dir file)
 124     , test "explicit dir & file" Nothing (Just dir) (Just file) (succeeds dir file)
 125     , test "explicit dir & nested file" Nothing (Just dir) (Just nixFile) (succeeds dir nixFile)
 126     , test "explicit dir & nested other file" Nothing (Just dir) (Just nixOther) (succeeds dir nixOther)
 127     , test "explicit dir & absolute file" Nothing (Just dir) (Just absFile) (succeedsWith ProjectRootExplicitAbsolute dir absFile)
 128     ]
 129   where
 130     dir = fixturesDir </> "project-root"
 131     libDir = dir </> "lib"
 132
 133     file = defaultProjectFile
 134     fileOther = file <.> "other"
 135     absFile = dir </> file
 136
 137     nixFile = "nix" </> file
 138     nixOther = nixFile <.> "other"
 139
 140     missing path = Just (path <.> "does_not_exist")
 141
 142     test name wrap projectDir projectFile validate =
 143       testCaseSteps name $ \step -> fromMaybe id wrap $ do
 144         result <- findProjectRoot silent projectDir projectFile
 145         _ <- validate result
 146
 147         when (isRight result) $ do
 148           for_ projectDir $ \path -> do
 149             step "missing project dir"
 150             fails =<< findProjectRoot silent (missing path) projectFile
 151
 152           for_ projectFile $ \path -> do
 153             step "missing project file"
 154             fails =<< findProjectRoot silent projectDir (missing path)
 155
 156     cd d = Just (withCurrentDirectory d)
 157
 158     succeeds = succeedsWith ProjectRootExplicit
 159
 160     succeedsWith mk projectDir projectFile result = case result of
 161       Left err -> assertFailure $ "Expected ProjectRoot, but found " <> show err
 162       Right pr -> pr @?= mk projectDir projectFile
 163
 164     fails result = case result of
 165       Left _ -> pure ()
 166       Right x -> assertFailure $ "Expected an error, but found " <> show x
 167
 168 fixturesDir :: FilePath
 169 fixturesDir =
 170   unsafePerformIO $
 171     canonicalizePath ("tests" </> "fixtures")
 172 {-# NOINLINE fixturesDir #-}
 173
 174 ------------------------------------------------
 175 -- Round trip: conversion to/from legacy types
 176 --
 177
 178 roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property
 179 roundtrip f f_inv x =
 180   counterexample (show y) $
 181     x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr
 182   where
 183     y = f x
 184
 185 roundtrip_legacytypes :: ProjectConfig -> Property
 186 roundtrip_legacytypes =
 187   roundtrip
 188     convertToLegacyProjectConfig
 189     convertLegacyProjectConfig
 190
 191 prop_roundtrip_legacytypes_all :: ProjectConfig -> Property
 192 prop_roundtrip_legacytypes_all config =
 193   roundtrip_legacytypes
 194     config
 195       { projectConfigProvenance = mempty
 196       }
 197
 198 prop_roundtrip_legacytypes_packages :: ProjectConfig -> Property
 199 prop_roundtrip_legacytypes_packages config =
 200   roundtrip_legacytypes
 201     config
 202       { projectConfigBuildOnly = mempty
 203       , projectConfigShared = mempty
 204       , projectConfigProvenance = mempty
 205       , projectConfigLocalPackages = mempty
 206       , projectConfigSpecificPackage = mempty
 207       }
 208
 209 prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Property
 210 prop_roundtrip_legacytypes_buildonly config =
 211   roundtrip_legacytypes
 212     mempty{projectConfigBuildOnly = config}
 213
 214 prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Property
 215 prop_roundtrip_legacytypes_shared config =
 216   roundtrip_legacytypes
 217     mempty{projectConfigShared = config}
 218
 219 prop_roundtrip_legacytypes_local :: PackageConfig -> Property
 220 prop_roundtrip_legacytypes_local config =
 221   roundtrip_legacytypes
 222     mempty{projectConfigLocalPackages = config}
 223
 224 prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Property
 225 prop_roundtrip_legacytypes_specific config =
 226   roundtrip_legacytypes
 227     mempty{projectConfigSpecificPackage = MapMappend config}
 228
 229 --------------------------------------------
 230 -- Round trip: printing and parsing config
 231 --
 232
 233 roundtrip_printparse :: ProjectConfig -> Property
 234 roundtrip_printparse config =
 235   case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of
 236     ParseOk _ x ->
 237       counterexample ("shown:\n" ++ str) $
 238         x `ediffEq` config{projectConfigProvenance = mempty}
 239     ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False
 240   where
 241     str :: String
 242     str = showLegacyProjectConfig (convertToLegacyProjectConfig config)
 243
 244 prop_roundtrip_printparse_all :: ProjectConfig -> Property
 245 prop_roundtrip_printparse_all config =
 246   roundtrip_printparse
 247     config
 248       { projectConfigBuildOnly =
 249           hackProjectConfigBuildOnly (projectConfigBuildOnly config)
 250       , projectConfigShared =
 251           hackProjectConfigShared (projectConfigShared config)
 252       }
 253
 254 prop_roundtrip_printparse_packages
 255   :: [PackageLocationString]
 256   -> [PackageLocationString]
 257   -> [SourceRepoList]
 258   -> [PackageVersionConstraint]
 259   -> Property
 260 prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =
 261   roundtrip_printparse
 262     mempty
 263       { projectPackages = map getPackageLocationString pkglocstrs1
 264       , projectPackagesOptional = map getPackageLocationString pkglocstrs2
 265       , projectPackagesRepo = repos
 266       , projectPackagesNamed = named
 267       }
 268
 269 prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Property
 270 prop_roundtrip_printparse_buildonly config =
 271   roundtrip_printparse
 272     mempty
 273       { projectConfigBuildOnly = hackProjectConfigBuildOnly config
 274       }
 275
 276 hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly
 277 hackProjectConfigBuildOnly config =
 278   config
 279     { -- These fields are only command line transitory things, not
 280       -- something to be recorded persistently in a config file
 281       projectConfigOnlyDeps = mempty
 282     , projectConfigOnlyDownload = mempty
 283     , projectConfigDryRun = mempty
 284     }
 285
 286 prop_roundtrip_printparse_shared :: ProjectConfigShared -> Property
 287 prop_roundtrip_printparse_shared config =
 288   roundtrip_printparse
 289     mempty
 290       { projectConfigShared = hackProjectConfigShared config
 291       }
 292
 293 hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared
 294 hackProjectConfigShared config =
 295   config
 296     { projectConfigProjectFile = mempty -- not present within project files
 297     , projectConfigProjectDir = mempty -- ditto
 298     , projectConfigConfigFile = mempty -- ditto
 299     , projectConfigConstraints =
 300         -- TODO: [required eventually] parse ambiguity in constraint
 301         -- "pkgname -any" as either any version or disabled flag "any".
 302         let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) =
 303               (not . null)
 304                 [ () | (name, False) <- unFlagAssignment flags, "any" `isPrefixOf` unFlagName name
 305                 ]
 306             ambiguous _ = False
 307          in filter (not . ambiguous) (projectConfigConstraints config)
 308     }
 309
 310 prop_roundtrip_printparse_local :: PackageConfig -> Property
 311 prop_roundtrip_printparse_local config =
 312   roundtrip_printparse
 313     mempty
 314       { projectConfigLocalPackages = config
 315       }
 316
 317 prop_roundtrip_printparse_specific
 318   :: Map PackageName (NonMEmpty PackageConfig)
 319   -> Property
 320 prop_roundtrip_printparse_specific config =
 321   roundtrip_printparse
 322     mempty
 323       { projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)
 324       }
 325
 326 ----------------------------
 327 -- Individual Parser tests
 328 --
 329
 330 -- | Helper to parse a given string
 331 --
 332 -- Succeeds only if there is a unique complete parse
 333 runReadP :: Parse.ReadP a a -> String -> Maybe a
 334 runReadP parser s = case [x | (x, "") <- Parse.readP_to_S parser s] of
 335   [x'] -> Just x'
 336   _ -> Nothing
 337
 338 prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool
 339 prop_parsePackageLocationTokenQ (PackageLocationString str) =
 340   runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str
 341
 342 prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Property
 343 prop_roundtrip_printparse_RelaxedDep rdep =
 344   counterexample (prettyShow rdep) $
 345     eitherParsec (prettyShow rdep) == Right rdep
 346
 347 prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Property
 348 prop_roundtrip_printparse_RelaxDeps rdep =
 349   counterexample (prettyShow rdep) $
 350     Right rdep `ediffEq` eitherParsec (prettyShow rdep)
 351
 352 prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property
 353 prop_roundtrip_printparse_RelaxDeps' rdep =
 354   counterexample rdep' $
 355     Right rdep `ediffEq` eitherParsec rdep'
 356   where
 357     rdep' = go (prettyShow rdep)
 358
 359     -- replace 'all' tokens by '*'
 360     go :: String -> String
 361     go [] = []
 362     go "all" = "*"
 363     go ('a' : 'l' : 'l' : c : rest) | c `elem` ":," = '*' : go (c : rest)
 364     go rest =
 365       let (x, y) = break (`elem` ":,") rest
 366           (x', y') = span (`elem` ":,^") y
 367        in x ++ x' ++ go y'
 368
 369 ------------------------
 370 -- Arbitrary instances
 371 --
 372
 373 instance Arbitrary ProjectConfig where
 374   arbitrary =
 375     ProjectConfig
 376       <$> (map getPackageLocationString <$> arbitrary)
 377       <*> (map getPackageLocationString <$> arbitrary)
 378       <*> shortListOf 3 arbitrary
 379       <*> arbitrary
 380       <*> arbitrary
 381       <*> arbitrary
 382       <*> arbitrary
 383       <*> arbitrary
 384       <*> arbitrary
 385       <*> ( MapMappend . fmap getNonMEmpty . Map.fromList
 386               <$> shortListOf 3 arbitrary
 387           )
 388
 389   -- package entries with no content are equivalent to
 390   -- the entry not existing at all, so exclude empty
 391
 392   shrink
 393     ProjectConfig
 394       { projectPackages = x0
 395       , projectPackagesOptional = x1
 396       , projectPackagesRepo = x2
 397       , projectPackagesNamed = x3
 398       , projectConfigBuildOnly = x4
 399       , projectConfigShared = x5
 400       , projectConfigProvenance = x6
 401       , projectConfigLocalPackages = x7
 402       , projectConfigSpecificPackage = x8
 403       , projectConfigAllPackages = x9
 404       } =
 405       [ ProjectConfig
 406         { projectPackages = x0'
 407         , projectPackagesOptional = x1'
 408         , projectPackagesRepo = x2'
 409         , projectPackagesNamed = x3'
 410         , projectConfigBuildOnly = x4'
 411         , projectConfigShared = x5'
 412         , projectConfigProvenance = x6'
 413         , projectConfigLocalPackages = x7'
 414         , projectConfigSpecificPackage =
 415             ( MapMappend
 416                 (fmap getNonMEmpty x8')
 417             )
 418         , projectConfigAllPackages = x9'
 419         }
 420       | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <-
 421           shrink
 422             ( (x0, x1, x2, x3)
 423             , (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9)
 424             )
 425       ]
 426
 427 newtype PackageLocationString = PackageLocationString {getPackageLocationString :: String}
 428   deriving (Show)
 429
 430 instance Arbitrary PackageLocationString where
 431   arbitrary =
 432     PackageLocationString
 433       <$> oneof
 434         [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))
 435         , arbitraryGlobLikeStr
 436         , show <$> (arbitrary :: Gen URI)
 437         ]
 438         `suchThat` (\xs -> not ("{" `isPrefixOf` xs))
 439
 440 arbitraryGlobLikeStr :: Gen String
 441 arbitraryGlobLikeStr = outerTerm
 442   where
 443     outerTerm =
 444       concat
 445         <$> shortListOf1
 446           4
 447           ( frequency
 448               [ (2, token)
 449               , (1, braces <$> innerTerm)
 450               ]
 451           )
 452     innerTerm =
 453       intercalate ","
 454         <$> shortListOf1
 455           3
 456           ( frequency
 457               [ (3, token)
 458               , (1, braces <$> innerTerm)
 459               ]
 460           )
 461     token = shortListOf1 4 (elements (['#' .. '~'] \\ "{,}"))
 462     braces s = "{" ++ s ++ "}"
 463
 464 instance Arbitrary ClientInstallFlags where
 465   arbitrary =
 466     ClientInstallFlags
 467       <$> arbitrary
 468       <*> arbitraryFlag arbitraryShortToken
 469       <*> arbitrary
 470       <*> arbitrary
 471       <*> arbitraryFlag arbitraryShortToken
 472
 473 instance Arbitrary ProjectConfigBuildOnly where
 474   arbitrary =
 475     ProjectConfigBuildOnly
 476       <$> arbitrary
 477       <*> arbitrary
 478       <*> arbitrary
 479       <*> arbitrary
 480       <*> (toNubList <$> shortListOf 2 arbitrary)
 481       <*> arbitrary
 482       <*> arbitrary
 483       <*> arbitrary
 484       <*> (fmap getShortToken <$> arbitrary)
 485       <*> arbitraryNumJobs
 486       <*> arbitrary
 487       <*> arbitrary
 488       <*> arbitrary
 489       <*> arbitrary
 490       <*> (fmap getShortToken <$> arbitrary)
 491       <*> arbitrary
 492       <*> (fmap getShortToken <$> arbitrary)
 493       <*> (fmap getShortToken <$> arbitrary)
 494       <*> arbitrary
 495     where
 496       arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary
 497
 498   shrink
 499     ProjectConfigBuildOnly
 500       { projectConfigVerbosity = x00
 501       , projectConfigDryRun = x01
 502       , projectConfigOnlyDeps = x02
 503       , projectConfigOnlyDownload = x18
 504       , projectConfigSummaryFile = x03
 505       , projectConfigLogFile = x04
 506       , projectConfigBuildReports = x05
 507       , projectConfigReportPlanningFailure = x06
 508       , projectConfigSymlinkBinDir = x07
 509       , projectConfigNumJobs = x09
 510       , projectConfigUseSemaphore = x19
 511       , projectConfigKeepGoing = x10
 512       , projectConfigOfflineMode = x11
 513       , projectConfigKeepTempFiles = x12
 514       , projectConfigHttpTransport = x13
 515       , projectConfigIgnoreExpiry = x14
 516       , projectConfigCacheDir = x15
 517       , projectConfigLogsDir = x16
 518       , projectConfigClientInstallFlags = x17
 519       } =
 520       [ ProjectConfigBuildOnly
 521         { projectConfigVerbosity = x00'
 522         , projectConfigDryRun = x01'
 523         , projectConfigOnlyDeps = x02'
 524         , projectConfigOnlyDownload = x18'
 525         , projectConfigSummaryFile = x03'
 526         , projectConfigLogFile = x04'
 527         , projectConfigBuildReports = x05'
 528         , projectConfigReportPlanningFailure = x06'
 529         , projectConfigSymlinkBinDir = x07'
 530         , projectConfigNumJobs = postShrink_NumJobs x09'
 531         , projectConfigUseSemaphore = x19'
 532         , projectConfigKeepGoing = x10'
 533         , projectConfigOfflineMode = x11'
 534         , projectConfigKeepTempFiles = x12'
 535         , projectConfigHttpTransport = x13
 536         , projectConfigIgnoreExpiry = x14'
 537         , projectConfigCacheDir = x15
 538         , projectConfigLogsDir = x16
 539         , projectConfigClientInstallFlags = x17'
 540         }
 541       | ( (x00', x01', x02', x03', x04')
 542           , (x05', x06', x07', x09')
 543           , (x10', x11', x12', x14')
 544           , (x17', x18', x19')
 545           ) <-
 546           shrink
 547             ( (x00, x01, x02, x03, x04)
 548             , (x05, x06, x07, preShrink_NumJobs x09)
 549             , (x10, x11, x12, x14)
 550             , (x17, x18, x19)
 551             )
 552       ]
 553       where
 554         preShrink_NumJobs = fmap (fmap Positive)
 555         postShrink_NumJobs = fmap (fmap getPositive)
 556
 557 instance Arbitrary ProjectConfigShared where
 558   arbitrary = do
 559     projectConfigDistDir <- arbitraryFlag arbitraryShortToken
 560     projectConfigConfigFile <- arbitraryFlag arbitraryShortToken
 561     projectConfigProjectDir <- arbitraryFlag arbitraryShortToken
 562     projectConfigProjectFile <- arbitraryFlag arbitraryShortToken
 563     projectConfigIgnoreProject <- arbitrary
 564     projectConfigHcFlavor <- arbitrary
 565     projectConfigHcPath <- arbitraryFlag arbitraryShortToken
 566     projectConfigHcPkg <- arbitraryFlag arbitraryShortToken
 567     projectConfigHaddockIndex <- arbitrary
 568     projectConfigInstallDirs <- fixInstallDirs <$> arbitrary
 569     projectConfigPackageDBs <- shortListOf 2 arbitrary
 570     projectConfigRemoteRepos <- arbitrary
 571     projectConfigLocalNoIndexRepos <- arbitrary
 572     projectConfigActiveRepos <- arbitrary
 573     projectConfigIndexState <- arbitrary
 574     projectConfigStoreDir <- arbitraryFlag arbitraryShortToken
 575     projectConfigConstraints <- arbitraryConstraints
 576     projectConfigPreferences <- shortListOf 2 arbitrary
 577     projectConfigCabalVersion <- arbitrary
 578     projectConfigSolver <- arbitrary
 579     projectConfigAllowOlder <- arbitrary
 580     projectConfigAllowNewer <- arbitrary
 581     projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary
 582     projectConfigMaxBackjumps <- arbitrary
 583     projectConfigReorderGoals <- arbitrary
 584     projectConfigCountConflicts <- arbitrary
 585     projectConfigFineGrainedConflicts <- arbitrary
 586     projectConfigMinimizeConflictSet <- arbitrary
 587     projectConfigStrongFlags <- arbitrary
 588     projectConfigAllowBootLibInstalls <- arbitrary
 589     projectConfigOnlyConstrained <- arbitrary
 590     projectConfigPerComponent <- arbitrary
 591     projectConfigIndependentGoals <- arbitrary
 592     projectConfigPreferOldest <- arbitrary
 593     projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken
 594     projectConfigMultiRepl <- arbitrary
 595     return ProjectConfigShared{..}
 596     where
 597       arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]
 598       arbitraryConstraints =
 599         fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary
 600       fixInstallDirs x = x{InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty}
 601
 602   shrink ProjectConfigShared{..} =
 603     runShrinker $
 604       pure ProjectConfigShared
 605         <*> shrinker projectConfigDistDir
 606         <*> shrinker projectConfigConfigFile
 607         <*> shrinker projectConfigProjectDir
 608         <*> shrinker projectConfigProjectFile
 609         <*> shrinker projectConfigIgnoreProject
 610         <*> shrinker projectConfigHcFlavor
 611         <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath
 612         <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg
 613         <*> shrinker projectConfigHaddockIndex
 614         <*> shrinker projectConfigInstallDirs
 615         <*> shrinker projectConfigPackageDBs
 616         <*> shrinker projectConfigRemoteRepos
 617         <*> shrinker projectConfigLocalNoIndexRepos
 618         <*> shrinker projectConfigActiveRepos
 619         <*> shrinker projectConfigIndexState
 620         <*> shrinker projectConfigStoreDir
 621         <*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints
 622         <*> shrinker projectConfigPreferences
 623         <*> shrinker projectConfigCabalVersion
 624         <*> shrinker projectConfigSolver
 625         <*> shrinker projectConfigAllowOlder
 626         <*> shrinker projectConfigAllowNewer
 627         <*> shrinker projectConfigWriteGhcEnvironmentFilesPolicy
 628         <*> shrinker projectConfigMaxBackjumps
 629         <*> shrinker projectConfigReorderGoals
 630         <*> shrinker projectConfigCountConflicts
 631         <*> shrinker projectConfigFineGrainedConflicts
 632         <*> shrinker projectConfigMinimizeConflictSet
 633         <*> shrinker projectConfigStrongFlags
 634         <*> shrinker projectConfigAllowBootLibInstalls
 635         <*> shrinker projectConfigOnlyConstrained
 636         <*> shrinker projectConfigPerComponent
 637         <*> shrinker projectConfigIndependentGoals
 638         <*> shrinker projectConfigPreferOldest
 639         <*> shrinker projectConfigProgPathExtra
 640         <*> shrinker projectConfigMultiRepl
 641     where
 642       preShrink_Constraints = map fst
 643       postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))
 644
 645 projectConfigConstraintSource :: ConstraintSource
 646 projectConfigConstraintSource = ConstraintSourceProjectConfig nullProjectConfigPath
 647
 648 instance Arbitrary ProjectConfigProvenance where
 649   arbitrary = elements [Implicit, Explicit (ProjectConfigPath $ "cabal.project" :| [])]
 650
 651 instance Arbitrary PackageConfig where
 652   arbitrary =
 653     PackageConfig
 654       <$> ( MapLast . Map.fromList
 655               <$> shortListOf
 656                 10
 657                 ( (,)
 658                     <$> arbitraryProgramName
 659                     <*> arbitraryShortToken
 660                 )
 661           )
 662       <*> ( MapMappend . Map.fromList
 663               <$> shortListOf
 664                 10
 665                 ( (,)
 666                     <$> arbitraryProgramName
 667                     <*> listOf arbitraryShortToken
 668                 )
 669           )
 670       <*> (toNubList <$> listOf arbitraryShortToken)
 671       <*> arbitrary
 672       <*> arbitrary
 673       <*> arbitrary
 674       <*> arbitrary
 675       <*> arbitrary
 676       <*> arbitrary
 677       <*> arbitrary
 678       <*> arbitrary
 679       <*> arbitrary
 680       <*> arbitrary
 681       <*> arbitrary
 682       <*> arbitrary
 683       <*> shortListOf 5 arbitraryShortToken
 684       <*> arbitrary
 685       <*> arbitrary
 686       <*> arbitrary
 687       <*> shortListOf 5 arbitraryShortToken
 688       <*> shortListOf 5 arbitraryShortToken
 689       <*> shortListOf 5 arbitraryShortToken
 690       <*> shortListOf 5 arbitraryShortToken
 691       <*> arbitrary
 692       <*> arbitrary
 693       <*> arbitrary
 694       <*> arbitrary
 695       <*> arbitrary
 696       <*> arbitrary
 697       <*> arbitrary
 698       <*> arbitrary
 699       <*> arbitrary
 700       <*> arbitrary
 701       <*> arbitrary
 702       <*> arbitrary
 703       <*> arbitrary
 704       <*> arbitrary
 705       <*> arbitrary
 706       <*> arbitraryFlag arbitraryShortToken
 707       <*> arbitrary
 708       <*> arbitrary
 709       <*> arbitrary
 710       <*> arbitrary
 711       <*> arbitrary
 712       <*> arbitraryFlag arbitraryShortToken
 713       <*> arbitrary
 714       <*> arbitrary
 715       <*> arbitraryFlag arbitraryShortToken
 716       <*> arbitrary
 717       <*> arbitrary
 718       <*> arbitraryFlag arbitraryShortToken
 719       <*> arbitraryFlag arbitraryShortToken
 720       <*> arbitraryFlag arbitraryShortToken
 721       <*> arbitrary
 722       <*> arbitrary
 723       <*> arbitrary
 724       <*> arbitrary
 725       <*> arbitrary
 726       <*> arbitrary
 727       <*> arbitraryFlag arbitraryShortToken
 728       <*> arbitrary
 729       <*> shortListOf 5 arbitrary
 730       <*> shortListOf 5 arbitrary
 731     where
 732       arbitraryProgramName :: Gen String
 733       arbitraryProgramName =
 734         elements
 735           [ programName prog
 736           | (prog, _) <- knownPrograms (defaultProgramDb)
 737           ]
 738
 739   shrink
 740     PackageConfig
 741       { packageConfigProgramPaths = x00
 742       , packageConfigProgramArgs = x01
 743       , packageConfigProgramPathExtra = x02
 744       , packageConfigFlagAssignment = x03
 745       , packageConfigVanillaLib = x04
 746       , packageConfigSharedLib = x05
 747       , packageConfigStaticLib = x42
 748       , packageConfigDynExe = x06
 749       , packageConfigFullyStaticExe = x50
 750       , packageConfigProf = x07
 751       , packageConfigProfLib = x08
 752       , packageConfigProfShared = x08_1
 753       , packageConfigProfExe = x09
 754       , packageConfigProfDetail = x10
 755       , packageConfigProfLibDetail = x11
 756       , packageConfigConfigureArgs = x12
 757       , packageConfigOptimization = x13
 758       , packageConfigProgPrefix = x14
 759       , packageConfigProgSuffix = x15
 760       , packageConfigExtraLibDirs = x16
 761       , packageConfigExtraLibDirsStatic = x53
 762       , packageConfigExtraFrameworkDirs = x17
 763       , packageConfigExtraIncludeDirs = x18
 764       , packageConfigGHCiLib = x19
 765       , packageConfigSplitSections = x20
 766       , packageConfigSplitObjs = x20_1
 767       , packageConfigStripExes = x21
 768       , packageConfigStripLibs = x22
 769       , packageConfigTests = x23
 770       , packageConfigBenchmarks = x24
 771       , packageConfigCoverage = x25
 772       , packageConfigRelocatable = x26
 773       , packageConfigDebugInfo = x27
 774       , packageConfigDumpBuildInfo = x27_1
 775       , packageConfigRunTests = x28
 776       , packageConfigDocumentation = x29
 777       , packageConfigHaddockHoogle = x30
 778       , packageConfigHaddockHtml = x31
 779       , packageConfigHaddockHtmlLocation = x32
 780       , packageConfigHaddockForeignLibs = x33
 781       , packageConfigHaddockExecutables = x33_1
 782       , packageConfigHaddockTestSuites = x34
 783       , packageConfigHaddockBenchmarks = x35
 784       , packageConfigHaddockInternal = x36
 785       , packageConfigHaddockCss = x37
 786       , packageConfigHaddockLinkedSource = x38
 787       , packageConfigHaddockQuickJump = x43
 788       , packageConfigHaddockHscolourCss = x39
 789       , packageConfigHaddockContents = x40
 790       , packageConfigHaddockForHackage = x41
 791       , packageConfigHaddockIndex = x54
 792       , packageConfigHaddockBaseUrl = x55
 793       , packageConfigHaddockResourcesDir = x56
 794       , packageConfigHaddockOutputDir = x57
 795       , packageConfigHaddockUseUnicode = x58
 796       , packageConfigTestHumanLog = x44
 797       , packageConfigTestMachineLog = x45
 798       , packageConfigTestShowDetails = x46
 799       , packageConfigTestKeepTix = x47
 800       , packageConfigTestWrapper = x48
 801       , packageConfigTestFailWhenNoTestSuites = x49
 802       , packageConfigTestTestOptions = x51
 803       , packageConfigBenchmarkOptions = x52
 804       } =
 805       [ PackageConfig
 806         { packageConfigProgramPaths = postShrink_Paths x00'
 807         , packageConfigProgramArgs = postShrink_Args x01'
 808         , packageConfigProgramPathExtra = x02'
 809         , packageConfigFlagAssignment = x03'
 810         , packageConfigVanillaLib = x04'
 811         , packageConfigSharedLib = x05'
 812         , packageConfigStaticLib = x42'
 813         , packageConfigDynExe = x06'
 814         , packageConfigFullyStaticExe = x50'
 815         , packageConfigProf = x07'
 816         , packageConfigProfLib = x08'
 817         , packageConfigProfShared = x08_1'
 818         , packageConfigProfExe = x09'
 819         , packageConfigProfDetail = x10'
 820         , packageConfigProfLibDetail = x11'
 821         , packageConfigConfigureArgs = map getNonEmpty x12'
 822         , packageConfigOptimization = x13'
 823         , packageConfigProgPrefix = x14'
 824         , packageConfigProgSuffix = x15'
 825         , packageConfigExtraLibDirs = map getNonEmpty x16'
 826         , packageConfigExtraLibDirsStatic = map getNonEmpty x53'
 827         , packageConfigExtraFrameworkDirs = map getNonEmpty x17'
 828         , packageConfigExtraIncludeDirs = map getNonEmpty x18'
 829         , packageConfigGHCiLib = x19'
 830         , packageConfigSplitSections = x20'
 831         , packageConfigSplitObjs = x20_1'
 832         , packageConfigStripExes = x21'
 833         , packageConfigStripLibs = x22'
 834         , packageConfigTests = x23'
 835         , packageConfigBenchmarks = x24'
 836         , packageConfigCoverage = x25'
 837         , packageConfigRelocatable = x26'
 838         , packageConfigDebugInfo = x27'
 839         , packageConfigDumpBuildInfo = x27_1'
 840         , packageConfigRunTests = x28'
 841         , packageConfigDocumentation = x29'
 842         , packageConfigHaddockHoogle = x30'
 843         , packageConfigHaddockHtml = x31'
 844         , packageConfigHaddockHtmlLocation = x32'
 845         , packageConfigHaddockForeignLibs = x33'
 846         , packageConfigHaddockExecutables = x33_1'
 847         , packageConfigHaddockTestSuites = x34'
 848         , packageConfigHaddockBenchmarks = x35'
 849         , packageConfigHaddockInternal = x36'
 850         , packageConfigHaddockCss = fmap getNonEmpty x37'
 851         , packageConfigHaddockLinkedSource = x38'
 852         , packageConfigHaddockQuickJump = x43'
 853         , packageConfigHaddockHscolourCss = fmap getNonEmpty x39'
 854         , packageConfigHaddockContents = x40'
 855         , packageConfigHaddockForHackage = x41'
 856         , packageConfigHaddockIndex = x54'
 857         , packageConfigHaddockBaseUrl = x55'
 858         , packageConfigHaddockResourcesDir = x56'
 859         , packageConfigHaddockOutputDir = x57'
 860         , packageConfigHaddockUseUnicode = x58'
 861         , packageConfigTestHumanLog = x44'
 862         , packageConfigTestMachineLog = x45'
 863         , packageConfigTestShowDetails = x46'
 864         , packageConfigTestKeepTix = x47'
 865         , packageConfigTestWrapper = x48'
 866         , packageConfigTestFailWhenNoTestSuites = x49'
 867         , packageConfigTestTestOptions = x51'
 868         , packageConfigBenchmarkOptions = x52'
 869         }
 870       | ( ( (x00', x01', x02', x03', x04')
 871             , (x05', x42', x06', x50', x07', x08', x08_1', x09')
 872             , (x10', x11', x12', x13', x14')
 873             , (x15', x16', x53', x17', x18', x19')
 874             )
 875           , ( (x20', x20_1', x21', x22', x23', x24')
 876               , (x25', x26', x27', x27_1', x28', x29')
 877               , (x30', x31', x32', (x33', x33_1'), x34')
 878               , (x35', x36', x37', x38', x43', x39')
 879               , (x40', x41')
 880               , (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55')
 881               , x56'
 882               , x57'
 883               , x58'
 884               )
 885           ) <-
 886           shrink
 887             (
 888               ( (preShrink_Paths x00, preShrink_Args x01, x02, x03, x04)
 889               , (x05, x42, x06, x50, x07, x08, x08_1, x09)
 890               , (x10, x11, map NonEmpty x12, x13, x14)
 891               ,
 892                 ( x15
 893                 , map NonEmpty x16
 894                 , map NonEmpty x53
 895                 , map NonEmpty x17
 896                 , map NonEmpty x18
 897                 , x19
 898                 )
 899               )
 900             ,
 901               ( (x20, x20_1, x21, x22, x23, x24)
 902               , (x25, x26, x27, x27_1, x28, x29)
 903               , (x30, x31, x32, (x33, x33_1), x34)
 904               , (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39)
 905               , (x40, x41)
 906               , (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55)
 907               , x56
 908               , x57
 909               , x58
 910               )
 911             )
 912       ]
 913       where
 914         preShrink_Paths =
 915           Map.map NonEmpty
 916             . Map.mapKeys NoShrink
 917             . getMapLast
 918         postShrink_Paths =
 919           MapLast
 920             . Map.map getNonEmpty
 921             . Map.mapKeys getNoShrink
 922         preShrink_Args =
 923           Map.map (NonEmpty . map NonEmpty)
 924             . Map.mapKeys NoShrink
 925             . getMapMappend
 926         postShrink_Args =
 927           MapMappend
 928             . Map.map (map getNonEmpty . getNonEmpty)
 929             . Map.mapKeys getNoShrink
 930
 931 instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where
 932   arbitrary =
 933     SourceRepositoryPackage
 934       <$> arbitrary
 935       <*> (getShortToken <$> arbitrary)
 936       <*> (fmap getShortToken <$> arbitrary)
 937       <*> (fmap getShortToken <$> arbitrary)
 938       <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
 939       <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
 940
 941   shrink SourceRepositoryPackage{..} =
 942     runShrinker $
 943       pure SourceRepositoryPackage
 944         <*> shrinker srpType
 945         <*> shrinkerAla ShortToken srpLocation
 946         <*> shrinkerAla (fmap ShortToken) srpTag
 947         <*> shrinkerAla (fmap ShortToken) srpBranch
 948         <*> shrinkerAla (fmap ShortToken) srpSubdir
 949         <*> shrinkerAla (fmap ShortToken) srpCommand
 950
 951 instance Arbitrary RemoteRepo where
 952   arbitrary =
 953     RemoteRepo
 954       <$> arbitrary
 955       <*> arbitrary -- URI
 956       <*> arbitrary
 957       <*> listOf arbitraryRootKey
 958       <*> fmap getNonNegative arbitrary
 959       <*> pure False
 960     where
 961       arbitraryRootKey =
 962         shortListOf1
 963           5
 964           ( oneof
 965               [ choose ('0', '9')
 966               , choose ('a', 'f')
 967               ]
 968           )
 969
 970 instance Arbitrary LocalRepo where
 971   arbitrary =
 972     LocalRepo
 973       <$> arbitrary
 974       <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths
 975       <*> arbitrary
 976
 977 instance Arbitrary PreSolver where
 978   arbitrary = elements [minBound .. maxBound]
 979
 980 instance Arbitrary ReorderGoals where
 981   arbitrary = ReorderGoals <$> arbitrary
 982
 983 instance Arbitrary CountConflicts where
 984   arbitrary = CountConflicts <$> arbitrary
 985
 986 instance Arbitrary FineGrainedConflicts where
 987   arbitrary = FineGrainedConflicts <$> arbitrary
 988
 989 instance Arbitrary MinimizeConflictSet where
 990   arbitrary = MinimizeConflictSet <$> arbitrary
 991
 992 instance Arbitrary IndependentGoals where
 993   arbitrary = IndependentGoals <$> arbitrary
 994
 995 instance Arbitrary PreferOldest where
 996   arbitrary = PreferOldest <$> arbitrary
 997
 998 instance Arbitrary StrongFlags where
 999   arbitrary = StrongFlags <$> arbitrary
1000
1001 instance Arbitrary AllowBootLibInstalls where
1002   arbitrary = AllowBootLibInstalls <$> arbitrary
1003
1004 instance Arbitrary OnlyConstrained where
1005   arbitrary =
1006     oneof
1007       [ pure OnlyConstrainedAll
1008       , pure OnlyConstrainedNone
1009       ]