Add fromArrayMonolithic

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,14 +2344,36 @@ 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))
   where
     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

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