TestExe.hs (8109B)
1 -- Copyright 2023 The Plunder Authors 2 -- Use of this source code is governed by a BSD-style license that can be 3 -- found in the LICENSE file. 4 5 module Data.Sorted.TestExe (main) where 6 7 import ClassyPrelude 8 import Test.Tasty 9 import Test.Tasty.QuickCheck as QC 10 import Data.Sorted 11 12 import Optics (both, over) 13 14 import qualified Data.Set as S 15 import qualified Data.Map as M 16 17 -------------------------------------------------------------------------------- 18 19 tests :: TestTree 20 tests = testGroup "Sorted Array Operations" $ 21 [ setTests 22 , tabTests 23 ] 24 25 setTests :: TestTree 26 setTests = testGroup "Set Operations" $ 27 let 28 our :: [Int] -> ArraySet Int 29 our = setFromList 30 31 their :: [Int] -> S.Set Int 32 their = setFromList 33 in 34 [ QC.testProperty "sorting" \lis -> 35 toList (our lis) == toList (their lis) 36 37 , QC.testProperty "reversed" \lis -> 38 ssetToDescList (our lis) == S.toDescList (their lis) 39 40 , QC.testProperty "size" \lis -> 41 ssetSize (our lis) == S.size (their lis) 42 43 , QC.testProperty "union" \x y -> 44 (==) (toList $ ssetUnion (our x) (our y)) 45 (toList $ S.union (their x) (their y)) 46 47 , QC.testProperty "lookupMin" \xs -> 48 (==) (toList $ ssetLookupMin (our xs)) 49 (toList $ S.lookupMin (their xs)) 50 51 , QC.testProperty "lookupMax" \xs -> 52 (==) (toList $ ssetLookupMax (our xs)) 53 (toList $ S.lookupMax (their xs)) 54 55 , QC.testProperty "intersection" \x y -> 56 (==) (toList $ intersection (our x) (our y)) 57 (toList $ intersection (their x) (their y)) 58 59 , QC.testProperty "splitAt-0" \ks -> 60 (==) (over both toList $ ssetSplitAt 0 (our ks)) 61 (over both toList $ S.splitAt 0 (their ks)) 62 63 , QC.testProperty "splitAt-99" \ks -> 64 (==) (over both toList $ ssetSplitAt 99 (our ks)) 65 (over both toList $ S.splitAt 99 (their ks)) 66 67 , QC.testProperty "splitAt-center" \ks -> 68 let center = length ks `div` 2 in 69 (==) (over both toList $ ssetSplitAt center (our ks)) 70 (over both toList $ S.splitAt center (their ks)) 71 72 , QC.testProperty "ssetSpanAntitone-1" \k ks -> 73 (==) (over both toList $ ssetSpanAntitone (< k) (our (k:ks))) 74 (over both toList $ S.spanAntitone (< k) (their (k:ks))) 75 76 , QC.testProperty "ssetSpanAntitone-2" \k ks -> 77 (==) (over both toList $ ssetSpanAntitone (<= k) (our (k:ks))) 78 (over both toList $ S.spanAntitone (<= k) (their (k:ks))) 79 80 , QC.testProperty "ssetSpanAntitone-3" \k ks -> 81 (==) (over both toList $ ssetSpanAntitone (<= k) (our ks)) 82 (over both toList $ S.spanAntitone (<= k) (their ks)) 83 84 , QC.testProperty "difference" \x y -> 85 (==) (toList $ difference (our x) (our y)) 86 (toList $ difference (their x) (their y)) 87 88 , QC.testProperty "insert" \k ks -> 89 (==) (toList $ insertSet k $ our ks) 90 (toList $ insertSet k $ their ks) 91 92 , QC.testProperty "insert-existing" \k ks -> 93 (==) (toList $ insertSet k $ our (k:ks)) 94 (toList $ insertSet k $ their (k:ks)) 95 96 , QC.testProperty "delete" \k ks -> 97 (==) (toList $ deleteSet k (our ks)) 98 (toList $ deleteSet k (their ks)) 99 100 , QC.testProperty "delete-first" \k ks -> 101 (==) (toList $ deleteSet k (our (k:ks))) 102 (toList $ deleteSet k (their (k:ks))) 103 104 , QC.testProperty "has-0" \ks -> 105 member 0 (our ks) == member 0 (their ks) 106 107 , QC.testProperty "has-first" \k ks -> 108 let lis = k:ks 109 in member k (our lis) == member k (their lis) 110 ] 111 112 tabTests :: TestTree 113 tabTests = testGroup "Tab Operations" $ 114 let 115 our :: [(Int,Int)] -> Tab Int Int 116 our = mapFromList 117 118 their :: [(Int,Int)] -> M.Map Int Int 119 their = mapFromList 120 121 ok :: IsMap m => m -> [(ContainerKey m, MapValue m)] 122 ok = mapToList 123 in 124 [ QC.testProperty "singleton" \k v -> 125 (==) (ok (singletonMap k v :: Tab Int Int)) 126 (ok (singletonMap k v :: M.Map Int Int)) 127 128 , QC.testProperty "sort" \lis -> 129 ok (our lis) == ok (their lis) 130 131 , QC.testProperty "size" \lis -> 132 tabSize (our lis) == M.size (their lis) 133 134 , QC.testProperty "insert" \k v ps -> 135 ok (insertMap k v (our ps)) == ok (insertMap k v (their ps)) 136 137 , QC.testProperty "insert-first" \p@(k,v) ps -> 138 ok (insertMap k v (our (p:ps))) == ok (insertMap k v (their (p:ps))) 139 140 , QC.testProperty "lookup" \k ps -> 141 lookup k (our ps) == lookup k (their ps) 142 143 , QC.testProperty "lookup-first" \p@(k,_) ps -> 144 lookup k (our (p:ps)) == lookup k (their (p:ps)) 145 146 , QC.testProperty "delete-first" \k ps -> 147 ok (deleteMap k (our ps)) == ok (deleteMap k (their ps)) 148 149 , QC.testProperty "delete-first" \p@(k,_) ps -> 150 ok (deleteMap k (our (p:ps))) == ok (deleteMap k (their (p:ps))) 151 152 , QC.testProperty "split-at-0" \ps -> 153 (==) (over both ok $ tabSplitAt 0 $ our ps) 154 (over both ok $ M.splitAt 0 $ their ps) 155 156 , QC.testProperty "split-at-1" \ps -> 157 (==) (over both ok $ tabSplitAt 0 $ our ps) 158 (over both ok $ M.splitAt 0 $ their ps) 159 160 , QC.testProperty "split-at-20" \ps -> 161 (==) (over both ok $ tabSplitAt 10 $ our ps) 162 (over both ok $ M.splitAt 10 $ their ps) 163 164 , QC.testProperty "split-0" \ps -> 165 (==) (over both ok $ tabSplit 0 $ our ps) 166 (over both ok $ M.split 0 $ their ps) 167 168 , QC.testProperty "split-first" \p@(k,_) ps -> 169 (==) (over both ok $ tabSplit k $ our (p:ps)) 170 (over both ok $ M.split k $ their (p:ps)) 171 172 , QC.testProperty "span-first" \p@(k,_) ps -> 173 (==) (over both ok $ tabSpanAntitone (< k) $ our (p:ps)) 174 (over both ok $ M.spanAntitone (< k) $ their (p:ps)) 175 176 , QC.testProperty "span-first" \p@(k,_) ps -> 177 (==) (over both ok $ tabSpanAntitone (<= k) $ our (p:ps)) 178 (over both ok $ M.spanAntitone (<= k) $ their (p:ps)) 179 180 , QC.testProperty "map-with-key" \ps -> 181 (==) (ok $ tabMapWithKey (+) (our ps)) 182 (ok $ M.mapWithKey (+) (their ps)) 183 184 , QC.testProperty "map" \ps -> 185 (==) (ok $ succ <$> our ps) 186 (ok $ succ <$> their ps) 187 188 , QC.testProperty "union" \x y -> 189 (==) (ok $ union (our x) (our y)) 190 (ok $ union (their x) (their y)) 191 192 , QC.testProperty "union-with" \x y -> 193 (==) (ok $ tabUnionWith (\x y -> x + (x*y)) (our x) (our y)) 194 (ok $ M.unionWith (\x y -> x + (x*y)) (their x) (their y)) 195 196 , QC.testProperty "intersection" \x y -> 197 (==) (ok $ intersection (our x) (our y)) 198 (ok $ intersection (their x) (their y)) 199 200 , QC.testProperty "difference" \x y -> 201 (==) (ok $ difference (our x) (our y)) 202 (ok $ difference (their x) (their y)) 203 204 , QC.testProperty "tab-alter-const" \k v ps -> 205 (==) (ok $ alterMap (const v) k (our ps)) 206 (ok $ alterMap (const v) k (their ps)) 207 208 , QC.testProperty "tab-alter-existing" \v k ps -> 209 (==) (ok $ alterMap (const v) k (our ps)) 210 (ok $ alterMap (const v) k (their ps)) 211 212 , QC.testProperty "tab-map-with-key" \o ps -> 213 (==) (ok $ tabMapWithKey (\k v -> k+v+o) (our ps)) 214 (ok $ M.mapWithKey (\k v -> k+v+o) (their ps)) 215 216 , QC.testProperty "lookupMin" \ps -> 217 (==) (toList $ tabLookupMin (our ps)) 218 (toList $ M.lookupMin (their ps)) 219 220 , QC.testProperty "lookupMax" \ps -> 221 (==) (toList $ tabLookupMax (our ps)) 222 (toList $ M.lookupMax (their ps)) 223 224 , QC.testProperty "tabFoldlWithKey" \ps -> 225 (==) (tabFoldlWithKey' (\x k v -> (k,v):x) [] (our ps)) 226 (M.foldlWithKey (\x k v -> (k,v):x) [] (their ps)) 227 ] 228 229 -------------------------------------------------------------------------------- 230 231 main = defaultMain tests