@@ -3,9 +3,9 @@
33{-# LANGUAGE DeriveFunctor #-}
44{-# LANGUAGE FlexibleInstances #-}
55
6−-- | An 'OMap' behaves much like a 'M.Map', with mostly the same asymptotics, but
6+-- | An 'OMap' behaves much like a 'Map', with mostly the same asymptotics, but
77-- also remembers the order that keys were inserted. All operations whose
8−-- asymptotics are worse than 'M.Map' have documentation saying so.
8+-- asymptotics are worse than 'Map' have documentation saying so.
99module Data.Map.Ordered
1010 ( OMap
1111 -- * Trivial maps
@@ -32,11 +32,237 @@ module Data.Map.Ordered
3232 , Index, findIndex, elemAt
3333 -- * List conversions
3434 , fromList, assocs, toAscList
35− -- * 'M.Map' conversion
36− , toMap
3735 ) where
3836
39−import qualified Data.Map as M ()
40−import Data.Map.Ordered.Internal
37+import Control.Applicative ((<|>))
38+import Control.Monad (guard)
39+import Data.Data
40+import Data.Foldable (Foldable, foldl', foldMap)
41+import Data.Function (on)
42+import Data.Map (Map)
4143import Data.Map.Util
44+import Data.Monoid
45+#if MIN_VERSION_base(4,9,0)
46+import Data.Semigroup
47+#endif
4248import Prelude hiding (filter, lookup, null)
49+import qualified Data.Map as M
50+
51+data OMap k v = OMap !(Map k (Tag, v)) !(Map Tag (k, v))
52+ deriving (Functor, Typeable)
53+
54+-- | Values are produced in insertion order, not key order.
55+instance Foldable (OMap k) where foldMap f (OMap _ kvs) = foldMap (f . snd) kvs
56+instance ( Eq k, Eq v) => Eq (OMap k v) where (==) = (==) `on` assocs
57+instance ( Ord k, Ord v) => Ord (OMap k v) where compare = compare `on` assocs
58+instance ( Show k, Show v) => Show (OMap k v) where showsPrec = showsPrecList assocs
59+instance (Ord k, Read k, Read v) => Read (OMap k v) where readsPrec = readsPrecList fromList
60+
61+-- This instance preserves data abstraction at the cost of inefficiency.
62+-- We provide limited reflection services for the sake of data abstraction.
63+instance (Data k, Data a, Ord k) => Data (OMap k a) where
64+ gfoldl f z m = z fromList `f` assocs m
65+ toConstr _ = fromListConstr
66+ gunfold k z c = case constrIndex c of
67+ 1 -> k (z fromList)
68+ _ -> error "gunfold"
69+ dataTypeOf _ = oMapDataType
70+ dataCast2 = gcast2
71+
72+fromListConstr :: Constr
73+fromListConstr = mkConstr oMapDataType "fromList" [] Prefix
74+
75+oMapDataType :: DataType
76+oMapDataType = mkDataType "Data.Map.Ordered.Map" [fromListConstr]
77+
78+#if MIN_VERSION_base(4,9,0)
79+instance (Ord k, Semigroup v) => Semigroup (Bias L (OMap k v)) where
80+ Bias o <> Bias o' = Bias (unionWithL (const (<>)) o o')
81+instance (Ord k, Semigroup v) => Semigroup (Bias R (OMap k v)) where
82+ Bias o <> Bias o' = Bias (unionWithR (const (<>)) o o')
83+#endif
84+
85+-- | Empty maps and map union. When combining two sets that share elements, the
86+-- indices of the left argument are preferred, and the values are combined with
87+-- 'mappend'.
88+--
89+-- See the asymptotics of 'unionWithL'.
90+instance (Ord k, Monoid v) => Monoid (Bias L (OMap k v)) where
91+ mempty = Bias empty
92+ mappend (Bias o) (Bias o') = Bias (unionWithL (const mappend) o o')
93+
94+-- | Empty maps and map union. When combining two sets that share elements, the
95+-- indices of the right argument are preferred, and the values are combined
96+-- with 'mappend'.
97+--
98+-- See the asymptotics of 'unionWithR'.
99+instance (Ord k, Monoid v) => Monoid (Bias R (OMap k v)) where
100+ mempty = Bias empty
101+ mappend (Bias o) (Bias o') = Bias (unionWithR (const mappend) o o')
102+
103+-- | Values are traversed in insertion order, not key order.
104+--
105+-- /O(n*log(n))/ where /n/ is the size of the map.
106+instance Ord k => Traversable (OMap k) where
107+ traverse f (OMap tvs kvs) = fromKV <$> traverse (\(k,v) -> (,) k <$> f v) kvs
108+
109+infixr 5 <|, |< -- copy :
110+infixl 5 >|, |>
111+infixr 6 <>|, |<> -- copy <>
112+
113+(<|) , (|<) :: Ord k => (,) k v -> OMap k v -> OMap k v
114+(>|) , (|>) :: Ord k => OMap k v -> (,) k v -> OMap k v
115+
116+-- | When a key occurs in both maps, prefer the value from the first map.
117+--
118+-- See asymptotics of 'unionWithR'.
119+(<>|) :: Ord k => OMap k v -> OMap k v -> OMap k v
120+
121+-- | When a key occurs in both maps, prefer the value from the first map.
122+--
123+-- See asymptotics of 'unionWithL'.
124+(|<>) :: Ord k => OMap k v -> OMap k v -> OMap k v
125+
126+(k, v) <| OMap tvs kvs = OMap (M.insert k (t, v) tvs) (M.insert t (k, v) kvs) where
127+ t = maybe (nextLowerTag kvs) fst (M.lookup k tvs)
128+
129+(k, v) |< o = OMap (M.insert k (t, v) tvs) (M.insert t (k, v) kvs) where
130+ t = nextLowerTag kvs
131+ OMap tvs kvs = delete k o
132+
133+o >| (k, v) = OMap (M.insert k (t, v) tvs) (M.insert t (k, v) kvs) where
134+ t = nextHigherTag kvs
135+ OMap tvs kvs = delete k o
136+
137+OMap tvs kvs |> (k, v) = OMap (M.insert k (t, v) tvs) (M.insert t (k, v) kvs) where
138+ t = maybe (nextHigherTag kvs) fst (M.lookup k tvs)
139+
140+(<>|) = unionWithR (const const)
141+(|<>) = unionWithL (const const)
142+
143+-- | Take the union. The first 'OMap' \'s argument's indices are lower than the
144+-- second. If a key appears in both maps, the first argument's index takes
145+-- precedence, and the supplied function is used to combine the values.
146+--
147+-- /O(r*log(r))/ where /r/ is the size of the result
148+unionWithL :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v
149+unionWithL = unionWithInternal (\t t' -> t )
150+
151+-- | Take the union. The first 'OMap' \'s argument's indices are lower than the
152+-- second. If a key appears in both maps, the second argument's index takes
153+-- precedence, and the supplied function is used to combine the values.
154+--
155+-- /O(r*log(r))/ where /r/ is the size of the result
156+unionWithR :: Ord k => (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v
157+unionWithR = unionWithInternal (\t t' -> t')
158+
159+unionWithInternal :: Ord k => (Tag -> Tag -> Tag) -> (k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v
160+unionWithInternal fT fKV (OMap tvs kvs) (OMap tvs' kvs') = fromTV tvs'' where
161+ bump = case maxTag kvs of
162+ Nothing -> 0
163+ Just k -> -k-1
164+ bump' = case minTag kvs' of
165+ Nothing -> 0
166+ Just k -> -k
167+ tvs'' = M.unionWithKey (\k (t,v) (t',v') -> (fT t t', fKV k v v'))
168+ (fmap (\(t,v) -> (bump +t,v)) tvs )
169+ (fmap (\(t,v) -> (bump'+t,v)) tvs')
170+
171+-- | @m \\\\ n@ deletes all the keys that exist in @n@ from @m@
172+--
173+-- /O(m*log(n))/ where /m/ is the size of the smaller map and /n/ is the size
174+-- of the larger map.
175+(\\) :: Ord k => OMap k v -> OMap k v' -> OMap k v
176+o@(OMap tvs kvs) \\ o'@(OMap tvs' kvs') = if size o < size o'
177+ then filter (const . (`notMember` o')) o
178+ else foldr delete o (fmap fst (assocs o'))
179+
180+empty :: OMap k v
181+empty = OMap M.empty M.empty
182+
183+singleton :: (k, v) -> OMap k v
184+singleton kv@(k, v) = OMap (M.singleton k (0, v)) (M.singleton 0 kv)
185+
186+-- | If a key appears multiple times, the first occurrence is used for ordering
187+-- and the last occurrence is used for its value. The library author welcomes
188+-- comments on whether this default is sane.
189+fromList :: Ord k => [(k, v)] -> OMap k v
190+fromList = foldl' (|>) empty
191+
192+null :: OMap k v -> Bool
193+null (OMap tvs _) = M.null tvs
194+
195+size :: OMap k v -> Int
196+size (OMap tvs _) = M.size tvs
197+
198+member, notMember :: Ord k => k -> OMap k v -> Bool
199+member k (OMap tvs _) = M.member k tvs
200+notMember k (OMap tvs _) = M.notMember k tvs
201+
202+lookup :: Ord k => k -> OMap k v -> Maybe v
203+lookup k (OMap tvs _) = fmap snd (M.lookup k tvs)
204+
205+-- The Ord constraint is for compatibility with older (<0.5) versions of
206+-- containers.
207+-- | @filter f m@ contains exactly the key-value pairs of @m@ that satisfy @f@,
208+-- without changing the order they appear
209+filter :: Ord k => (k -> v -> Bool) -> OMap k v -> OMap k v
210+filter f (OMap tvs kvs) = OMap (M.filterWithKey (\k (t, v) -> f k v) tvs)
211+ (M.filterWithKey (\t (k, v) -> f k v) kvs)
212+
213+delete :: Ord k => k -> OMap k v -> OMap k v
214+delete k o@(OMap tvs kvs) = case M.lookup k tvs of
215+ Nothing -> o
216+ Just (t, _) -> OMap (M.delete k tvs) (M.delete t kvs)
217+
218+-- | Intersection. (The @/\\@ is intended to look a bit like the standard
219+-- mathematical notation for set intersection.)
220+--
221+-- See asymptotics of 'intersectionWith'.
222+(/\|) :: Ord k => OMap k v -> OMap k v' -> OMap k v
223+o /\| o' = intersectionWith (\k v' v -> v) o' o
224+
225+-- | Intersection. (The @/\\@ is intended to look a bit like the standard
226+-- mathematical notation for set intersection.)
227+--
228+-- See asymptotics of 'intersectionWith'.
229+(|/\) :: Ord k => OMap k v -> OMap k v' -> OMap k v
230+o |/\ o' = intersectionWith (\k v v' -> v) o o'
231+
232+-- | Take the intersection. The first 'OMap' \'s argument's indices are used for
233+-- the result.
234+--
235+-- /O(m*log(n\/(m+1)) + r*log(r))/ where /m/ is the size of the smaller map, /n/
236+-- is the size of the larger map, and /r/ is the size of the result.
237+intersectionWith ::
238+ Ord k =>
239+ (k -> v -> v' -> v'') ->
240+ OMap k v -> OMap k v' -> OMap k v''
241+intersectionWith f (OMap tvs kvs) (OMap tvs' kvs') = fromTV
242+ $ M.intersectionWithKey (\k (t,v) (t',v') -> (t, f k v v')) tvs tvs'
243+
244+fromTV :: Ord k => Map k (Tag, v) -> OMap k v
245+fromTV tvs = OMap tvs kvs where
246+ kvs = M.fromList [(t,(k,v)) | (k,(t,v)) <- M.toList tvs]
247+
248+fromKV :: Ord k => Map Tag (k, v) -> OMap k v
249+fromKV kvs = OMap tvs kvs where
250+ tvs = M.fromList [(k,(t,v)) | (t,(k,v)) <- M.toList kvs]
251+
252+findIndex :: Ord k => k -> OMap k v -> Maybe Index
253+findIndex k o@(OMap tvs kvs) = do
254+ (t, _) <- M.lookup k tvs
255+ M.lookupIndex t kvs
256+
257+elemAt :: OMap k v -> Index -> Maybe (k, v)
258+elemAt o@(OMap tvs kvs) i = do
259+ guard (0 <= i && i < M.size kvs)
260+ return . snd $ M.elemAt i kvs
261+
262+-- | Return key-value pairs in the order they were inserted.
263+assocs :: OMap k v -> [(k, v)]
264+assocs (OMap _ kvs) = map snd $ M.toAscList kvs
265+
266+-- | Return key-value pairs in order of increasing key.
267+toAscList :: OMap k v -> [(k, v)]
268+toAscList (OMap tvs kvs) = map (\(k, (t, v)) -> (k, v)) $ M.toAscList tvs