/
Instances.hs
78 lines (55 loc) · 2.19 KB
/
Instances.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
{-# LANGUAGE NamedFieldPuns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Ouroboros.Network.PeerSelection.Instances (
-- test types
PeerAddr(..),
-- generator tests
prop_arbitrary_PeerSelectionTargets,
prop_shrink_PeerSelectionTargets,
) where
import Ouroboros.Network.PeerSelection.Governor
import Ouroboros.Network.PeerSelection.Types
import Test.QuickCheck
import Test.QuickCheck.Utils
--
-- QuickCheck instances
--
-- | Simple address representation for the tests
--
newtype PeerAddr = PeerAddr Int
deriving (Eq, Ord, Show)
-- | We mostly avoid using this instance since we need careful control over
-- the peer addrs, e.g. to make graphs work, and sets overlap etc. But it's
-- here for the few cases that need it, and it is used for (lack-of) shrinking.
--
instance Arbitrary PeerAddr where
arbitrary = PeerAddr <$> arbitrarySizedNatural
shrink _ = []
instance Arbitrary PeerAdvertise where
arbitrary = elements [ DoAdvertisePeer, DoNotAdvertisePeer ]
shrink DoAdvertisePeer = []
shrink DoNotAdvertisePeer = [DoAdvertisePeer]
instance Arbitrary PeerSelectionTargets where
arbitrary = do
targetNumberOfKnownPeers <- min 10000 . getNonNegative <$> arbitrary
targetNumberOfRootPeers <- choose (0, min 100 targetNumberOfKnownPeers)
targetNumberOfEstablishedPeers <- choose (0, min 1000 targetNumberOfKnownPeers)
targetNumberOfActivePeers <- choose (0, min 100 targetNumberOfEstablishedPeers)
return PeerSelectionTargets {
targetNumberOfRootPeers,
targetNumberOfKnownPeers,
targetNumberOfEstablishedPeers,
targetNumberOfActivePeers
}
shrink (PeerSelectionTargets r k e a) =
[ targets'
| (r',k',e',a') <- shrink (r,k,e,a)
, let targets' = PeerSelectionTargets r' k' e' a'
, sanePeerSelectionTargets targets' ]
prop_arbitrary_PeerSelectionTargets :: PeerSelectionTargets -> Bool
prop_arbitrary_PeerSelectionTargets =
sanePeerSelectionTargets
prop_shrink_PeerSelectionTargets :: Fixed PeerSelectionTargets -> Property
prop_shrink_PeerSelectionTargets x =
prop_shrink_valid sanePeerSelectionTargets x
.&&. prop_shrink_nonequal x