-{-# OPTIONS -cpp #-}
+{-# OPTIONS -cpp -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Sequence
--
-- * 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
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
-#if TESTING
-import Control.Monad (liftM, liftM2, liftM3, liftM4)
-import Test.QuickCheck
+#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 __GLASGOW_HASKELL__
-import Data.Generics.Basics (Data(..), mkNorepType)
+#if TESTING
+import Control.Monad (liftM, liftM3, liftM4)
+import Test.QuickCheck
#endif
infixr 5 `consTree`
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
compare xs ys = compare (toList xs) (toList ys)
#if TESTING
-instance (Show a) => Show (Seq a) where
+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")
#if __GLASGOW_HASKELL__
instance Data a => Data (Seq a) where
- gfoldl f z xs = z fromList `f` toList xs
- toConstr _ = error "toConstr"
- gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Sequence.Seq"
+ gfoldl f z s = case viewl s of
+ EmptyL -> z empty
+ x :< xs -> z (<|) `f` x `f` xs
+
+ gunfold k z c = case constrIndex c of
+ 1 -> z empty
+ 2 -> k (k (z (<|)))
+ _ -> error "gunfold"
+
+ toConstr xs
+ | null xs = emptyConstr
+ | otherwise = consConstr
+
+ dataTypeOf _ = seqDataType
+
+ dataCast1 = gcast1
+
+emptyConstr = mkConstr seqDataType "empty" [] Prefix
+consConstr = mkConstr seqDataType "<|" [] Infix
+seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
#endif
-- Finger trees
#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
Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)
{-# INLINE deep #-}
+{-# SPECIALIZE deep :: Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a) #-}
+{-# SPECIALIZE deep :: Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) -> FingerTree (Node a) #-}
deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
deep pr m sf = Deep (size pr + size m + size sf) pr m sf
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) #-}
size (Node3 v _ _ _) = v
{-# INLINE node2 #-}
+{-# SPECIALIZE node2 :: Elem a -> Elem a -> Node (Elem a) #-}
+{-# SPECIALIZE node2 :: Node a -> Node a -> Node (Node a) #-}
node2 :: Sized a => a -> a -> Node a
node2 a b = Node2 (size a + size b) a b
{-# INLINE node3 #-}
+{-# SPECIALIZE node3 :: Elem a -> Elem a -> Elem a -> Node (Elem a) #-}
+{-# SPECIALIZE node3 :: Node a -> Node a -> Node a -> Node (Node a) #-}
node3 :: Sized a => a -> a -> a -> Node a
node3 a b c = Node3 (size a + size b + size c) a b c
= 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
| 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
-- | /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
projects / haskell-directory.git / blobdiff