Skip to content

Commit 5f80646

Browse files
phadejphadej
authored
Merge pull request #6759 from phadej/shrinker
Add shrinker, so writing big non-generic product shrinkers is easier
2 parents a6aa0bb + 5a88e98 commit 5f80646

File tree

2 files changed

+66
-72
lines changed

2 files changed

+66
-72
lines changed

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

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,12 @@ module UnitTests.Distribution.Client.ArbitraryInstances (
99
arbitraryShortToken,
1010
NonMEmpty(..),
1111
NoShrink(..),
12+
-- * Shrinker
13+
Shrinker,
14+
runShrinker,
15+
shrinker,
16+
shrinkerPP,
17+
shrinkerAla,
1218
) where
1319

1420
import Distribution.Client.Compat.Prelude
@@ -31,11 +37,39 @@ import Distribution.Client.Types (RepoName (..), WriteGh
3137
import Test.QuickCheck
3238
import Test.QuickCheck.Instances.Cabal ()
3339

40+
import Data.Coerce (Coercible, coerce)
3441
import Network.URI (URI (..), URIAuth (..), isUnreserved)
3542

3643
-- note: there are plenty of instances defined in ProjectConfig test file.
3744
-- they should be moved here or into Cabal-quickcheck
3845

46+
-------------------------------------------------------------------------------
47+
-- Utilities
48+
-------------------------------------------------------------------------------
49+
50+
data Shrinker a = Shrinker a [a]
51+
52+
instance Functor Shrinker where
53+
fmap f (Shrinker x xs) = Shrinker (f x) (map f xs)
54+
55+
instance Applicative Shrinker where
56+
pure x = Shrinker x []
57+
58+
Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs)
59+
60+
runShrinker :: Shrinker a -> [a]
61+
runShrinker (Shrinker _ xs) = xs
62+
63+
shrinker :: Arbitrary a => a -> Shrinker a
64+
shrinker x = Shrinker x (shrink x)
65+
66+
shrinkerAla :: (Coercible a b, Arbitrary b) => (a -> b) -> a -> Shrinker a
67+
shrinkerAla pack = shrinkerPP pack coerce
68+
69+
-- | shrinker with pre and post functions.
70+
shrinkerPP :: Arbitrary b => (a -> b) -> (b -> a) -> a -> Shrinker a
71+
shrinkerPP pack unpack x = Shrinker x (map unpack (shrink (pack x)))
72+
3973
-------------------------------------------------------------------------------
4074
-- Non-Cabal instances
4175
-------------------------------------------------------------------------------

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

