import Prelude hiding (lookup,map,filter,foldr,foldl,null)
import Data.Bits
import Data.Int
-import Data.Monoid
import qualified Data.IntSet as IntSet
+import Data.Typeable
{-
-- just for testing
import qualified List
-}
-#ifdef __GLASGOW_HASKELL__
-{--------------------------------------------------------------------
- GHC: use unboxing to get @shiftRL@ inlined.
---------------------------------------------------------------------}
+#if __GLASGOW_HASKELL__
+import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec)
+import Data.Generics.Basics
+import Data.Generics.Instances
+#endif
+
#if __GLASGOW_HASKELL__ >= 503
import GHC.Word
import GHC.Exts ( Word(..), Int(..), shiftRL# )
-#else
+#elif __GLASGOW_HASKELL__
import Word
import GlaExts ( Word(..), Int(..), shiftRL# )
+#else
+import Data.Word
#endif
infixl 9 \\{-This comment teaches CPP correct behaviour -}
+-- A "Nat" is a natural machine word (an unsigned Int)
type Nat = Word
natFromInt :: Key -> Nat
intFromNat w = fromIntegral w
shiftRL :: Nat -> Key -> Nat
-shiftRL (W# x) (I# i)
- = W# (shiftRL# x i)
-
-#elif __HUGS__
+#if __GLASGOW_HASKELL__
{--------------------------------------------------------------------
- Hugs:
- * raises errors on boundary values when using 'fromIntegral'
- but not with the deprecated 'fromInt/toInt'.
- * Older Hugs doesn't define 'Word'.
- * Newer Hugs defines 'Word' in the Prelude but no operations.
+ GHC: use unboxing to get @shiftRL@ inlined.
--------------------------------------------------------------------}
-import Data.Word
-infixl 9 \\
-
-type Nat = Word32 -- illegal on 64-bit platforms!
-
-natFromInt :: Key -> Nat
-natFromInt i = fromInt i
-
-intFromNat :: Nat -> Key
-intFromNat w = toInt w
-
-shiftRL :: Nat -> Key -> Nat
-shiftRL x i = shiftR x i
-
+shiftRL (W# x) (I# i)
+ = W# (shiftRL# x i)
#else
-{--------------------------------------------------------------------
- 'Standard' Haskell
- * A "Nat" is a natural machine word (an unsigned Int)
---------------------------------------------------------------------}
-import Data.Word
-infixl 9 \\
-
-type Nat = Word
-
-natFromInt :: Key -> Nat
-natFromInt i = fromIntegral i
-
-intFromNat :: Nat -> Key
-intFromNat w = fromIntegral w
-
-shiftRL :: Nat -> Key -> Nat
-shiftRL w i = shiftR w i
-
+shiftRL x i = shiftR x i
#endif
-
{--------------------------------------------------------------------
Operators
--------------------------------------------------------------------}
--- | /O(min(n,W))/. Find the value of a key. Calls @error@ when the element can not be found.
+-- | /O(min(n,W))/. Find the value at a key.
+-- Calls 'error' when the element can not be found.
(!) :: IntMap a -> Key -> a
m ! k = find' k m
type Mask = Int
type Key = Int
+#if __GLASGOW_HASKELL__
+
+{--------------------------------------------------------------------
+ A Data instance
+--------------------------------------------------------------------}
+
+-- This instance preserves data abstraction at the cost of inefficiency.
+-- We omit reflection services for the sake of data abstraction.
+
+instance Data a => Data (IntMap a) where
+ gfoldl f z im = z fromList `f` (toList im)
+ toConstr _ = error "toConstr"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNorepType "Data.IntMap.IntMap"
+
+#endif
+
{--------------------------------------------------------------------
Query
--------------------------------------------------------------------}
Nothing -> False
Just x -> True
--- | /O(min(n,W))/. Lookup the value of a key in the map.
+-- | /O(min(n,W))/. Lookup the value at a key in the map.
lookup :: Key -> IntMap a -> Maybe a
lookup k t
= let nk = natFromInt k in seq nk (lookupN nk t)
Just x -> x
--- | /O(min(n,W))/. The expression @(findWithDefault def k map)@ returns the value of key @k@ or returns @def@ when
--- the key is not an element of the map.
+-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@
+-- returns the value at key @k@ or returns @def@ when the key is not an
+-- element of the map.
findWithDefault :: a -> Key -> IntMap a -> a
findWithDefault def k m
= case lookup k m of
{--------------------------------------------------------------------
Insert
- 'insert' is the inlined version of 'insertWith (\k x y -> x)'
--------------------------------------------------------------------}
--- | /O(min(n,W))/. Insert a new key\/value pair in the map. When the key
--- is already an element of the set, its value is replaced by the new value,
--- ie. 'insert' is left-biased.
+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.
+-- If the key is already present in the map, the associated value is
+-- replaced with the supplied value, i.e. 'insert' is equivalent to
+-- @'insertWith' 'const'@.
insert :: Key -> a -> IntMap a -> IntMap a
insert k x t
= case t of
Nil -> Tip k x
--- | /O(min(n,W))/. The expression (@insertLookupWithKey f k x map@) is a pair where
--- the first element is equal to (@lookup k map@) and the second element
--- equal to (@insertWithKey f k x map@).
+-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)
+-- is a pair where the first element is equal to (@'lookup' k map@)
+-- and the second element equal to (@'insertWithKey' f k x map@).
insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)
insertLookupWithKey f k x t
= case t of
adjustWithKey f k m
= updateWithKey (\k x -> Just (f k x)) k m
--- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f x@) is @Nothing@, the element is
--- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a
update f k m
= updateWithKey (\k x -> f x) k m
--- | /O(min(n,W))/. The expression (@update f k map@) updates the value @x@
--- at @k@ (if it is in the map). If (@f k x@) is @Nothing@, the element is
--- deleted. If it is (@Just y@), the key @k@ is bound to the new value @y@.
+-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@
+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is
+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.
updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a
updateWithKey f k t
= case t of
unionsWith f ts
= foldlStrict (unionWith f) empty ts
--- | /O(n+m)/. The (left-biased) union of two sets.
+-- | /O(n+m)/. The (left-biased) union of two maps.
+-- It prefers the first map when duplicate keys are encountered,
+-- i.e. (@'union' == 'unionWith' 'const'@).
union :: IntMap a -> IntMap a -> IntMap a
union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = union1
-- | /O(n+m)/. Difference with a combining function. When two equal keys are
-- encountered, the combining function is applied to the key and both values.
--- If it returns @Nothing@, the element is discarded (proper set difference). If
--- it returns (@Just y@), the element is updated with a new value @y@.
+-- If it returns 'Nothing', the element is discarded (proper set difference).
+-- If it returns (@'Just' y@), the element is updated with a new value @y@.
differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a
differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)
| shorter m1 m2 = difference1
Submap
--------------------------------------------------------------------}
-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
--- Defined as (@isProperSubmapOf = isProperSubmapOfBy (==)@).
+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).
isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
isProperSubmapOf m1 m2
= isProperSubmapOfBy (==) m1 m2
{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).
- The expression (@isProperSubmapOfBy f m1 m2@) returns @True@ when
+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when
@m1@ and @m2@ are not equal,
- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
applied to their respective values. For example, the following
- expressions are all @True@.
+ expressions are all 'True':
> isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
> isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
- But the following are all @False@:
+ But the following are all 'False':
> isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
> isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])
submapCmp pred Nil Nil = EQ
submapCmp pred Nil t = LT
--- | /O(n+m)/. Is this a submap? Defined as (@isSubmapOf = isSubmapOfBy (==)@).
+-- | /O(n+m)/. Is this a submap?
+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).
isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool
isSubmapOf m1 m2
= isSubmapOfBy (==) m1 m2
{- | /O(n+m)/.
- The expression (@isSubmapOfBy f m1 m2@) returns @True@ if
- all keys in @m1@ are in @m2@, and when @f@ returns @True@ when
+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if
+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when
applied to their respective values. For example, the following
- expressions are all @True@.
+ expressions are all 'True':
> isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
> isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
> isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])
- But the following are all @False@:
+ But the following are all 'False':
> isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])
> isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])
Tip k x -> Tip k (f k x)
Nil -> Nil
--- | /O(n)/. The function @mapAccum@ threads an accumulating
--- argument through the map in an unspecified order.
+-- | /O(n)/. The function @'mapAccum'@ threads an accumulating
+-- argument through the map in ascending order of keys.
mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccum f a m
= mapAccumWithKey (\a k x -> f a x) a m
--- | /O(n)/. The function @mapAccumWithKey@ threads an accumulating
--- argument through the map in an unspecified order.
+-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating
+-- argument through the map in ascending order of keys.
mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccumWithKey f a t
= mapAccumL f a t
--- | /O(n)/. The function @mapAccumL@ threads an accumulating
--- argument through the map in pre-order.
+-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating
+-- argument through the map in ascending order of keys.
mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccumL f a t
= case t of
Nil -> (a,Nil)
--- | /O(n)/. The function @mapAccumR@ threads an accumulating
--- argument throught the map in post-order.
+-- | /O(n)/. The function @'mapAccumR'@ threads an accumulating
+-- argument throught the map in descending order of keys.
mapAccumR :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)
mapAccumR f a t
= case t of
Nil -> (Nil,Nil)
--- | /O(log n)/. The expression (@split k map@) is a pair @(map1,map2)@
+-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@
-- where all keys in @map1@ are lower than @k@ and all keys in
-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.
split :: Key -> IntMap a -> (IntMap a,IntMap a)
split k t
= case t of
Bin p m l r
+ | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)
| zero k m -> let (lt,gt) = split k l in (lt,union gt r)
| otherwise -> let (lt,gt) = split k r in (union l lt,gt)
Tip ky y
-- | /O(log n)/. Performs a 'split' but also returns whether the pivot
-- key was found in the original map.
-splitLookup :: Key -> IntMap a -> (Maybe a,IntMap a,IntMap a)
+splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
splitLookup k t
= case t of
Bin p m l r
- | zero k m -> let (found,lt,gt) = splitLookup k l in (found,lt,union gt r)
- | otherwise -> let (found,lt,gt) = splitLookup k r in (found,union l lt,gt)
+ | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)
+ | zero k m -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)
+ | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)
Tip ky y
- | k>ky -> (Nothing,t,Nil)
- | k<ky -> (Nothing,Nil,t)
- | otherwise -> (Just y,Nil,Nil)
- Nil -> (Nothing,Nil,Nil)
+ | k>ky -> (t,Nothing,Nil)
+ | k<ky -> (Nil,Nothing,t)
+ | otherwise -> (Nil,Just y,Nil)
+ Nil -> (Nil,Nothing,Nil)
{--------------------------------------------------------------------
Fold
--------------------------------------------------------------------}
--- | /O(n)/. Fold over the elements of a map in an unspecified order.
+-- | /O(n)/. Fold the values in the map, such that
+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.
+-- For example,
--
--- > sum map = fold (+) 0 map
-- > elems map = fold (:) [] map
+--
fold :: (a -> b -> b) -> b -> IntMap a -> b
fold f z t
= foldWithKey (\k x y -> f x y) z t
--- | /O(n)/. Fold over the elements of a map in an unspecified order.
+-- | /O(n)/. Fold the keys and values in the map, such that
+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.
+-- For example,
--
-- > keys map = foldWithKey (\k x ks -> k:ks) [] map
+--
foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b
foldWithKey f z t
= foldr f z t
{--------------------------------------------------------------------
List variations
--------------------------------------------------------------------}
--- | /O(n)/. Return all elements of the map.
+-- | /O(n)/.
+-- Return all elements of the map in the ascending order of their keys.
elems :: IntMap a -> [a]
elems m
= foldWithKey (\k x xs -> x:xs) [] m
--- | /O(n)/. Return all keys of the map.
+-- | /O(n)/. Return all keys of the map in ascending order.
keys :: IntMap a -> [Key]
keys m
= foldWithKey (\k x ks -> k:ks) [] m
keysSet m = IntSet.fromDistinctAscList (keys m)
--- | /O(n)/. Return all key\/value pairs in the map.
+-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.
assocs :: IntMap a -> [(Key,a)]
assocs m
= toList m
fmap = map
{--------------------------------------------------------------------
- Monoid
---------------------------------------------------------------------}
-
-instance Ord a => Monoid (IntMap a) where
- mempty = empty
- mappend = union
- mconcat = unions
-
-{--------------------------------------------------------------------
Show
--------------------------------------------------------------------}
instance Show a => Show (IntMap a) where
- showsPrec d t = showMap (toList t)
-
+ showsPrec d m = showParen (d > 10) $
+ showString "fromList " . shows (toList m)
showMap :: (Show a) => [(Key,a)] -> ShowS
showMap []
showTail (x:xs) = showChar ',' . showElem x . showTail xs
showElem (k,x) = shows k . showString ":=" . shows x
-
+
+{--------------------------------------------------------------------
+ Read
+--------------------------------------------------------------------}
+instance (Read e) => Read (IntMap e) where
+#ifdef __GLASGOW_HASKELL__
+ readPrec = parens $ prec 10 $ do
+ Ident "fromList" <- lexP
+ xs <- readPrec
+ return (fromList xs)
+#else
+ readsPrec p = readParen (p > 10) $ \ r -> do
+ ("fromList",s) <- lex
+ (xs,t) <- reads
+ return (fromList xs,t)
+#endif
+
+{--------------------------------------------------------------------
+ Typeable
+--------------------------------------------------------------------}
+
+#include "Typeable.h"
+INSTANCE_TYPEABLE1(IntMap,intMapTc,"IntMap")
+
{--------------------------------------------------------------------
Debugging
--------------------------------------------------------------------}
= showTreeWith True False s
-{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows
+{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
the tree that implements the map. If @hang@ is
- @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If
- @wide@ is true, an extra wide version is shown.
+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
+ @wide@ is 'True', an extra wide version is shown.
-}
showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
showTreeWith hang wide t
projects / ghc-base.git / blobdiff