diff --git a/Data/Sequence.hs b/Data/Sequence.hs index 0a64c3e85..e6761dc34 100644 --- a/Data/Sequence.hs +++ b/Data/Sequence.hs @@ -60,6 +60,7 @@ module Data.Sequence ( fromList, -- :: [a] -> Seq a fromFunction, -- :: Int -> (Int -> a) -> Seq a fromArray, -- :: Ix i => Array i a -> Seq a + fromArrayMonolithic, -- :: Ix i => Array i a -> Seq a -- ** Repetition replicate, -- :: Int -> a -> Seq a replicateA, -- :: Applicative f => Int -> f a -> f (Seq a) @@ -177,6 +178,7 @@ import Data.Data import Data.Array (Ix, Array) #ifdef __GLASGOW_HASKELL__ import qualified GHC.Arr +import qualified Data.Primitive.Array as PA #endif -- Coercion on GHC 7.8+ @@ -821,6 +823,12 @@ instance Applicative Identity where -- | This is essentially a clone of Control.Monad.State.Strict. newtype State s a = State {runState :: s -> (s, a)} +put :: s -> State s () +put s = State (\_ -> (s, ())) + +get :: State s s +get = State (\s -> (s, s)) + instance Functor (State s) where fmap = liftA @@ -1643,6 +1651,7 @@ fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a) fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a) #endif + -- Splitting -- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence. @@ -2335,7 +2344,7 @@ unstableSortBy cmp (Seq xs) = toPQ cmp (\ (Elem x) -> PQueue x Nil) xs -- | fromList2, given a list and its length, constructs a completely --- balanced Seq whose elements are that list using the applicativeTree +-- balanced Seq whose elements are that list using the replicateA -- generalization. fromList2 :: Int -> [a] -> Seq a fromList2 n = execState (replicateA n (State ht)) @@ -2343,6 +2352,28 @@ fromList2 n = execState (replicateA n (State ht)) ht (x:xs) = (xs, x) ht [] = error "fromList2: short list" +-- | /O(n)/. Create a sequence consisting of the elements of an 'Array'. With +-- GHC, the result of 'fromArrayMonolithic' is guaranteed not to retain any +-- references to the array, unless individual array entries contain such. To +-- accomplish this, it reads each entry out of the array before returning. With +-- other implementations, this is identical to 'fromArray'. +fromArrayMonolithic :: Ix i => Array i a -> Seq a +#ifdef __GLASGOW_HASKELL__ +fromArrayMonolithic (GHC.Arr.Array _ _ len ar) + = execState (fromArrayMonolithicState (PA.Array ar)) 0 + where + {-# INLINE fromArrayMonolithicState #-} + fromArrayMonolithicState :: PA.Array a -> State Int (Seq a) + fromArrayMonolithicState a = + replicateA len (do + i <- get + x <- PA.indexArrayM a i + put (i+1) + return x) +#else +fromArrayMonolithic = fromArray +#endif + -- | A 'PQueue' is a simple pairing heap. data PQueue e = PQueue e (PQL e) data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e diff --git a/containers.cabal b/containers.cabal index c5d7523f7..38096fb7b 100644 --- a/containers.cabal +++ b/containers.cabal @@ -34,6 +34,8 @@ Library build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5 if impl(ghc>=6.10) build-depends: ghc-prim + if impl(ghc) + build-depends: primitive ghc-options: -O2 -Wall @@ -208,6 +210,8 @@ Test-suite seq-properties cpp-options: -DTESTING build-depends: base >= 4.2 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim + if impl(ghc) + build-depends: primitive ghc-options: -O2 include-dirs: include extensions: MagicHash, DeriveDataTypeable, StandaloneDeriving, Rank2Types