first attempt at shrinking

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs

@@ -261,6 +261,7 @@ instance (IsConwayUniv fn, Crypto c, Typeable index) => HasSpec fn (SafeHash c i
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -275,6 +276,7 @@ instance (IsConwayUniv fn, Typeable r, Crypto c) => HasSpec fn (KeyHash r c) whe
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -356,6 +358,7 @@ instance IsConwayUniv fn => HasSpec fn PV1.Data where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -443,6 +446,7 @@ instance (IsConwayUniv fn, Crypto (EraCrypto era), Era era) => HasSpec fn (Timel
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -489,6 +493,7 @@ instance (IsConwayUniv fn, Typeable b) => HasSpec fn (AbstractHash Blake2b_224 b
   genFromTypeSpec _ = do
     bytes <- pureGen $ vectorOf 28 arbitrary
     pure $ fromJust $ abstractHashFromBytes (BS.pack bytes)
+  shrinkWithTypeSpec _ _ = []
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -523,6 +528,7 @@ instance (IsConwayUniv fn, HashAlgorithm a, Typeable b) => HasSpec fn (Hash a b)
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -546,6 +552,7 @@ instance IsConwayUniv fn => HasSpec fn StakePoolRelay where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -559,6 +566,7 @@ instance IsConwayUniv fn => HasSpec fn UnitInterval where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -569,6 +577,7 @@ instance IsConwayUniv fn => HasSpec fn NonNegativeInterval where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -586,6 +595,7 @@ instance IsConwayUniv fn => HasSpec fn Text where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -606,6 +616,7 @@ instance IsConwayUniv fn => HasSpec fn ByteString where
   genFromTypeSpec (StringSpec ls) = do
     len <- genFromSpec ls
     BS.pack <$> vectorOfT len (pureGen arbitrary)
+  shrinkWithTypeSpec _ = shrink
   conformsTo bs (StringSpec ls) = BS.length bs `conformsToSpec` ls
   toPreds str (StringSpec len) = satisfies (strLen_ str) len
 
@@ -616,6 +627,7 @@ instance IsConwayUniv fn => HasSpec fn ShortByteString where
   genFromTypeSpec (StringSpec ls) = do
     len <- genFromSpec ls
     SBS.pack <$> vectorOfT len (pureGen arbitrary)
+  shrinkWithTypeSpec _ = shrink
   conformsTo bs (StringSpec ls) = SBS.length bs `conformsToSpec` ls
   toPreds str (StringSpec len) = satisfies (strLen_ str) len
 
@@ -730,12 +742,13 @@ instance IsConwayUniv fn => HasSpec fn ProtVer
 -- while ensuring that we don't have to add instances for e.g. `Num`
 -- to version.
 newtype VersionRep = VersionRep Word8
-  deriving (Show, Eq, Ord, Num, Random) via Word8
+  deriving (Show, Eq, Ord, Num, Random, Arbitrary) via Word8
 instance BaseUniverse fn => HasSpec fn VersionRep where
   type TypeSpec fn VersionRep = NumSpec VersionRep
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
 instance Bounded VersionRep where
@@ -851,6 +864,7 @@ instance IsConwayUniv fn => HasSpec fn Char where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -859,6 +873,7 @@ instance IsConwayUniv fn => HasSpec fn CostModel where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -1256,6 +1271,7 @@ instance (IsConwayUniv fn, Crypto c, Typeable r) => HasSpec fn (WitVKey r c) whe
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 
@@ -1264,6 +1280,7 @@ instance (IsConwayUniv fn, Crypto c) => HasSpec fn (BootstrapWitness c) where
   emptySpec = ()
   combineSpec _ _ = TrueSpec
   genFromTypeSpec _ = pureGen arbitrary
+  shrinkWithTypeSpec _ = shrink
   conformsTo _ _ = True
   toPreds _ _ = toPred True
 

libs/cardano-ledger-test/src/Test/Cardano/Ledger/STS.hs

@@ -45,7 +45,7 @@ import Test.Tasty.QuickCheck
 type GenShrink a = (Gen a, a -> [a])
 
 genShrinkFromSpec :: forall fn a. HasSpec fn a => Spec fn a -> GenShrink a
-genShrinkFromSpec spec = (genFromSpec_ @fn spec, const [])
+genShrinkFromSpec spec = (genFromSpec_ @fn spec, shrinkWithSpec @fn spec)
 
 stsPropertyV2 ::
   forall r fn era env st sig fail p.

libs/constrained-generators/src/Constrained.hs

@@ -40,6 +40,7 @@ module Constrained (
   genFromSpec,
   genFromSpec_,
   genFromSpecWithSeed,
+  shrinkWithSpec,
   conformsToSpec,
   conformsToSpecProp,
   giveHint,
@@ -99,6 +100,7 @@ module Constrained (
   emptyNumSpec,
   combineNumSpec,
   genFromNumSpec,
+  shrinkWithNumSpec,
   conformsToNumSpec,
   toPredsNumSpec,
   -- TODO: this is super yucky, it would be good to implement

libs/constrained-generators/src/Constrained/Base.hs

@@ -620,6 +620,9 @@ class
   -- | Check conformance to the spec.
   conformsTo :: HasCallStack => a -> TypeSpec fn a -> Bool
 
+  -- | Shrink an `a` with the aide of a `TypeSpec`
+  shrinkWithTypeSpec :: TypeSpec fn a -> a -> [a]
+
   -- | Convert a spec to predicates:
   -- The key property here is:
   --   ∀ a. a `conformsTo` spec == a `conformsTo` constrained (\t -> toPreds t spec)
@@ -714,6 +717,16 @@ class
     Pred fn
   toPreds v s = toPreds (toGeneric_ v) s
 
+  default shrinkWithTypeSpec ::
+    ( HasSpec fn (SimpleRep a)
+    , TypeSpec fn a ~ TypeSpec fn (SimpleRep a)
+    , HasSimpleRep a
+    ) =>
+    TypeSpec fn a ->
+    a ->
+    [a]
+  shrinkWithTypeSpec spec a = map fromSimpleRep $ shrinkWithTypeSpec @fn spec (toSimpleRep a)
+
 data WithHasSpec fn f a where
   WithHasSpec :: HasSpec fn a => f a -> WithHasSpec fn f a
 
@@ -800,6 +813,21 @@ genFromSpec ts@(TypeSpec s cant) =
     genFromTypeSpec @fn s `suchThatT` (`notElem` cant)
 genFromSpec (ErrorSpec e) = genError e
 
+shrinkWithSpec :: forall fn a. HasSpec fn a => Spec fn a -> a -> [a]
+-- TODO: possibly allow for ignoring the `conformsToSpec` check in the `TypeSpec`
+-- case when you know what you're doing
+shrinkWithSpec spec a = filter (`conformsToSpec` spec) $ case spec of
+  -- TODO: filter on can't if we have a known to be sound shrinker
+  TypeSpec s _ -> shrinkWithTypeSpec @fn s a
+  -- TODO: The better way of doing this is to compute the dependency graph,
+  -- shrink one variable at a time, and fixup the rest of the variables
+  SuspendedSpec {} -> shr a
+  MemberSpec {} -> shr a
+  TrueSpec -> shr a
+  ErrorSpec {} -> []
+  where
+    shr = shrinkWithTypeSpec @fn (emptySpec @fn @a)
+
 -- | A version of `genFromSpec` that simply errors if the generator fails
 genFromSpec_ :: forall fn a. (HasCallStack, HasSpec fn a) => Spec fn a -> Gen a
 genFromSpec_ spec = do
@@ -2463,17 +2491,19 @@ instance BaseUniverse fn => HasSpec fn () where
   emptySpec = ()
   combineSpec _ _ = typeSpec ()
   _ `conformsTo` _ = True
+  shrinkWithTypeSpec _ _ = []
   genFromTypeSpec _ = pure ()
   toPreds _ _ = TruePred
   cardinalTypeSpec _ = MemberSpec [1]
-  cardinalTrueSpec = exactSizeSpec 1 -- there are exactly two, True and False
+  cardinalTrueSpec = exactSizeSpec 1 -- there is exactly one, ()
   typeSpecOpt _ [] = TrueSpec
   typeSpecOpt _ (_ : _) = MemberSpec []
 
 -- Bool -------------------------------------------------------------------
 
 instance HasSimpleRep Bool
-instance (BaseUniverse fn, HasSpec fn ()) => HasSpec fn Bool
+instance (BaseUniverse fn, HasSpec fn ()) => HasSpec fn Bool where
+  shrinkWithTypeSpec _ = shrink
 
 -- Sum --------------------------------------------------------------------
 
@@ -2515,6 +2545,9 @@ instance (HasSpec fn a, HasSpec fn b) => HasSpec fn (Sum a b) where
       emptyA = isErrorLike sa
       emptyB = isErrorLike sb
 
+  shrinkWithTypeSpec (SumSpec sa _) (SumLeft a) = SumLeft <$> shrinkWithSpec sa a
+  shrinkWithTypeSpec (SumSpec _ sb) (SumRight b) = SumRight <$> shrinkWithSpec sb b
+
   toPreds ct (SumSpec sa sb) =
     Case
       ct
@@ -2570,6 +2603,8 @@ instance (Ord a, HasSpec fn a) => HasSpec fn (Set a) where
               genFromSpec elemS `suchThatT` (`Set.notMember` s)
         go (n - 1) (Set.insert e s)
 
+  shrinkWithTypeSpec (SetSpec _ es _) as = map Set.fromList $ shrinkList (shrinkWithSpec es) (Set.toList as)
+
   toPreds s (SetSpec m es size) =
     (Assert ["Subset of " ++ show m] $ subset_ (Lit m) s)
       <> forAll s (\e -> satisfies e es)
@@ -2737,6 +2772,9 @@ instance HasSpec fn a => HasSpec fn [a] where
   genFromTypeSpec (ListSpec msz must size elemS (FoldSpec f foldS)) = do
     genFromFold must (size <> maybe TrueSpec leqSpec msz) elemS f foldS
 
+  shrinkWithTypeSpec (ListSpec _ _ _ es _) as =
+    shrinkList (shrinkWithSpec es) as
+
   conformsTo xs (ListSpec _ must size elemS foldS) =
     sizeOf xs `conformsToSpec` size
       && all (`elem` xs) must
@@ -2849,6 +2887,10 @@ genFromNumSpec (NumSpecInterval ml mu) = do
   n <- sizeT
   pureGen . choose =<< constrainInterval (ml <|> lowerBound) (mu <|> upperBound) (fromIntegral n)
 
+-- TODO: fixme (?)
+shrinkWithNumSpec :: Arbitrary n => NumSpec n -> n -> [n]
+shrinkWithNumSpec _ = shrink
+
 constrainInterval ::
   (MonadGenError m, Ord a, Num a, Show a) => Maybe a -> Maybe a -> Integer -> m (a, a)
 constrainInterval ml mu r =
@@ -2895,6 +2937,7 @@ instance BaseUniverse fn => HasSpec fn Int where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
 
@@ -2903,6 +2946,7 @@ instance BaseUniverse fn => HasSpec fn Integer where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2912,6 +2956,7 @@ instance BaseUniverse fn => HasSpec fn (Ratio Integer) where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
 
@@ -2920,6 +2965,7 @@ instance BaseUniverse fn => HasSpec fn Natural where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec (NumSpecInterval (Just lo) (Just hi)) =
@@ -2933,6 +2979,7 @@ instance BaseUniverse fn => HasSpec fn Word8 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2943,6 +2990,7 @@ instance BaseUniverse fn => HasSpec fn Word16 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2952,6 +3000,7 @@ instance BaseUniverse fn => HasSpec fn Word32 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2961,6 +3010,7 @@ instance BaseUniverse fn => HasSpec fn Word64 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
 
@@ -2969,6 +3019,7 @@ instance BaseUniverse fn => HasSpec fn Int8 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2978,6 +3029,7 @@ instance BaseUniverse fn => HasSpec fn Int16 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2987,6 +3039,7 @@ instance BaseUniverse fn => HasSpec fn Int32 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -2996,6 +3049,7 @@ instance BaseUniverse fn => HasSpec fn Int64 where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
   cardinalTypeSpec = cardinalSizeSpec
@@ -3005,6 +3059,7 @@ instance BaseUniverse fn => HasSpec fn Float where
   emptySpec = emptyNumSpec
   combineSpec = combineNumSpec
   genFromTypeSpec = genFromNumSpec
+  shrinkWithTypeSpec = shrinkWithNumSpec
   conformsTo = conformsToNumSpec
   toPreds = toPredsNumSpec
 

libs/constrained-generators/src/Constrained/Spec/Maps.hs

@@ -27,6 +27,7 @@ import Data.Map qualified as Map
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Prettyprinter
+import Test.QuickCheck (shrinkList)
 
 ------------------------------------------------------------------------
 -- HasSpec
@@ -131,6 +132,8 @@ instance
           go (Map.insert k v m) restVals'
     go (Map.fromList mustMap) restVals
 
+  shrinkWithTypeSpec (MapSpec _ _ _ kvs _) m = map Map.fromList $ shrinkList (shrinkWithSpec kvs) (Map.toList m)
+
   toPreds m (MapSpec mustKeys mustVals size kvs foldSpec) =
     toPred
       [ assert $ app (subsetFn @fn) (app (domFn @fn) m) (Lit mustKeys)