[project @ 2005-10-22 00:28:21 by ross]

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

diff --git a/Data/Sequence.hs b/Data/Sequence.hs
index bc3a743..80c42d3 100644 (file)
--- a/Data/Sequence.hs
+++ b/Data/Sequence.hs
@@ -79,24 +79,24 @@ module Data.Sequence (
 import Prelude hiding (
        null, length, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
        reverse)
-import qualified Prelude (foldr)
-import qualified Data.List (foldl', intersperse)
+import qualified Data.List (foldl')
+import Control.Monad (MonadPlus(..), liftM2)
 import Data.FunctorM
 import Data.Typeable
+
 #ifdef __GLASGOW_HASKELL__
 import GHC.Exts (build)
+import Text.Read (Lexeme(Ident), lexP, parens, prec,
+       readPrec, readListPrec, readListPrecDefault)
+import Data.Generics.Basics (Data(..), Fixity(..),
+                       constrIndex, mkConstr, mkDataType)
 #endif
 
 #if TESTING
-import Control.Monad (liftM, liftM2, liftM3, liftM4)
+import Control.Monad (liftM, liftM3, liftM4)
 import Test.QuickCheck
 #endif
 
-#if __GLASGOW_HASKELL__
-import Data.Generics.Basics (Data(..), Fixity(..),
-                       constrIndex, mkConstr, mkDataType)
-#endif
-
 infixr 5 `consTree`
 infixl 5 `snocTree`
 
@@ -107,16 +107,29 @@ infixl 5 |>, :>
 class Sized a where
        size :: a -> Int
 
-------------------------------------------------------------------------
--- Random access sequences
-------------------------------------------------------------------------
-
 -- | General-purpose finite sequences.
 newtype Seq a = Seq (FingerTree (Elem a))
 
 instance Functor Seq where
        fmap f (Seq xs) = Seq (fmap (fmap f) xs)
 
+instance Monad Seq where
+       return = singleton
+       xs >>= f = foldl' add empty xs
+         where add ys x = ys >< f x
+
+instance MonadPlus Seq where
+       mzero = empty
+       mplus = (><)
+
+instance FunctorM Seq where
+       fmapM f = foldlM f' empty
+         where f' ys x = do
+                       y <- f x
+                       return $! (ys |> y)
+       fmapM_ f = foldlM f' ()
+         where f' _ x = f x >> return ()
+
 instance Eq a => Eq (Seq a) where
        xs == ys = length xs == length ys && toList xs == toList ys
 
@@ -128,19 +141,24 @@ instance Show a => Show (Seq a) where
        showsPrec p (Seq x) = showsPrec p x
 #else
 instance Show a => Show (Seq a) where
-       showsPrec _ xs = showChar '<' .
-               flip (Prelude.foldr ($)) (Data.List.intersperse (showChar ',')
-                                               (map shows (toList xs))) .
-               showChar '>'
+       showsPrec p xs = showParen (p > 10) $
+               showString "fromList " . shows (toList xs)
 #endif
 
-instance FunctorM Seq where
-       fmapM f = foldlM f' empty
-         where f' ys x = do
-                       y <- f x
-                       return $! (ys |> y)
-       fmapM_ f = foldlM f' ()
-         where f' _ x = f x >> return ()
+instance Read a => Read (Seq a) 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
 
 #include "Typeable.h"
 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
@@ -584,17 +602,31 @@ data ViewL a
        = EmptyL        -- ^ empty sequence
        | a :< Seq a    -- ^ leftmost element and the rest of the sequence
 #ifndef __HADDOCK__
-       deriving (Eq, Show)
+# if __GLASGOW_HASKELL__
+       deriving (Eq, Ord, Show, Read, Data)
+# else
+       deriving (Eq, Ord, Show, Read)
+# endif
 #else
 instance Eq a => Eq (ViewL a)
+instance Ord a => Ord (ViewL a)
 instance Show a => Show (ViewL a)
+instance Read a => Read (ViewL a)
+instance Data a => Data (ViewL a)
 #endif
 
+INSTANCE_TYPEABLE1(ViewL,viewLTc,"ViewL")
 
 instance Functor ViewL where
        fmap _ EmptyL           = EmptyL
        fmap f (x :< xs)        = f x :< fmap f xs
 
+instance FunctorM ViewL where
+       fmapM _ EmptyL          = return EmptyL
+       fmapM f (x :< xs)       = liftM2 (:<) (f x) (fmapM f xs)
+       fmapM_ _ EmptyL         = return ()
+       fmapM_ f (x :< xs)      = f x >> fmapM_ f xs >> return ()
+
 -- | /O(1)/. Analyse the left end of a sequence.
 viewl          ::  Seq a -> ViewL a
 viewl (Seq xs) =  case viewLTree xs of
@@ -622,16 +654,31 @@ data ViewR a
        | Seq a :> a    -- ^ the sequence minus the rightmost element,
                        -- and the rightmost element
 #ifndef __HADDOCK__
-       deriving (Eq, Show)
+# if __GLASGOW_HASKELL__
+       deriving (Eq, Ord, Show, Read, Data)
+# else
+       deriving (Eq, Ord, Show, Read)
+# endif
 #else
 instance Eq a => Eq (ViewR a)
+instance Ord a => Ord (ViewR a)
 instance Show a => Show (ViewR a)
+instance Read a => Read (ViewR a)
+instance Data a => Data (ViewR a)
 #endif
 
+INSTANCE_TYPEABLE1(ViewR,viewRTc,"ViewR")
+
 instance Functor ViewR where
        fmap _ EmptyR           = EmptyR
        fmap f (xs :> x)        = fmap f xs :> f x
 
+instance FunctorM ViewR where
+       fmapM _ EmptyR          = return EmptyR
+       fmapM f (xs :> x)       = liftM2 (:>) (fmapM f xs) (f x)
+       fmapM_ _ EmptyR         = return ()
+       fmapM_ f (xs :> x)      = fmapM_ f xs >> f x >> return ()
+
 -- | /O(1)/. Analyse the right end of a sequence.
 viewr          ::  Seq a -> ViewR a
 viewr (Seq xs) =  case viewRTree xs of