[project @ 2005-12-01 12:32:24 by simonmar]

[haskell-directory.git] / Data / Map.hs

diff --git a/Data/Map.hs b/Data/Map.hs
index 6f11db1..da12f9d 100644 (file)
--- a/Data/Map.hs
+++ b/Data/Map.hs
@@ -150,7 +150,11 @@ module Data.Map  (
 import Prelude hiding (lookup,map,filter,foldr,foldl,null)
 import qualified Data.Set as Set
 import qualified Data.List as List
+import Data.Monoid (Monoid(..))
 import Data.Typeable
+import Control.Applicative (Applicative(..))
+import Data.Traversable (Traversable(traverse))
+import Data.Foldable (Foldable(foldMap))
 
 {-
 -- for quick check
@@ -161,6 +165,7 @@ import List(nub,sort)
 -}
 
 #if __GLASGOW_HASKELL__
+import Text.Read
 import Data.Generics.Basics
 import Data.Generics.Instances
 #endif
@@ -188,6 +193,11 @@ data Map k a  = Tip
 
 type Size     = Int
 
+instance (Ord k) => Monoid (Map k v) where
+    mempty  = empty
+    mappend = union
+    mconcat = unions
+
 #if __GLASGOW_HASKELL__
 
 {--------------------------------------------------------------------
@@ -294,11 +304,19 @@ insert kx x t
                EQ -> Bin sz kx x l r
 
 -- | /O(log n)/. 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 :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
 insertWith f k x m          
   = insertWithKey (\k x y -> f x y) k x m
 
 -- | /O(log n)/. 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 :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a
 insertWithKey f kx x t
   = case t of
@@ -1304,20 +1322,33 @@ instance (Ord k, Ord v) => Ord (Map k v) where
 instance Functor (Map k) where
   fmap f m  = map f m
 
+instance Traversable (Map k) where
+  traverse f Tip = pure Tip
+  traverse f (Bin s k v l r)
+    = flip (Bin s k) <$> traverse f l <*> f v <*> traverse f r
+
+instance Foldable (Map k) where
+  foldMap _f Tip = mempty
+  foldMap f (Bin _s _k v l r)
+    = foldMap f l `mappend` f v `mappend` foldMap f r
+
 {--------------------------------------------------------------------
   Read
 --------------------------------------------------------------------}
 instance (Ord k, Read k, Read e) => Read (Map k e) where
-    readsPrec _ = readParen False $ \ r ->
-                  [(fromList xs,t) | ("{",s) <- lex r
-                                   , (xs,t)  <- readl s]
-        where readl s  = [([],t)   | ("}",t) <- lex s] ++
-                         [(x:xs,u) | (x,t)   <- readPair s
-                                   , (xs,u)  <- readl' t]
-              readl' s = [([],t)   | ("}",t) <- lex s] ++
-                         [(x:xs,v) | (",",t) <- lex s
-                                   , (x,u)   <- readPair t
-                                   , (xs,v)  <- readl' u]
+#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
 
 -- parses a pair of things with the syntax a:=b
 readPair :: (Read a, Read b) => ReadS (a,b)
@@ -1330,7 +1361,8 @@ readPair s = do (a, ct1)    <- reads s
   Show
 --------------------------------------------------------------------}
 instance (Show k, Show a) => Show (Map k a) where
-  showsPrec d m  = showMap (toAscList m)
+  showsPrec d m  = showParen (d > 10) $
+    showString "fromList " . shows (toList m)
 
 showMap :: (Show k,Show a) => [(k,a)] -> ShowS
 showMap []