Lines changed: 32 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE RecordWildCards #-}
34
{-# OPTIONS_GHC -fno-warn-orphans #-}
45

56
module UnitTests.Distribution.Client.ProjectConfig (tests) where
@@ -470,78 +471,37 @@ instance Arbitrary ProjectConfigShared where
470471
arbitraryConstraints =
471472
fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary
472473

473-
shrink ProjectConfigShared { projectConfigDistDir = x00
474-
, projectConfigProjectFile = x01
475-
, projectConfigHcFlavor = x02
476-
, projectConfigHcPath = x03
477-
, projectConfigHcPkg = x04
478-
, projectConfigHaddockIndex = x05
479-
, projectConfigRemoteRepos = x06
480-
, projectConfigLocalRepos = x07
481-
, projectConfigLocalNoIndexRepos = x07b
482-
, projectConfigIndexState = x08
483-
, projectConfigConstraints = x09
484-
, projectConfigPreferences = x10
485-
, projectConfigCabalVersion = x11
486-
, projectConfigSolver = x12
487-
, projectConfigAllowOlder = x13
488-
, projectConfigAllowNewer = x14
489-
, projectConfigWriteGhcEnvironmentFilesPolicy = x15
490-
, projectConfigMaxBackjumps = x16
491-
, projectConfigReorderGoals = x17
492-
, projectConfigCountConflicts = x18
493-
, projectConfigFineGrainedConflicts = x19
494-
, projectConfigMinimizeConflictSet = x20
495-
, projectConfigStrongFlags = x21
496-
, projectConfigAllowBootLibInstalls = x22
497-
, projectConfigOnlyConstrained = x23
498-
, projectConfigPerComponent = x24
499-
, projectConfigIndependentGoals = x25
500-
, projectConfigConfigFile = x26
501-
, projectConfigProgPathExtra = x27
502-
, projectConfigStoreDir = x28 } =
503-
[ ProjectConfigShared { projectConfigDistDir = x00'
504-
, projectConfigProjectFile = x01'
505-
, projectConfigHcFlavor = x02'
506-
, projectConfigHcPath = fmap getNonEmpty x03'
507-
, projectConfigHcPkg = fmap getNonEmpty x04'
508-
, projectConfigHaddockIndex = x05'
509-
, projectConfigRemoteRepos = x06'
510-
, projectConfigLocalRepos = x07'
511-
, projectConfigLocalNoIndexRepos = x07b'
512-
, projectConfigIndexState = x08'
513-
, projectConfigConstraints = postShrink_Constraints x09'
514-
, projectConfigPreferences = x10'
515-
, projectConfigCabalVersion = x11'
516-
, projectConfigSolver = x12'
517-
, projectConfigAllowOlder = x13'
518-
, projectConfigAllowNewer = x14'
519-
, projectConfigWriteGhcEnvironmentFilesPolicy = x15'
520-
, projectConfigMaxBackjumps = x16'
521-
, projectConfigReorderGoals = x17'
522-
, projectConfigCountConflicts = x18'
523-
, projectConfigFineGrainedConflicts = x19'
524-
, projectConfigMinimizeConflictSet = x20'
525-
, projectConfigStrongFlags = x21'
526-
, projectConfigAllowBootLibInstalls = x22'
527-
, projectConfigOnlyConstrained = x23'
528-
, projectConfigPerComponent = x24'
529-
, projectConfigIndependentGoals = x25'
530-
, projectConfigConfigFile = x26'
531-
, projectConfigProgPathExtra = x27'
532-
, projectConfigStoreDir = x28' }
533-
| ((x00', x01', x02', x03', x04', x05'),
534-
(x06', x07', x07b', x08', x09', x10'),
535-
(x11', x12', x13', x14', x15', x16'),
536-
(x17', x18', x19', x20', x21', x22'),
537-
x23', x24', x25', x26', x27', x28')
538-
<- shrink
539-
((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04, x05),
540-
(x06, x07, x07b, x08, preShrink_Constraints x09, x10),
541-
(x11, x12, x13, x14, x15, x16),
542-
(x17, x18, x19, x20, x21, x22),
543-
x23, x24, x25, x26, x27, x28)
544-
]
474+
shrink ProjectConfigShared {..} = runShrinker $ pure ProjectConfigShared
475+
<*> shrinker projectConfigDistDir
476+
<*> shrinker projectConfigConfigFile
477+
<*> shrinker projectConfigProjectFile
478+
<*> shrinker projectConfigHcFlavor
479+
<*> shrinkerAla (fmap NonEmpty) projectConfigHcPath
480+
<*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg
481+
<*> shrinker projectConfigHaddockIndex
482+
<*> shrinker projectConfigRemoteRepos
483+
<*> shrinker projectConfigLocalRepos
484+
<*> shrinker projectConfigLocalNoIndexRepos
485+
<*> shrinker projectConfigIndexState
486+
<*> shrinker projectConfigStoreDir
487+
<*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints
488+
<*> shrinker projectConfigPreferences
489+
<*> shrinker projectConfigCabalVersion
490+
<*> shrinker projectConfigSolver
491+
<*> shrinker projectConfigAllowOlder
492+
<*> shrinker projectConfigAllowNewer
493+
<*> shrinker projectConfigWriteGhcEnvironmentFilesPolicy
494+
<*> shrinker projectConfigMaxBackjumps
495+
<*> shrinker projectConfigReorderGoals
496+
<*> shrinker projectConfigCountConflicts
497+
<*> shrinker projectConfigFineGrainedConflicts
498+
<*> shrinker projectConfigMinimizeConflictSet
499+
<*> shrinker projectConfigStrongFlags
500+
<*> shrinker projectConfigAllowBootLibInstalls
501+
<*> shrinker projectConfigOnlyConstrained
502+
<*> shrinker projectConfigPerComponent
503+
<*> shrinker projectConfigIndependentGoals
504+
<*> shrinker projectConfigProgPathExtra
545505
where
546506
preShrink_Constraints = map fst
547507
postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))

0 commit comments

Comments
 (0)