Convert to cabal.project
[packages/containers.git] / containers-tests / benchmarks / Map.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE BangPatterns #-}
3 module Main where
4
5 import Control.Applicative (Const(Const, getConst), pure)
6 import Control.DeepSeq (rnf)
7 import Control.Exception (evaluate)
8 import Gauge (bench, defaultMain, whnf, nf)
9 import Data.Functor.Identity (Identity(..))
10 import Data.List (foldl')
11 import qualified Data.Map as M
12 import qualified Data.Map.Strict as MS
13 import Data.Map (alterF)
14 import Data.Maybe (fromMaybe)
15 import Data.Functor ((<$))
16 #if __GLASGOW_HASKELL__ >= 708
17 import Data.Coerce
18 #endif
19 import Prelude hiding (lookup)
20
21 main = do
22 let m = M.fromAscList elems :: M.Map Int Int
23 m_even = M.fromAscList elems_even :: M.Map Int Int
24 m_odd = M.fromAscList elems_odd :: M.Map Int Int
25 evaluate $ rnf [m, m_even, m_odd]
26 defaultMain
27 [ bench "lookup absent" $ whnf (lookup evens) m_odd
28 , bench "lookup present" $ whnf (lookup evens) m_even
29 , bench "map" $ whnf (M.map (+ 1)) m
30 , bench "map really" $ nf (M.map (+ 2)) m
31 , bench "<$" $ whnf ((1 :: Int) <$) m
32 , bench "<$ really" $ nf ((2 :: Int) <$) m
33 , bench "alterF lookup absent" $ whnf (atLookup evens) m_odd
34 , bench "alterF lookup present" $ whnf (atLookup evens) m_even
35 , bench "alterF no rules lookup absent" $ whnf (atLookupNoRules evens) m_odd
36 , bench "alterF no rules lookup present" $ whnf (atLookupNoRules evens) m_even
37 , bench "insert absent" $ whnf (ins elems_even) m_odd
38 , bench "insert present" $ whnf (ins elems_even) m_even
39 , bench "alterF insert absent" $ whnf (atIns elems_even) m_odd
40 , bench "alterF insert present" $ whnf (atIns elems_even) m_even
41 , bench "alterF no rules insert absent" $ whnf (atInsNoRules elems_even) m_odd
42 , bench "alterF no rules insert present" $ whnf (atInsNoRules elems_even) m_even
43 , bench "delete absent" $ whnf (del evens) m_odd
44 , bench "delete present" $ whnf (del evens) m
45 , bench "alterF delete absent" $ whnf (atDel evens) m_odd
46 , bench "alterF delete present" $ whnf (atDel evens) m
47 , bench "alterF no rules delete absent" $ whnf (atDelNoRules evens) m_odd
48 , bench "alterF no rules delete present" $ whnf (atDelNoRules evens) m
49 , bench "alter absent" $ whnf (alt id evens) m_odd
50 , bench "alter insert" $ whnf (alt (const (Just 1)) evens) m_odd
51 , bench "alter update" $ whnf (alt id evens) m_even
52 , bench "alter delete" $ whnf (alt (const Nothing) evens) m
53 , bench "alterF alter absent" $ whnf (atAlt id evens) m_odd
54 , bench "alterF alter insert" $ whnf (atAlt (const (Just 1)) evens) m_odd
55 , bench "alterF alter update" $ whnf (atAlt id evens) m_even
56 , bench "alterF alter delete" $ whnf (atAlt (const Nothing) evens) m
57 , bench "alterF no rules alter absent" $ whnf (atAltNoRules id evens) m_odd
58 , bench "alterF no rules alter insert" $ whnf (atAltNoRules (const (Just 1)) evens) m_odd
59 , bench "alterF no rules alter update" $ whnf (atAltNoRules id evens) m_even
60 , bench "alterF no rules alter delete" $ whnf (atAltNoRules (const Nothing) evens) m
61 , bench "insertWith absent" $ whnf (insWith elems_even) m_odd
62 , bench "insertWith present" $ whnf (insWith elems_even) m_even
63 , bench "insertWith' absent" $ whnf (insWith' elems_even) m_odd
64 , bench "insertWith' present" $ whnf (insWith' elems_even) m_even
65 , bench "insertWithKey absent" $ whnf (insWithKey elems_even) m_odd
66 , bench "insertWithKey present" $ whnf (insWithKey elems_even) m_even
67 , bench "insertWithKey' absent" $ whnf (insWithKey' elems_even) m_odd
68 , bench "insertWithKey' present" $ whnf (insWithKey' elems_even) m_even
69 , bench "insertLookupWithKey absent" $ whnf (insLookupWithKey elems_even) m_odd
70 , bench "insertLookupWithKey present" $ whnf (insLookupWithKey elems_even) m_even
71 , bench "insertLookupWithKey' absent" $ whnf (insLookupWithKey' elems_even) m_odd
72 , bench "insertLookupWithKey' present" $ whnf (insLookupWithKey' elems_even) m_even
73 , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m
74 , bench "foldlWithKey" $ whnf (ins elems) m
75 -- , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m
76 , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m
77 , bench "update absent" $ whnf (upd Just evens) m_odd
78 , bench "update present" $ whnf (upd Just evens) m_even
79 , bench "update delete" $ whnf (upd (const Nothing) evens) m
80 , bench "updateLookupWithKey absent" $ whnf (upd' Just evens) m_odd
81 , bench "updateLookupWithKey present" $ whnf (upd' Just evens) m_even
82 , bench "updateLookupWithKey delete" $ whnf (upd' (const Nothing) evens) m
83 , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m
84 , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m
85 , bench "lookupIndex" $ whnf (lookupIndex keys) m
86 , bench "union" $ whnf (M.union m_even) m_odd
87 , bench "difference" $ whnf (M.difference m) m_even
88 , bench "intersection" $ whnf (M.intersection m) m_even
89 , bench "split" $ whnf (M.split (bound `div` 2)) m
90 , bench "fromList" $ whnf M.fromList elems
91 , bench "fromList-desc" $ whnf M.fromList (reverse elems)
92 , bench "fromAscList" $ whnf M.fromAscList elems
93 , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems
94 , bench "minView" $ whnf (\m' -> case M.minViewWithKey m' of {Nothing -> 0; Just ((k,v),m'') -> k+v+M.size m''}) (M.fromAscList $ zip [1..10::Int] [100..110::Int])
95 ]
96 where
97 bound = 2^12
98 elems = zip keys values
99 elems_even = zip evens evens
100 elems_odd = zip odds odds
101 keys = [1..bound]
102 evens = [2,4..bound]
103 odds = [1,3..bound]
104 values = [1..bound]
105 sum k v1 v2 = k + v1 + v2
106 consPair k v xs = (k, v) : xs
107
108 add3 :: Int -> Int -> Int -> Int
109 add3 x y z = x + y + z
110 {-# INLINE add3 #-}
111
112 lookup :: [Int] -> M.Map Int Int -> Int
113 lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs
114
115 atLookup :: [Int] -> M.Map Int Int -> Int
116 atLookup xs m = foldl' (\n k -> fromMaybe n (getConst (alterF Const k m))) 0 xs
117
118 newtype Consty a b = Consty { getConsty :: a }
119 instance Functor (Consty a) where
120 fmap _ (Consty a) = Consty a
121
122 atLookupNoRules :: [Int] -> M.Map Int Int -> Int
123 atLookupNoRules xs m = foldl' (\n k -> fromMaybe n (getConsty (alterF Consty k m))) 0 xs
124
125 lookupIndex :: [Int] -> M.Map Int Int -> Int
126 lookupIndex xs m = foldl' (\n k -> fromMaybe n (M.lookupIndex k m)) 0 xs
127
128 ins :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
129 ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs
130
131 atIns :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
132 atIns xs m = foldl' (\m (k, v) -> runIdentity (alterF (\_ -> Identity (Just v)) k m)) m xs
133
134 newtype Ident a = Ident { runIdent :: a }
135 instance Functor Ident where
136 #if __GLASGOW_HASKELL__ >= 708
137 fmap = coerce
138 #else
139 fmap f (Ident a) = Ident (f a)
140 #endif
141
142 atInsNoRules :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
143 atInsNoRules xs m = foldl' (\m (k, v) -> runIdent (alterF (\_ -> Ident (Just v)) k m)) m xs
144
145 insWith :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
146 insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs
147
148 insWithKey :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
149 insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs
150
151 insWith' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
152 insWith' xs m = foldl' (\m (k, v) -> MS.insertWith (+) k v m) m xs
153
154 insWithKey' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
155 insWithKey' xs m = foldl' (\m (k, v) -> MS.insertWithKey add3 k v m) m xs
156
157 data PairS a b = PS !a !b
158
159 insLookupWithKey :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)
160 insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
161 where
162 f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m
163 in PS (fromMaybe 0 n' + n) m'
164
165 insLookupWithKey' :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)
166 insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
167 where
168 f (PS n m) (k, v) = let !(n', m') = MS.insertLookupWithKey add3 k v m
169 in PS (fromMaybe 0 n' + n) m'
170
171 del :: [Int] -> M.Map Int Int -> M.Map Int Int
172 del xs m = foldl' (\m k -> M.delete k m) m xs
173
174 atDel :: [Int] -> M.Map Int Int -> M.Map Int Int
175 atDel xs m = foldl' (\m k -> runIdentity (alterF (\_ -> Identity Nothing) k m)) m xs
176
177 atDelNoRules :: [Int] -> M.Map Int Int -> M.Map Int Int
178 atDelNoRules xs m = foldl' (\m k -> runIdent (alterF (\_ -> Ident Nothing) k m)) m xs
179
180 upd :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
181 upd f xs m = foldl' (\m k -> M.update f k m) m xs
182
183 upd' :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
184 upd' f xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> f a) k m) m xs
185
186 alt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
187 alt f xs m = foldl' (\m k -> M.alter f k m) m xs
188
189 atAlt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
190 atAlt f xs m = foldl' (\m k -> runIdentity (alterF (Identity . f) k m)) m xs
191
192 atAltNoRules :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int
193 atAltNoRules f xs m = foldl' (\m k -> runIdent (alterF (Ident . f) k m)) m xs
194
195 maybeDel :: Int -> Maybe Int
196 maybeDel n | n `mod` 3 == 0 = Nothing
197 | otherwise = Just n