Skip to content

Commit

Permalink
VCS tests: Make smaller Arbitrary repositories
Browse files Browse the repository at this point in the history
The `Arbitrary` repo recipes can get quite large due to nesting:

- `RepoRecipes` contain a number of groups (`TaggedCommits` or `BranchCommits`).
- Groups contain a number of `Commit`s.
- Commits contain a number of operations (`FileUpdate` or `SubmoduleAdd`).

There's also another wrinkle in that `SubmoduleAdd`s contain a `Commit`
themselves, so square the `operationsPerCommit` number!

Then, a rough upper bound of the number of `git` calls required for an
arbitrary `RepoRecipe` is
`groupsPerRecipe * commitsPerGroup * operationsPerCommit^2`.

The original implementation of these instances, which chose
reasonable-sounding size parameters of 5-15, led to a maximum of 1875
operations per test case! No wonder they took so long!

In my tests, this change reduces the time of running the `long-tests`
suite from 429 seconds to 102 seconds (a 4.2x speedup).
  • Loading branch information
9999years authored and Mikolaj committed Nov 27, 2024
1 parent 3f9ce03 commit 351ebb2
Showing 1 changed file with 54 additions and 12 deletions.
66 changes: 54 additions & 12 deletions cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,12 @@ import UnitTests.Distribution.Client.ArbitraryInstances
tests :: MTimeChange -> [TestTree]
tests mtimeChange =
map
-- Are you tuning performance for these tests? The size of the arbitrary
-- instances involved is very significant, because each element generated
-- corresponds to one or more Git subcommands being run.
--
-- See [Tuning Arbitrary Instances] below for more information and
-- parameters.
(localOption $ QuickCheckTests 10)
[ ignoreInWindows "See issue #8048 and #9519" $
testGroup
Expand Down Expand Up @@ -472,6 +478,7 @@ instance Arbitrary PrngSeed where
-- VCS commands to make a repository on-disk.

data SubmodulesSupport = SubmodulesSupported | SubmodulesNotSupported
deriving (Show, Eq)

class KnownSubmodulesSupport (a :: SubmodulesSupport) where
submoduleSupport :: SubmodulesSupport
Expand All @@ -484,7 +491,11 @@ instance KnownSubmodulesSupport 'SubmodulesNotSupported where

data FileUpdate = FileUpdate FilePath String
deriving (Show)
data SubmoduleAdd = SubmoduleAdd FilePath FilePath (Commit 'SubmodulesSupported)
data SubmoduleAdd = SubmoduleAdd
{ submodulePath :: FilePath
, submoduleSource :: FilePath
, submoduleCommit :: Commit 'SubmodulesSupported
}
deriving (Show)

newtype Commit (submodules :: SubmodulesSupport)
Expand Down Expand Up @@ -525,40 +536,71 @@ data RepoRecipe submodules
genFileName :: Gen FilePath
genFileName = (\c -> "file" </> [c]) <$> choose ('A', 'E')

-- [Tuning Arbitrary Instances]
--
-- Arbitrary repo recipes can get quite large due to nesting:
--
-- - `RepoRecipes` contain a number of groups (`TaggedCommits` or `BranchCommits`).
-- - Groups contain a number of `Commit`s.
-- - Commits contain a number of operations (`FileUpdate` or `SubmoduleAdd`).
--
-- There's also another wrinkle in that `SubmoduleAdd`s contain a `Commit`
-- themselves, so square the `operationsPerCommit` number!
--
-- Then, a rough upper bound of the number of `git` calls required for an
-- arbitrary `RepoRecipe` is
-- `groupsPerRecipe * commitsPerGroup * operationsPerCommit^2`.
--
-- The original implementation of these instances, which chose
-- reasonable-sounding size parameters of 5-15, led to a maximum of 1875
-- operations per test case! No wonder they took so long!
--
-- In most cases, we only care about one or many operations, so "two" is a fine
-- stand-in for "many" :)
groupsPerRecipe :: Int
groupsPerRecipe = 3

commitsPerGroup :: Int
commitsPerGroup = 3

operationsPerCommit :: Int
operationsPerCommit = 3

instance Arbitrary FileUpdate where
arbitrary = genOnlyFileUpdate
arbitrary = FileUpdate <$> genFileName <*> genFileContent
where
genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent
genFileContent = vectorOf 10 (choose ('#', '~'))

instance Arbitrary SubmoduleAdd where
arbitrary = genOnlySubmoduleAdd
arbitrary = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary
where
genOnlySubmoduleAdd = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary
genSubmoduleSrc = vectorOf 20 (choose ('a', 'z'))

instance forall submodules. KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where
arbitrary = Commit <$> shortListOf1 5 fileUpdateOrSubmoduleAdd
arbitrary = Commit <$> shortListOf1 operationsPerCommit (sized fileUpdateOrSubmoduleAdd)
where
fileUpdateOrSubmoduleAdd =
fileUpdateOrSubmoduleAdd 0 = Left <$> arbitrary
fileUpdateOrSubmoduleAdd size =
case submoduleSupport @submodules of
SubmodulesSupported ->
frequency
[ (10, Left <$> arbitrary)
, (1, Right <$> arbitrary)
, -- A `SubmoduleAdd` contains a `Commit`, so we make sure to scale
-- down the size in the recursive call to avoid unbounded nesting.
(1, Right <$> resize (size `div` 2) arbitrary)
]
SubmodulesNotSupported -> Left <$> arbitrary
shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes)

instance KnownSubmodulesSupport submodules => Arbitrary (TaggedCommits submodules) where
arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary
arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 commitsPerGroup arbitrary
where
genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z'))
shrink (TaggedCommits tag commits) =
TaggedCommits tag <$> filter (not . null) (shrink commits)

instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodules) where
arbitrary = BranchCommits <$> genBranchName <*> shortListOf1 5 arbitrary
arbitrary = BranchCommits <$> genBranchName <*> shortListOf1 commitsPerGroup arbitrary
where
genBranchName =
sized $ \n ->
Expand All @@ -568,12 +610,12 @@ instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodule
BranchCommits branch <$> filter (not . null) (shrink commits)

instance KnownSubmodulesSupport submodules => Arbitrary (NonBranchingRepoRecipe submodules) where
arbitrary = NonBranchingRepoRecipe <$> shortListOf1 15 arbitrary
arbitrary = NonBranchingRepoRecipe <$> shortListOf1 groupsPerRecipe arbitrary
shrink (NonBranchingRepoRecipe xs) =
NonBranchingRepoRecipe <$> filter (not . null) (shrink xs)

instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe submodules) where
arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch
arbitrary = BranchingRepoRecipe <$> shortListOf1 groupsPerRecipe taggedOrBranch
where
taggedOrBranch =
frequency
Expand Down

0 comments on commit 351ebb2

Please sign in to comment.