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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
{-# LANGUAGE TemplateHaskell #-}
import Test.QuickCheck
import Test.QuickCheck.All
import Data.List (sort, group)
import Data.Maybe (isNothing, isJust)
import Bustle.Regions
instance Arbitrary Stripe where
arbitrary = do
top <- fmap abs arbitrary
bottom <- arbitrary `suchThat` (>= top)
return $ Stripe top bottom
newtype NonOverlappingStripes = NonOverlappingStripes [Stripe]
deriving
(Show, Eq, Ord)
instance Arbitrary NonOverlappingStripes where
arbitrary = do
-- there is no orderedList1 sadly
stripes <- fmap sort (listOf1 arbitrary) `suchThat` nonOverlapping
return $ NonOverlappingStripes stripes
newtype ValidRegions a = ValidRegions (Regions a)
deriving
(Show, Eq, Ord)
instance (Eq a, Arbitrary a) => Arbitrary (ValidRegions a) where
arbitrary = do
NonOverlappingStripes stripes <- arbitrary
values <- vector (length stripes) `suchThat` unique
return $ ValidRegions (zip stripes values)
where
unique xs = all (== 1) . map length . group $ xs
instance (Eq a, Arbitrary a) => Arbitrary (RegionSelection a) where
arbitrary = do
ValidRegions rs <- arbitrary
return $ regionSelectionNew rs
prop_InitiallyUnselected = \rs -> isNothing $ rsCurrent rs
prop_UpDoesNothing = \rs -> isNothing $ rsCurrent $ regionSelectionUp rs
prop_DownDoesNothing vr@(ValidRegions regions) =
withRegions vr $ \rs ->
let final = last regions
rs' = regionSelectionLast rs
in
rsCurrent (regionSelectionDown rs') == Just final
prop_DownWorks vr@(ValidRegions regions) =
withRegions vr $ \rs ->
rsCurrent (regionSelectionDown rs) == Just (head regions)
withRegions :: Testable t
=> ValidRegions a
-> (RegionSelection a -> t)
-> t
withRegions (ValidRegions regions) f = f (regionSelectionNew regions)
prop_UpdateToFirst :: (Eq a)
=> ValidRegions a
-> Bool
prop_UpdateToFirst vr@(ValidRegions regions) = withRegions vr $ \rs ->
Just first == rsCurrent (regionSelectionUpdate y rs) &&
null (rsBefore rs)
where
first@(Stripe top bottom, _) = head regions
y = (top + bottom) / 2
prop_SelectFirst :: (Eq a)
=> ValidRegions a
-> Bool
prop_SelectFirst vr@(ValidRegions regions) = withRegions vr $ \rs ->
Just (head regions) == rsCurrent (regionSelectionFirst rs)
prop_SelectLast :: (Eq a)
=> ValidRegions a
-> Bool
prop_SelectLast vr@(ValidRegions regions) = withRegions vr $ \rs ->
Just (last regions) == rsCurrent (regionSelectionLast rs)
prop_UpdateToAny :: (Eq a, Show a)
=> ValidRegions a
-> Property
prop_UpdateToAny vr@(ValidRegions regions) =
withRegions vr $ \rs ->
forAll (elements regions) $ \ r@(s, _) ->
rsCurrent (regionSelectionUpdate (midpoint s) rs) == Just r
shuffled :: [a] -> Gen [a]
shuffled [] = return []
shuffled xs = do
i <- choose (0, length xs - 1)
let x = xs !! i
pre = take i xs
post = drop (i + 1) xs
xs' <- shuffled (pre ++ post)
return (x:xs')
prop_UpdateToAll :: (Eq a, Show a)
=> ValidRegions a
-> Property
prop_UpdateToAll vr@(ValidRegions regions) =
withRegions vr $ \rs ->
forAll (shuffled regions) $ \regions' ->
updateAndForward rs regions'
where
updateAndForward rs [] = True
updateAndForward rs (x:xs) =
let rs' = regionSelectionUpdate (midpoint (fst x)) rs
in rsCurrent rs' == Just x && updateAndForward rs' xs
randomMutation :: Gen (RegionSelection a -> RegionSelection a)
randomMutation = do
y <- arbitrary
elements [ regionSelectionUp
, regionSelectionDown
, regionSelectionFirst
, regionSelectionLast
, regionSelectionUpdate y
]
randomMutations :: Gen (RegionSelection a -> RegionSelection a)
randomMutations = do
fs <- listOf randomMutation
return $ foldr (.) id fs
prop_ClickAlwaysInSelection = \rs ->
forAll (fmap Blind randomMutations) $ \(Blind f) ->
let
rs' = f rs
in
isJust (rsCurrent rs') ==>
let
Just (Stripe top bottom, _) = rsCurrent rs'
y = rsLastClick rs'
in
top <= y && y <= bottom
prop_SelectWorks :: (Eq a, Show a)
=> ValidRegions a
-> Property
prop_SelectWorks vr@(ValidRegions regions) =
withRegions vr $ \rs ->
forAll (elements regions) $ \ r@(s, x) ->
Just r == rsCurrent (regionSelectionSelect x rs)
prop_Append :: (Eq a, Show a)
=> ValidRegions a
-> Property
prop_Append vr@(ValidRegions regions) =
forAll (choose (0, length regions - 1)) $ \i ->
let as = take i regions
bs = drop i regions
in regionSelectionAppend bs (regionSelectionNew as) == regionSelectionNew regions
runTests = $quickCheckAll
main = do
runTests
return ()
|
