X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FIntMap.hs;h=daf85a0afc48cf3155fce2bef69d086119f06539;hb=5d30f3426e4153aebb7022f7dbda05647a3cb891;hp=1e8c3e4aa6b4c8727f421029a12db310c19f2b9a;hpb=f3cd46e9212873a023ba04263f0c9c488e57f356;p=haskell-directory.git

diff --git a/Data/IntMap.hs b/Data/IntMap.hs
index 1e8c3e4..daf85a0 100644
--- a/Data/IntMap.hs
+++ b/Data/IntMap.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -cpp -fglasgow-exts #-} 
+{-# OPTIONS -cpp -fglasgow-exts -fno-bang-patterns #-} 
 -----------------------------------------------------------------------------
 -- Module      :  Data.IntMap
 -- Copyright   :  (c) Daan Leijen 2002
@@ -45,6 +45,7 @@ module Data.IntMap  (
             , null
             , size
             , member
+            , notMember
 	    , lookup
             , findWithDefault
             
@@ -63,6 +64,7 @@ module Data.IntMap  (
             , update
             , updateWithKey
             , updateLookupWithKey
+            , alter
   
             -- * Combine
 
@@ -119,6 +121,11 @@ module Data.IntMap  (
             , partition
             , partitionWithKey
 
+            , mapMaybe
+            , mapMaybeWithKey
+            , mapEither
+            , mapEitherWithKey
+
             , split         
             , splitLookup   
 
@@ -135,9 +142,10 @@ module Data.IntMap  (
 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.Monoid (Monoid(..))
 import Data.Typeable
+import Data.Foldable (Foldable(foldMap))
 
 {-
 -- just for testing
@@ -148,6 +156,7 @@ import qualified List
 -}  
 
 #if __GLASGOW_HASKELL__
+import Text.Read
 import Data.Generics.Basics
 import Data.Generics.Instances
 #endif
@@ -210,6 +219,16 @@ type Prefix = Int
 type Mask   = Int
 type Key    = Int
 
+instance Monoid (IntMap a) where
+    mempty  = empty
+    mappend = union
+    mconcat = unions
+
+instance Foldable IntMap where
+    foldMap f Nil = mempty
+    foldMap f (Tip _k v) = f v
+    foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r
+
 #if __GLASGOW_HASKELL__
 
 {--------------------------------------------------------------------
@@ -224,6 +243,7 @@ instance Data a => Data (IntMap a) where
   toConstr _    = error "toConstr"
   gunfold _ _   = error "gunfold"
   dataTypeOf _  = mkNorepType "Data.IntMap.IntMap"
+  dataCast1 f   = gcast1 f
 
 #endif
 
@@ -250,9 +270,18 @@ member k m
       Nothing -> False
       Just x  -> True
     
+-- | /O(log n)/. Is the key not a member of the map?
+notMember :: Key -> IntMap a -> Bool
+notMember k m = not $ member k m
+
 -- | /O(min(n,W))/. Lookup the value at a key in the map.
-lookup :: Key -> IntMap a -> Maybe a
-lookup k t
+lookup :: (Monad m) => Key -> IntMap a -> m a
+lookup k t = case lookup' k t of
+    Just x -> return x
+    Nothing -> fail "Data.IntMap.lookup: Key not found"
+
+lookup' :: Key -> IntMap a -> Maybe a
+lookup' k t
   = let nk = natFromInt k  in seq nk (lookupN nk t)
 
 lookupN :: Nat -> IntMap a -> Maybe a
@@ -297,11 +326,11 @@ singleton k x
 
 {--------------------------------------------------------------------
   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
@@ -316,11 +345,19 @@ insert k x t
 
 -- right-biased insertion, used by 'union'
 -- | /O(min(n,W))/. Insert with a combining function.
+-- @'insertWith' f key value mp@ 
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert @f new_value old_value@.
 insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
 insertWith f k x t
   = insertWithKey (\k x y -> f x y) k x t
 
 -- | /O(min(n,W))/. Insert with a combining function.
+-- @'insertWithKey' f key value mp@ 
+-- will insert the pair (key, value) into @mp@ if key does
+-- not exist in the map. If the key does exist, the function will
+-- insert @f key new_value old_value@.
 insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a
 insertWithKey f k x t
   = case t of
@@ -420,6 +457,30 @@ updateLookupWithKey f k t
       Nil -> (Nothing,Nil)
 
 
+
+-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.
+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.
+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@
+alter f k t
+  = case t of
+      Bin p m l r 
+        | nomatch k p m -> case f Nothing of 
+                             Nothing -> t
+                             Just x -> join k (Tip k x) p t
+        | zero k m      -> bin p m (alter f k l) r
+        | otherwise     -> bin p m l (alter f k r)
+      Tip ky y          
+        | k==ky         -> case f (Just y) of
+                             Just x -> Tip ky x
+                             Nothing -> Nil
+        | otherwise     -> case f Nothing of
+                             Just x -> join k (Tip k x) ky t
+                             Nothing -> Tip ky y
+      Nil               -> case f Nothing of
+                             Just x -> Tip k x
+                             Nothing -> Nil
+
+
 {--------------------------------------------------------------------
   Union
 --------------------------------------------------------------------}
@@ -433,7 +494,9 @@ unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a
 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
@@ -789,6 +852,36 @@ partitionWithKey pred t
         | otherwise -> (Nil,t)
       Nil -> (Nil,Nil)
 
+-- | /O(n)/. Map values and collect the 'Just' results.
+mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b
+mapMaybe f m
+  = mapMaybeWithKey (\k x -> f x) m
+
+-- | /O(n)/. Map keys\/values and collect the 'Just' results.
+mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b
+mapMaybeWithKey f (Bin p m l r)
+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)
+mapMaybeWithKey f (Tip k x) = case f k x of
+  Just y  -> Tip k y
+  Nothing -> Nil
+mapMaybeWithKey f Nil = Nil
+
+-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.
+mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
+mapEither f m
+  = mapEitherWithKey (\k x -> f x) m
+
+-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.
+mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)
+mapEitherWithKey f (Bin p m l r)
+  = (bin p m l1 r1, bin p m l2 r2)
+  where
+    (l1,l2) = mapEitherWithKey f l
+    (r1,r2) = mapEitherWithKey f r
+mapEitherWithKey f (Tip k x) = case f k x of
+  Left y  -> (Tip k y, Nil)
+  Right z -> (Nil, Tip k z)
+mapEitherWithKey f Nil = (Nil, Nil)
 
 -- | /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
@@ -796,7 +889,22 @@ partitionWithKey pred t
 split :: Key -> IntMap a -> (IntMap a,IntMap a)
 split k t
   = case t of
+      Bin p m l r 
+          | m < 0 -> (if k >= 0 -- handle negative numbers.
+                      then let (lt,gt) = split' k l in (union r lt, gt)
+                      else let (lt,gt) = split' k r in (lt, union gt l))
+          | otherwise   -> split' k t
+      Tip ky y 
+        | k>ky      -> (t,Nil)
+        | k<ky      -> (Nil,t)
+        | otherwise -> (Nil,Nil)
+      Nil -> (Nil,Nil)
+
+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 
@@ -807,17 +915,32 @@ split k t
 
 -- | /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)
+          | m < 0 -> (if k >= 0 -- handle negative numbers.
+                      then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)
+                      else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))
+          | otherwise   -> splitLookup' k t
       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)
+
+splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)
+splitLookup' k t
+  = case t of
+      Bin p m l r
+        | 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      -> (t,Nothing,Nil)
+        | k<ky      -> (Nil,Nothing,t)
+        | otherwise -> (Nil,Just y,Nil)
+      Nil -> (Nil,Nothing,Nil)
 
 {--------------------------------------------------------------------
   Fold
@@ -845,10 +968,20 @@ foldWithKey f z t
 foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b
 foldr f z t
   = case t of
-      Bin p m l r -> foldr f (foldr f z r) l
+      Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r  -- put negative numbers before.
+      Bin _ _ _ _ -> foldr' f z t
+      Tip k x     -> f k x z
+      Nil         -> z
+
+foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b
+foldr' f z t
+  = case t of
+      Bin p m l r -> foldr' f (foldr' f z r) l
       Tip k x     -> f k x z
       Nil         -> z
 
+
+
 {--------------------------------------------------------------------
   List variations 
 --------------------------------------------------------------------}
@@ -971,21 +1104,12 @@ instance Functor IntMap where
     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 []     
@@ -997,7 +1121,25 @@ showMap (x:xs)
     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)
+
+  readListPrec = readListPrecDefault
+#else
+  readsPrec p = readParen (p > 10) $ \ r -> do
+    ("fromList",s) <- lex r
+    (xs,t) <- reads s
+    return (fromList xs,t)
+#endif
+
 {--------------------------------------------------------------------
   Typeable
 --------------------------------------------------------------------}