From 5a88e98401d84ae5f3c5e1b72fbd024a65424efb Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 6 May 2020 16:40:35 +0300 Subject: [PATCH] Add shrinker, so writing big non-generic product shrinkers is easier --- .../Distribution/Client/ArbitraryInstances.hs | 34 ++++++ .../Distribution/Client/ProjectConfig.hs | 104 ++++++------------ 2 files changed, 66 insertions(+), 72 deletions(-) diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index e9e957073a8..85208528719 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -9,6 +9,12 @@ module UnitTests.Distribution.Client.ArbitraryInstances ( arbitraryShortToken, NonMEmpty(..), NoShrink(..), + -- * Shrinker + Shrinker, + runShrinker, + shrinker, + shrinkerPP, + shrinkerAla, ) where import Distribution.Client.Compat.Prelude @@ -31,11 +37,39 @@ import Distribution.Client.Types (RepoName (..), WriteGh import Test.QuickCheck import Test.QuickCheck.Instances.Cabal () +import Data.Coerce (Coercible, coerce) import Network.URI (URI (..), URIAuth (..), isUnreserved) -- note: there are plenty of instances defined in ProjectConfig test file. -- they should be moved here or into Cabal-quickcheck +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +data Shrinker a = Shrinker a [a] + +instance Functor Shrinker where + fmap f (Shrinker x xs) = Shrinker (f x) (map f xs) + +instance Applicative Shrinker where + pure x = Shrinker x [] + + Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs) + +runShrinker :: Shrinker a -> [a] +runShrinker (Shrinker _ xs) = xs + +shrinker :: Arbitrary a => a -> Shrinker a +shrinker x = Shrinker x (shrink x) + +shrinkerAla :: (Coercible a b, Arbitrary b) => (a -> b) -> a -> Shrinker a +shrinkerAla pack = shrinkerPP pack coerce + +-- | shrinker with pre and post functions. +shrinkerPP :: Arbitrary b => (a -> b) -> (b -> a) -> a -> Shrinker a +shrinkerPP pack unpack x = Shrinker x (map unpack (shrink (pack x))) + ------------------------------------------------------------------------------- -- Non-Cabal instances ------------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index f54f4e23886..d5dbf6a3f18 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Client.ProjectConfig (tests) where @@ -470,78 +471,37 @@ instance Arbitrary ProjectConfigShared where arbitraryConstraints = fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary - shrink ProjectConfigShared { projectConfigDistDir = x00 - , projectConfigProjectFile = x01 - , projectConfigHcFlavor = x02 - , projectConfigHcPath = x03 - , projectConfigHcPkg = x04 - , projectConfigHaddockIndex = x05 - , projectConfigRemoteRepos = x06 - , projectConfigLocalRepos = x07 - , projectConfigLocalNoIndexRepos = x07b - , projectConfigIndexState = x08 - , projectConfigConstraints = x09 - , projectConfigPreferences = x10 - , projectConfigCabalVersion = x11 - , projectConfigSolver = x12 - , projectConfigAllowOlder = x13 - , projectConfigAllowNewer = x14 - , projectConfigWriteGhcEnvironmentFilesPolicy = x15 - , projectConfigMaxBackjumps = x16 - , projectConfigReorderGoals = x17 - , projectConfigCountConflicts = x18 - , projectConfigFineGrainedConflicts = x19 - , projectConfigMinimizeConflictSet = x20 - , projectConfigStrongFlags = x21 - , projectConfigAllowBootLibInstalls = x22 - , projectConfigOnlyConstrained = x23 - , projectConfigPerComponent = x24 - , projectConfigIndependentGoals = x25 - , projectConfigConfigFile = x26 - , projectConfigProgPathExtra = x27 - , projectConfigStoreDir = x28 } = - [ ProjectConfigShared { projectConfigDistDir = x00' - , projectConfigProjectFile = x01' - , projectConfigHcFlavor = x02' - , projectConfigHcPath = fmap getNonEmpty x03' - , projectConfigHcPkg = fmap getNonEmpty x04' - , projectConfigHaddockIndex = x05' - , projectConfigRemoteRepos = x06' - , projectConfigLocalRepos = x07' - , projectConfigLocalNoIndexRepos = x07b' - , projectConfigIndexState = x08' - , projectConfigConstraints = postShrink_Constraints x09' - , projectConfigPreferences = x10' - , projectConfigCabalVersion = x11' - , projectConfigSolver = x12' - , projectConfigAllowOlder = x13' - , projectConfigAllowNewer = x14' - , projectConfigWriteGhcEnvironmentFilesPolicy = x15' - , projectConfigMaxBackjumps = x16' - , projectConfigReorderGoals = x17' - , projectConfigCountConflicts = x18' - , projectConfigFineGrainedConflicts = x19' - , projectConfigMinimizeConflictSet = x20' - , projectConfigStrongFlags = x21' - , projectConfigAllowBootLibInstalls = x22' - , projectConfigOnlyConstrained = x23' - , projectConfigPerComponent = x24' - , projectConfigIndependentGoals = x25' - , projectConfigConfigFile = x26' - , projectConfigProgPathExtra = x27' - , projectConfigStoreDir = x28' } - | ((x00', x01', x02', x03', x04', x05'), - (x06', x07', x07b', x08', x09', x10'), - (x11', x12', x13', x14', x15', x16'), - (x17', x18', x19', x20', x21', x22'), - x23', x24', x25', x26', x27', x28') - <- shrink - ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04, x05), - (x06, x07, x07b, x08, preShrink_Constraints x09, x10), - (x11, x12, x13, x14, x15, x16), - (x17, x18, x19, x20, x21, x22), - x23, x24, x25, x26, x27, x28) - ] + shrink ProjectConfigShared {..} = runShrinker $ pure ProjectConfigShared + <*> shrinker projectConfigDistDir + <*> shrinker projectConfigConfigFile + <*> shrinker projectConfigProjectFile + <*> shrinker projectConfigHcFlavor + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath + <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg + <*> shrinker projectConfigHaddockIndex + <*> shrinker projectConfigRemoteRepos + <*> shrinker projectConfigLocalRepos + <*> shrinker projectConfigLocalNoIndexRepos + <*> shrinker projectConfigIndexState + <*> shrinker projectConfigStoreDir + <*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints + <*> shrinker projectConfigPreferences + <*> shrinker projectConfigCabalVersion + <*> shrinker projectConfigSolver + <*> shrinker projectConfigAllowOlder + <*> shrinker projectConfigAllowNewer + <*> shrinker projectConfigWriteGhcEnvironmentFilesPolicy + <*> shrinker projectConfigMaxBackjumps + <*> shrinker projectConfigReorderGoals + <*> shrinker projectConfigCountConflicts + <*> shrinker projectConfigFineGrainedConflicts + <*> shrinker projectConfigMinimizeConflictSet + <*> shrinker projectConfigStrongFlags + <*> shrinker projectConfigAllowBootLibInstalls + <*> shrinker projectConfigOnlyConstrained + <*> shrinker projectConfigPerComponent + <*> shrinker projectConfigIndependentGoals + <*> shrinker projectConfigProgPathExtra where preShrink_Constraints = map fst postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))