From dc7aad69737867983c5d63728f4fb29553ae5922 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Tue, 2 Nov 2021 06:54:59 +0000 Subject: [PATCH 1/3] Add module `Data.Generic.Fields`. This module contains generic functions and types relating to data types with one or more fields. --- .../cardano-wallet-test-utils.cabal | 1 + lib/test-utils/src/Data/Generic/Fields.hs | 120 ++++++++++++++++++ 2 files changed, 121 insertions(+) create mode 100644 lib/test-utils/src/Data/Generic/Fields.hs diff --git a/lib/test-utils/cardano-wallet-test-utils.cabal b/lib/test-utils/cardano-wallet-test-utils.cabal index bb3a1a1fbde..214a2f82865 100644 --- a/lib/test-utils/cardano-wallet-test-utils.cabal +++ b/lib/test-utils/cardano-wallet-test-utils.cabal @@ -64,6 +64,7 @@ library hs-source-dirs: src exposed-modules: + Data.Generic.Fields Test.Hspec.Extra Test.Hspec.Goldens Test.QuickCheck.Extra diff --git a/lib/test-utils/src/Data/Generic/Fields.hs b/lib/test-utils/src/Data/Generic/Fields.hs new file mode 100644 index 00000000000..be473825326 --- /dev/null +++ b/lib/test-utils/src/Data/Generic/Fields.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Copyright: © 2021 IOHK +-- License: Apache-2.0 +-- +-- Generic functions and types relating to fields of data types. +-- +module Data.Generic.Fields + ( + -- * Generic constraints for data types with fields + HasFields1 + , HasFields2 + , HasFields3 + , HasFields4 + , HasFields5 + , HasFields6 + , HasFields7 + , HasFields8 + , HasFields9 + + -- * Generic conversion of values to tuples + , toTuple1 + , toTuple2 + , toTuple3 + , toTuple4 + , toTuple5 + , toTuple6 + , toTuple7 + , toTuple8 + , toTuple9 + ) + where + +import Data.Generics.Internal.VL.Lens + ( (^.) ) +import Data.Generics.Product.Positions + ( HasPosition', position' ) + +-------------------------------------------------------------------------------- +-- Generic constraints for data types with fields +-------------------------------------------------------------------------------- + +type HasFields1 r a = + (HasPosition' 1 r a) + +type HasFields2 r a b = + (HasFields1 r a, HasPosition' 2 r b) + +type HasFields3 r a b c = + (HasFields2 r a b, HasPosition' 3 r c) + +type HasFields4 r a b c d = + (HasFields3 r a b c, HasPosition' 4 r d) + +type HasFields5 r a b c d e = + (HasFields4 r a b c d, HasPosition' 5 r e) + +type HasFields6 r a b c d e f = + (HasFields5 r a b c d e, HasPosition' 6 r f) + +type HasFields7 r a b c d e f g = + (HasFields6 r a b c d e f, HasPosition' 7 r g) + +type HasFields8 r a b c d e f g h = + (HasFields7 r a b c d e f g, HasPosition' 8 r h) + +type HasFields9 r a b c d e f g h i = + (HasFields8 r a b c d e f g h, HasPosition' 9 r i) + +-------------------------------------------------------------------------------- +-- Generic conversion of values to tuples +-------------------------------------------------------------------------------- + +toTuple1 :: HasFields1 r a => r -> (a) +toTuple1 r = (r ^. position' @1) + +toTuple2 :: HasFields2 r a b => r -> (a, b) +toTuple2 r = (a, r ^. position' @2) + where + (a) = toTuple1 r + +toTuple3 :: HasFields3 r a b c => r -> (a, b, c) +toTuple3 r = (a, b, r ^. position' @3) + where + (a, b) = toTuple2 r + +toTuple4 :: HasFields4 r a b c d => r -> (a, b, c, d) +toTuple4 r = (a, b, c, r ^. position' @4) + where + (a, b, c) = toTuple3 r + +toTuple5 :: HasFields5 r a b c d e => r -> (a, b, c, d, e) +toTuple5 r = (a, b, c, d, r ^. position' @5) + where + (a, b, c, d) = toTuple4 r + +toTuple6 :: HasFields6 r a b c d e f => r -> (a, b, c, d, e, f) +toTuple6 r = (a, b, c, d, e, r ^. position' @6) + where + (a, b, c, d, e) = toTuple5 r + +toTuple7 :: HasFields7 r a b c d e f g => r -> (a, b, c, d, e, f, g) +toTuple7 r = (a, b, c, d, e, f, r ^. position' @7) + where + (a, b, c, d, e, f) = toTuple6 r + +toTuple8 :: HasFields8 r a b c d e f g h => r -> (a, b, c, d, e, f, g, h) +toTuple8 r = (a, b, c, d, e, f, g, r ^. position' @8) + where + (a, b, c, d, e, f, g) = toTuple7 r + +toTuple9 :: HasFields9 r a b c d e f g h i => r -> (a, b, c, d, e, f, g, h, i) +toTuple9 r = (a, b, c, d, e, f, g, h, r ^. position' @9) + where + (a, b, c, d, e, f, g, h) = toTuple8 r From b65a6981bcf474ec404f13a88fc7e9d905cf6998 Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Fri, 29 Oct 2021 07:36:31 +0000 Subject: [PATCH 2/3] Generalize `liftShrink` family of functions. In this commit, we generalize the `liftShrink` family of functions so that each of these functions can be applied to any data type with the right number of fields. --- .../Primitive/CoinSelection/Balance/Gen.hs | 5 +- .../Cardano/Wallet/Primitive/Types/Tx/Gen.hs | 15 +- .../Primitive/CoinSelection/BalanceSpec.hs | 10 +- .../Wallet/Primitive/CoinSelectionSpec.hs | 11 +- .../cardano-wallet-test-utils.cabal | 1 + lib/test-utils/src/Test/QuickCheck/Extra.hs | 185 ++++++++++-------- 6 files changed, 119 insertions(+), 108 deletions(-) diff --git a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Balance/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Balance/Gen.hs index 4e8549fe991..4649e9b1878 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Balance/Gen.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/CoinSelection/Balance/Gen.hs @@ -68,7 +68,7 @@ genSelectionSkeleton = SelectionSkeleton shrinkSelectionSkeleton :: SelectionSkeleton -> [SelectionSkeleton] shrinkSelectionSkeleton = - shrinkMapBy tupleToSkeleton skeletonToTuple $ liftShrink3 + liftShrink3 SelectionSkeleton shrinkSkeletonInputCount shrinkSkeletonOutputs shrinkSkeletonChange @@ -80,6 +80,3 @@ shrinkSelectionSkeleton = shrinkSkeletonChange = shrinkList $ shrinkMapBy Set.fromList Set.toList (shrinkList shrinkAssetId) - - skeletonToTuple (SelectionSkeleton a b c) = (a, b, c) - tupleToSkeleton (a, b, c) = (SelectionSkeleton a b c) diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/Tx/Gen.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/Tx/Gen.hs index 8625439a867..2132aef63fe 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types/Tx/Gen.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types/Tx/Gen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} @@ -55,6 +56,8 @@ import Data.Text.Class ( FromText (..) ) import Data.Word ( Word32 ) +import GHC.Generics + ( Generic ) import Test.QuickCheck ( Gen , arbitrary @@ -105,7 +108,7 @@ data TxWithoutId = TxWithoutId , withdrawals :: !(Map RewardAccount Coin) , scriptValidity :: !(Maybe TxScriptValidity) } - deriving (Eq, Ord, Show) + deriving (Eq, Generic, Ord, Show) genTxWithoutId :: Gen TxWithoutId genTxWithoutId = TxWithoutId @@ -119,7 +122,7 @@ genTxWithoutId = TxWithoutId shrinkTxWithoutId :: TxWithoutId -> [TxWithoutId] shrinkTxWithoutId = - shrinkMapBy tupleToTxWithoutId txWithoutIdToTuple $ liftShrink7 + liftShrink7 TxWithoutId (liftShrink shrinkCoinPositive) (shrinkList (liftShrink2 shrinkTxIn shrinkCoinPositive)) (shrinkList (liftShrink2 shrinkTxIn shrinkCoinPositive)) @@ -134,14 +137,6 @@ txWithoutIdToTx tx@TxWithoutId {..} = Tx {txId = mockHash tx, ..} txToTxWithoutId :: Tx -> TxWithoutId txToTxWithoutId Tx {..} = TxWithoutId {..} -txWithoutIdToTuple :: TxWithoutId -> _ -txWithoutIdToTuple (TxWithoutId a1 a2 a3 a4 a5 a6 a7) = - (a1, a2, a3, a4, a5, a6, a7) - -tupleToTxWithoutId :: _ -> TxWithoutId -tupleToTxWithoutId (a1, a2, a3, a4, a5, a6, a7) = - (TxWithoutId a1 a2 a3 a4 a5 a6 a7) - genTxScriptValidity :: Gen TxScriptValidity genTxScriptValidity = genericArbitrary diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/BalanceSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/BalanceSpec.hs index aaa51e21fff..56857052017 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/BalanceSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/BalanceSpec.hs @@ -614,16 +614,13 @@ genSelectionParams genPreselectedInputs genUTxOIndex' = do shrinkSelectionParams :: SelectionParams -> [SelectionParams] shrinkSelectionParams = - shrinkMapBy tupleToParams paramsToTuple $ liftShrink6 + liftShrink6 SelectionParams (shrinkList shrinkTxOut) (shrinkUTxOSelection) (shrinkCoin) (shrinkCoin) (shrinkTokenMap) (shrinkTokenMap) - where - paramsToTuple (SelectionParams a b c d e f) = (a, b, c, d, e, f) - tupleToParams (a, b, c, d, e, f) = (SelectionParams a b c d e f) prop_performSelection_small :: MockSelectionConstraints @@ -2044,14 +2041,11 @@ genMockSelectionConstraints = MockSelectionConstraints shrinkMockSelectionConstraints :: MockSelectionConstraints -> [MockSelectionConstraints] shrinkMockSelectionConstraints = - shrinkMapBy tupleToMock mockToTuple $ liftShrink4 + liftShrink4 MockSelectionConstraints shrinkMockAssessTokenBundleSize shrinkMockComputeMinimumAdaQuantity shrinkMockComputeMinimumCost shrinkMockComputeSelectionLimit - where - mockToTuple (MockSelectionConstraints a b c d) = (a, b, c, d) - tupleToMock (a, b, c, d) = (MockSelectionConstraints a b c d) unMockSelectionConstraints :: MockSelectionConstraints -> SelectionConstraints unMockSelectionConstraints m = SelectionConstraints diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs index 197ef36169f..9d37c3c9bff 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs @@ -115,7 +115,6 @@ import Test.QuickCheck , scale , shrink , shrinkList - , shrinkMapBy , vectorOf , (===) ) @@ -533,7 +532,7 @@ genMockSelectionConstraints = MockSelectionConstraints shrinkMockSelectionConstraints :: MockSelectionConstraints -> [MockSelectionConstraints] shrinkMockSelectionConstraints = - shrinkMapBy toMock unMock $ liftShrink8 + liftShrink8 MockSelectionConstraints shrinkMockAssessTokenBundleSize shrinkCertificateDepositAmount shrinkMockComputeMinimumAdaQuantity @@ -542,9 +541,6 @@ shrinkMockSelectionConstraints = shrinkMaximumCollateralInputCount shrinkMinimumCollateralPercentage shrinkMockUTxOSuitableForCollateral - where - unMock (MockSelectionConstraints a b c d e f g h) = (a, b, c, d, e, f, g, h) - toMock (a, b, c, d, e, f, g, h) = (MockSelectionConstraints a b c d e f g h) unMockSelectionConstraints :: MockSelectionConstraints -> SelectionConstraints unMockSelectionConstraints m = SelectionConstraints @@ -640,7 +636,7 @@ genSelectionParams = SelectionParams shrinkSelectionParams :: SelectionParams -> [SelectionParams] shrinkSelectionParams = - shrinkMapBy ofTuple toTuple $ liftShrink9 + liftShrink9 SelectionParams shrinkAssetsToBurn shrinkAssetsToMint shrinkOutputsToCover @@ -650,9 +646,6 @@ shrinkSelectionParams = shrinkCollateralRequirement shrinkUTxOAvailableForCollateral shrinkUTxOAvailableForInputs - where - toTuple (SelectionParams a b c d e f g h i) = (a, b, c, d, e, f, g, h, i) - ofTuple (a, b, c, d, e, f, g, h, i) = (SelectionParams a b c d e f g h i) -------------------------------------------------------------------------------- -- Assets to mint and burn diff --git a/lib/test-utils/cardano-wallet-test-utils.cabal b/lib/test-utils/cardano-wallet-test-utils.cabal index 214a2f82865..e3a01865058 100644 --- a/lib/test-utils/cardano-wallet-test-utils.cabal +++ b/lib/test-utils/cardano-wallet-test-utils.cabal @@ -40,6 +40,7 @@ library , directory , either , fmt + , generic-lens , hspec-core , hspec-expectations , hspec-golden-aeson diff --git a/lib/test-utils/src/Test/QuickCheck/Extra.hs b/lib/test-utils/src/Test/QuickCheck/Extra.hs index 8933478b933..63f1ae5d7d2 100644 --- a/lib/test-utils/src/Test/QuickCheck/Extra.hs +++ b/lib/test-utils/src/Test/QuickCheck/Extra.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} -- | @@ -84,6 +86,7 @@ import Test.Utils.Pretty import Text.Pretty.Simple ( pShow ) +import qualified Data.Generic.Fields as Fields import qualified Data.List as L import qualified Data.Map.Strict as Map import qualified Data.Text.Lazy as TL @@ -147,105 +150,127 @@ genSized2 genA genB = (,) genSized2With :: (a -> b -> c) -> Gen a -> Gen b -> Gen c genSized2With f genA genB = uncurry f <$> genSized2 genA genB --- | Similar to 'liftShrink2', but applicable to 3-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 3 fields. -- liftShrink3 - :: (a1 -> [a1]) + :: Fields.HasFields3 r a1 a2 a3 + => (a1 -> a2 -> a3 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) - -> (a1, a2, a3) - -> [(a1, a2, a3)] -liftShrink3 s1 s2 s3 (a1, a2, a3) = + -> r + -> [r] +liftShrink3 f s1 s2 s3 r = interleaveRoundRobin - [ [ (a1', a2 , a3 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3') | a3' <- s3 a3 ] + [ [ f a1' a2 a3 | a1' <- s1 a1 ] + , [ f a1 a2' a3 | a2' <- s2 a2 ] + , [ f a1 a2 a3' | a3' <- s3 a3 ] ] + where + (a1, a2, a3) = Fields.toTuple3 r --- | Similar to 'liftShrink2', but applicable to 4-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 4 fields. -- liftShrink4 - :: (a1 -> [a1]) + :: Fields.HasFields4 r a1 a2 a3 a4 + => (a1 -> a2 -> a3 -> a4 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) -> (a4 -> [a4]) - -> (a1, a2, a3, a4) - -> [(a1, a2, a3, a4)] -liftShrink4 s1 s2 s3 s4 (a1, a2, a3, a4) = + -> r + -> [r] +liftShrink4 f s1 s2 s3 s4 r = interleaveRoundRobin - [ [ (a1', a2 , a3 , a4 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 , a4 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3', a4 ) | a3' <- s3 a3 ] - , [ (a1 , a2 , a3 , a4') | a4' <- s4 a4 ] + [ [ f a1' a2 a3 a4 | a1' <- s1 a1 ] + , [ f a1 a2' a3 a4 | a2' <- s2 a2 ] + , [ f a1 a2 a3' a4 | a3' <- s3 a3 ] + , [ f a1 a2 a3 a4' | a4' <- s4 a4 ] ] + where + (a1, a2, a3, a4) = Fields.toTuple4 r --- | Similar to 'liftShrink2', but applicable to 5-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 5 fields. -- liftShrink5 - :: (a1 -> [a1]) + :: Fields.HasFields5 r a1 a2 a3 a4 a5 + => (a1 -> a2 -> a3 -> a4 -> a5 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) -> (a4 -> [a4]) -> (a5 -> [a5]) - -> (a1, a2, a3, a4, a5) - -> [(a1, a2, a3, a4, a5)] -liftShrink5 s1 s2 s3 s4 s5 (a1, a2, a3, a4, a5) = + -> r + -> [r] +liftShrink5 f s1 s2 s3 s4 s5 r = interleaveRoundRobin - [ [ (a1', a2 , a3 , a4 , a5 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 , a4 , a5 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3', a4 , a5 ) | a3' <- s3 a3 ] - , [ (a1 , a2 , a3 , a4', a5 ) | a4' <- s4 a4 ] - , [ (a1 , a2 , a3 , a4 , a5') | a5' <- s5 a5 ] + [ [ f a1' a2 a3 a4 a5 | a1' <- s1 a1 ] + , [ f a1 a2' a3 a4 a5 | a2' <- s2 a2 ] + , [ f a1 a2 a3' a4 a5 | a3' <- s3 a3 ] + , [ f a1 a2 a3 a4' a5 | a4' <- s4 a4 ] + , [ f a1 a2 a3 a4 a5' | a5' <- s5 a5 ] ] + where + (a1, a2, a3, a4, a5) = Fields.toTuple5 r --- | Similar to 'liftShrink2', but applicable to 6-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 6 fields. -- liftShrink6 - :: (a1 -> [a1]) + :: Fields.HasFields6 r a1 a2 a3 a4 a5 a6 + => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) -> (a4 -> [a4]) -> (a5 -> [a5]) -> (a6 -> [a6]) - -> (a1, a2, a3, a4, a5, a6) - -> [(a1, a2, a3, a4, a5, a6)] -liftShrink6 s1 s2 s3 s4 s5 s6 (a1, a2, a3, a4, a5, a6) = + -> r + -> [r] +liftShrink6 f s1 s2 s3 s4 s5 s6 r = interleaveRoundRobin - [ [ (a1', a2 , a3 , a4 , a5 , a6 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 , a4 , a5 , a6 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3', a4 , a5 , a6 ) | a3' <- s3 a3 ] - , [ (a1 , a2 , a3 , a4', a5 , a6 ) | a4' <- s4 a4 ] - , [ (a1 , a2 , a3 , a4 , a5', a6 ) | a5' <- s5 a5 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6') | a6' <- s6 a6 ] + [ [ f a1' a2 a3 a4 a5 a6 | a1' <- s1 a1 ] + , [ f a1 a2' a3 a4 a5 a6 | a2' <- s2 a2 ] + , [ f a1 a2 a3' a4 a5 a6 | a3' <- s3 a3 ] + , [ f a1 a2 a3 a4' a5 a6 | a4' <- s4 a4 ] + , [ f a1 a2 a3 a4 a5' a6 | a5' <- s5 a5 ] + , [ f a1 a2 a3 a4 a5 a6' | a6' <- s6 a6 ] ] + where + (a1, a2, a3, a4, a5, a6) = Fields.toTuple6 r --- | Similar to 'liftShrink2', but applicable to 7-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 7 fields. -- liftShrink7 - :: (a1 -> [a1]) + :: Fields.HasFields7 r a1 a2 a3 a4 a5 a6 a7 + => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) -> (a4 -> [a4]) -> (a5 -> [a5]) -> (a6 -> [a6]) -> (a7 -> [a7]) - -> (a1, a2, a3, a4, a5, a6, a7) - -> [(a1, a2, a3, a4, a5, a6, a7)] -liftShrink7 s1 s2 s3 s4 s5 s6 s7 (a1, a2, a3, a4, a5, a6, a7) = + -> r + -> [r] +liftShrink7 f s1 s2 s3 s4 s5 s6 s7 r = interleaveRoundRobin - [ [ (a1', a2 , a3 , a4 , a5 , a6 , a7 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 , a4 , a5 , a6 , a7 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3', a4 , a5 , a6 , a7 ) | a3' <- s3 a3 ] - , [ (a1 , a2 , a3 , a4', a5 , a6 , a7 ) | a4' <- s4 a4 ] - , [ (a1 , a2 , a3 , a4 , a5', a6 , a7 ) | a5' <- s5 a5 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6', a7 ) | a6' <- s6 a6 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6 , a7') | a7' <- s7 a7 ] + [ [ f a1' a2 a3 a4 a5 a6 a7 | a1' <- s1 a1 ] + , [ f a1 a2' a3 a4 a5 a6 a7 | a2' <- s2 a2 ] + , [ f a1 a2 a3' a4 a5 a6 a7 | a3' <- s3 a3 ] + , [ f a1 a2 a3 a4' a5 a6 a7 | a4' <- s4 a4 ] + , [ f a1 a2 a3 a4 a5' a6 a7 | a5' <- s5 a5 ] + , [ f a1 a2 a3 a4 a5 a6' a7 | a6' <- s6 a6 ] + , [ f a1 a2 a3 a4 a5 a6 a7' | a7' <- s7 a7 ] ] + where + (a1, a2, a3, a4, a5, a6, a7) = Fields.toTuple7 r --- | Similar to 'liftShrink2', but applicable to 8-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 8 fields. -- liftShrink8 - :: (a1 -> [a1]) + :: Fields.HasFields8 r a1 a2 a3 a4 a5 a6 a7 a8 + => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) -> (a4 -> [a4]) @@ -253,24 +278,28 @@ liftShrink8 -> (a6 -> [a6]) -> (a7 -> [a7]) -> (a8 -> [a8]) - -> (a1, a2, a3, a4, a5, a6, a7, a8) - -> [(a1, a2, a3, a4, a5, a6, a7, a8)] -liftShrink8 s1 s2 s3 s4 s5 s6 s7 s8 (a1, a2, a3, a4, a5, a6, a7, a8) = + -> r + -> [r] +liftShrink8 f s1 s2 s3 s4 s5 s6 s7 s8 r = interleaveRoundRobin - [ [ (a1', a2 , a3 , a4 , a5 , a6 , a7 , a8 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 , a4 , a5 , a6 , a7 , a8 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3', a4 , a5 , a6 , a7 , a8 ) | a3' <- s3 a3 ] - , [ (a1 , a2 , a3 , a4', a5 , a6 , a7 , a8 ) | a4' <- s4 a4 ] - , [ (a1 , a2 , a3 , a4 , a5', a6 , a7 , a8 ) | a5' <- s5 a5 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6', a7 , a8 ) | a6' <- s6 a6 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6 , a7', a8 ) | a7' <- s7 a7 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8') | a8' <- s8 a8 ] + [ [ f a1' a2 a3 a4 a5 a6 a7 a8 | a1' <- s1 a1 ] + , [ f a1 a2' a3 a4 a5 a6 a7 a8 | a2' <- s2 a2 ] + , [ f a1 a2 a3' a4 a5 a6 a7 a8 | a3' <- s3 a3 ] + , [ f a1 a2 a3 a4' a5 a6 a7 a8 | a4' <- s4 a4 ] + , [ f a1 a2 a3 a4 a5' a6 a7 a8 | a5' <- s5 a5 ] + , [ f a1 a2 a3 a4 a5 a6' a7 a8 | a6' <- s6 a6 ] + , [ f a1 a2 a3 a4 a5 a6 a7' a8 | a7' <- s7 a7 ] + , [ f a1 a2 a3 a4 a5 a6 a7 a8' | a8' <- s8 a8 ] ] + where + (a1, a2, a3, a4, a5, a6, a7, a8) = Fields.toTuple8 r --- | Similar to 'liftShrink2', but applicable to 9-tuples. +-- | Similar to 'liftShrink2', but applicable to values with 9 fields. -- liftShrink9 - :: (a1 -> [a1]) + :: Fields.HasFields9 r a1 a2 a3 a4 a5 a6 a7 a8 a9 + => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> r) + -> (a1 -> [a1]) -> (a2 -> [a2]) -> (a3 -> [a3]) -> (a4 -> [a4]) @@ -279,20 +308,22 @@ liftShrink9 -> (a7 -> [a7]) -> (a8 -> [a8]) -> (a9 -> [a9]) - -> (a1, a2, a3, a4, a5, a6, a7, a8, a9) - -> [(a1, a2, a3, a4, a5, a6, a7, a8, a9)] -liftShrink9 s1 s2 s3 s4 s5 s6 s7 s8 s9 (a1, a2, a3, a4, a5, a6, a7, a8, a9) = + -> r + -> [r] +liftShrink9 f s1 s2 s3 s4 s5 s6 s7 s8 s9 r = interleaveRoundRobin - [ [ (a1', a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9 ) | a1' <- s1 a1 ] - , [ (a1 , a2', a3 , a4 , a5 , a6 , a7 , a8 , a9 ) | a2' <- s2 a2 ] - , [ (a1 , a2 , a3', a4 , a5 , a6 , a7 , a8 , a9 ) | a3' <- s3 a3 ] - , [ (a1 , a2 , a3 , a4', a5 , a6 , a7 , a8 , a9 ) | a4' <- s4 a4 ] - , [ (a1 , a2 , a3 , a4 , a5', a6 , a7 , a8 , a9 ) | a5' <- s5 a5 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6', a7 , a8 , a9 ) | a6' <- s6 a6 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6 , a7', a8 , a9 ) | a7' <- s7 a7 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8', a9 ) | a8' <- s8 a8 ] - , [ (a1 , a2 , a3 , a4 , a5 , a6 , a7 , a8 , a9') | a9' <- s9 a9 ] + [ [ f a1' a2 a3 a4 a5 a6 a7 a8 a9 | a1' <- s1 a1 ] + , [ f a1 a2' a3 a4 a5 a6 a7 a8 a9 | a2' <- s2 a2 ] + , [ f a1 a2 a3' a4 a5 a6 a7 a8 a9 | a3' <- s3 a3 ] + , [ f a1 a2 a3 a4' a5 a6 a7 a8 a9 | a4' <- s4 a4 ] + , [ f a1 a2 a3 a4 a5' a6 a7 a8 a9 | a5' <- s5 a5 ] + , [ f a1 a2 a3 a4 a5 a6' a7 a8 a9 | a6' <- s6 a6 ] + , [ f a1 a2 a3 a4 a5 a6 a7' a8 a9 | a7' <- s7 a7 ] + , [ f a1 a2 a3 a4 a5 a6 a7 a8' a9 | a8' <- s8 a8 ] + , [ f a1 a2 a3 a4 a5 a6 a7 a8 a9' | a9' <- s9 a9 ] ] + where + (a1, a2, a3, a4, a5, a6, a7, a8, a9) = Fields.toTuple9 r -- Interleaves the given lists together in round-robin order. -- From b5ea488d9436c65b27c12f2cfd87dd602d25f6fe Mon Sep 17 00:00:00 2001 From: Jonathan Knowles Date: Wed, 3 Nov 2021 03:34:01 +0000 Subject: [PATCH 3/3] Regenerate nix. --- nix/.stack.nix/cardano-wallet-test-utils.nix | 1 + 1 file changed, 1 insertion(+) diff --git a/nix/.stack.nix/cardano-wallet-test-utils.nix b/nix/.stack.nix/cardano-wallet-test-utils.nix index d3a5006b253..b02a6969c3b 100644 --- a/nix/.stack.nix/cardano-wallet-test-utils.nix +++ b/nix/.stack.nix/cardano-wallet-test-utils.nix @@ -40,6 +40,7 @@ (hsPkgs."directory" or (errorHandler.buildDepError "directory")) (hsPkgs."either" or (errorHandler.buildDepError "either")) (hsPkgs."fmt" or (errorHandler.buildDepError "fmt")) + (hsPkgs."generic-lens" or (errorHandler.buildDepError "generic-lens")) (hsPkgs."hspec-core" or (errorHandler.buildDepError "hspec-core")) (hsPkgs."hspec-expectations" or (errorHandler.buildDepError "hspec-expectations")) (hsPkgs."hspec-golden-aeson" or (errorHandler.buildDepError "hspec-golden-aeson"))