[project @ 2005-10-20 23:28:42 by ross]

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

diff --git a/Data/Sequence.hs b/Data/Sequence.hs
index 611a0cb..6b53985 100644 (file)
--- a/Data/Sequence.hs
+++ b/Data/Sequence.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -cpp #-}
+{-# OPTIONS -cpp -fglasgow-exts #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Sequence
@@ -22,7 +22,7 @@
 --
 --    * Ralf Hinze and Ross Paterson,
 --     \"Finger trees: a simple general-purpose data structure\",
---     submitted to /Journal of Functional Programming/.
+--     to appear in /Journal of Functional Programming/.
 --     <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>
 --
 -- /Note/: Many of these operations have the same names as similar
@@ -81,19 +81,26 @@ import Prelude hiding (
        reverse)
 import qualified Prelude (foldr)
 import qualified Data.List (foldl', intersperse)
+import Control.Monad (MonadPlus(..))
 import Data.FunctorM
 import Data.Typeable
 
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (build)
+import Text.ParserCombinators.ReadP (char, skipSpaces, between, sepBy, (+++))
+import Text.Read (readPrec, readPrec_to_P, readP_to_Prec, minPrec)
+import Control.Monad (liftM)
+import Data.Generics.Basics (Data(..), Fixity(..),
+                       constrIndex, mkConstr, mkDataType)
+#else
+import Data.Char (isSpace)
+#endif
+
 #if TESTING
 import Control.Monad (liftM, liftM2, 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`
 
@@ -104,16 +111,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
 
@@ -131,13 +151,31 @@ instance Show a => Show (Seq a) where
                showChar '>'
 #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
+       -- avoid lex, as < or > might be followed by symbol characters.
+#ifdef __GLASGOW_HASKELL__
+       readPrec = readP_to_Prec $ const $
+               parens $
+               between (litChar '<') (litChar '>') $
+               liftM fromList $
+               readPrec_to_P readPrec minPrec `sepBy` litChar ','
+         where parens p = p +++ between (litChar '(') (litChar ')') (parens p)
+               litChar c = skipSpaces >> char c
+#else
+       readsPrec _ = readParen False $ \ r ->
+               case dropWhile isSpace r of
+                       ('<':s) -> case dropWhile isSpace s of
+                               ('>':t) -> return (empty,t)
+                               _       -> readRest empty s
+                       _ -> []
+         where readRest xs s = do
+                       (x,t) <- reads s
+                       let xs' = xs |> x
+                       case dropWhile isSpace t of
+                               ('>':u) -> return (xs',u)
+                               (',':u) -> readRest xs' u
+                               _     -> []
+#endif
 
 #include "Typeable.h"
 INSTANCE_TYPEABLE1(Seq,seqTc,"Seq")
@@ -177,6 +215,8 @@ data FingerTree a
 #endif
 
 instance Sized a => Sized (FingerTree a) where
+       {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
+       {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
        size Empty              = 0
        size (Single x)         = size x
        size (Deep v _ _ _)     = v
@@ -211,6 +251,8 @@ instance Functor Digit where
        fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)
 
 instance Sized a => Sized (Digit a) where
+       {-# SPECIALIZE instance Sized (Digit (Elem a)) #-}
+       {-# SPECIALIZE instance Sized (Digit (Node a)) #-}
        size xs = foldlDigit (\ i x -> i + size x) 0 xs
 
 {-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
@@ -877,7 +919,12 @@ fromList   =  Data.List.foldl' (|>) empty
 
 -- | /O(n)/. List of elements of the sequence.
 toList         :: Seq a -> [a]
+#ifdef __GLASGOW_HASKELL__
+{-# INLINE toList #-}
+toList xs      =  build (\ c n -> foldr c n xs)
+#else
 toList         =  foldr (:) []
+#endif
 
 ------------------------------------------------------------------------
 -- Folds