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