1{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-} 2{-# LANGUAGE RankNTypes #-} 3{-# LANGUAGE TypeFamilies #-} 4 5-- | 6-- Module : Data.Primitive.Array 7-- Copyright : (c) Roman Leshchinskiy 2009-2012 8-- License : BSD-style 9-- 10-- Maintainer : Roman Leshchinskiy <rl@cse.unsw.edu.au> 11-- Portability : non-portable 12-- 13-- Primitive arrays of boxed values. 14-- 15 16module Data.Primitive.Array ( 17 Array(..), MutableArray(..), 18 19 newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##, 20 freezeArray, thawArray, runArray, 21 unsafeFreezeArray, unsafeThawArray, sameMutableArray, 22 copyArray, copyMutableArray, 23 cloneArray, cloneMutableArray, 24 sizeofArray, sizeofMutableArray, 25 fromListN, fromList, 26 mapArray', 27 traverseArrayP 28) where 29 30import Control.Monad.Primitive 31 32import GHC.Base ( Int(..) ) 33import GHC.Exts 34#if (MIN_VERSION_base(4,7,0)) 35 hiding (toList) 36#endif 37import qualified GHC.Exts as Exts 38#if (MIN_VERSION_base(4,7,0)) 39import GHC.Exts (fromListN, fromList) 40#endif 41 42import Data.Typeable ( Typeable ) 43import Data.Data 44 (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) 45import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) 46 47import Control.Monad.ST(ST,runST) 48 49import Control.Applicative 50import Control.Monad (MonadPlus(..), when) 51import qualified Control.Monad.Fail as Fail 52import Control.Monad.Fix 53#if MIN_VERSION_base(4,4,0) 54import Control.Monad.Zip 55#endif 56import Data.Foldable (Foldable(..), toList) 57#if !(MIN_VERSION_base(4,8,0)) 58import Data.Traversable (Traversable(..)) 59import Data.Monoid 60#endif 61#if MIN_VERSION_base(4,9,0) 62import qualified GHC.ST as GHCST 63import qualified Data.Foldable as F 64import Data.Semigroup 65#endif 66#if MIN_VERSION_base(4,8,0) 67import Data.Functor.Identity 68#endif 69#if MIN_VERSION_base(4,10,0) 70import GHC.Exts (runRW#) 71#elif MIN_VERSION_base(4,9,0) 72import GHC.Base (runRW#) 73#endif 74 75import Text.Read (Read (..), parens, prec) 76import Text.ParserCombinators.ReadPrec (ReadPrec) 77import qualified Text.ParserCombinators.ReadPrec as RdPrc 78import Text.ParserCombinators.ReadP 79 80#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 81import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) 82#endif 83import Control.Monad (liftM2) 84 85-- | Boxed arrays 86data Array a = Array 87 { array# :: Array# a } 88 deriving ( Typeable ) 89 90-- | Mutable boxed arrays associated with a primitive state token. 91data MutableArray s a = MutableArray 92 { marray# :: MutableArray# s a } 93 deriving ( Typeable ) 94 95sizeofArray :: Array a -> Int 96sizeofArray a = I# (sizeofArray# (array# a)) 97{-# INLINE sizeofArray #-} 98 99sizeofMutableArray :: MutableArray s a -> Int 100sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) 101{-# INLINE sizeofMutableArray #-} 102 103-- | Create a new mutable array of the specified size and initialise all 104-- elements with the given value. 105newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) 106{-# INLINE newArray #-} 107newArray (I# n#) x = primitive 108 (\s# -> case newArray# n# x s# of 109 (# s'#, arr# #) -> 110 let ma = MutableArray arr# 111 in (# s'# , ma #)) 112 113-- | Read a value from the array at the given index. 114readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a 115{-# INLINE readArray #-} 116readArray arr (I# i#) = primitive (readArray# (marray# arr) i#) 117 118-- | Write a value to the array at the given index. 119writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () 120{-# INLINE writeArray #-} 121writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x) 122 123-- | Read a value from the immutable array at the given index. 124indexArray :: Array a -> Int -> a 125{-# INLINE indexArray #-} 126indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x 127 128-- | Read a value from the immutable array at the given index, returning 129-- the result in an unboxed unary tuple. This is currently used to implement 130-- folds. 131indexArray## :: Array a -> Int -> (# a #) 132indexArray## arr (I# i) = indexArray# (array# arr) i 133{-# INLINE indexArray## #-} 134 135-- | Monadically read a value from the immutable array at the given index. 136-- This allows us to be strict in the array while remaining lazy in the read 137-- element which is very useful for collective operations. Suppose we want to 138-- copy an array. We could do something like this: 139-- 140-- > copy marr arr ... = do ... 141-- > writeArray marr i (indexArray arr i) ... 142-- > ... 143-- 144-- But since primitive arrays are lazy, the calls to 'indexArray' will not be 145-- evaluated. Rather, @marr@ will be filled with thunks each of which would 146-- retain a reference to @arr@. This is definitely not what we want! 147-- 148-- With 'indexArrayM', we can instead write 149-- 150-- > copy marr arr ... = do ... 151-- > x <- indexArrayM arr i 152-- > writeArray marr i x 153-- > ... 154-- 155-- Now, indexing is executed immediately although the returned element is 156-- still not evaluated. 157-- 158indexArrayM :: Monad m => Array a -> Int -> m a 159{-# INLINE indexArrayM #-} 160indexArrayM arr (I# i#) 161 = case indexArray# (array# arr) i# of (# x #) -> return x 162 163-- | Create an immutable copy of a slice of an array. 164-- 165-- This operation makes a copy of the specified section, so it is safe to 166-- continue using the mutable array afterward. 167freezeArray 168 :: PrimMonad m 169 => MutableArray (PrimState m) a -- ^ source 170 -> Int -- ^ offset 171 -> Int -- ^ length 172 -> m (Array a) 173{-# INLINE freezeArray #-} 174freezeArray (MutableArray ma#) (I# off#) (I# len#) = 175 primitive $ \s -> case freezeArray# ma# off# len# s of 176 (# s', a# #) -> (# s', Array a# #) 177 178-- | Convert a mutable array to an immutable one without copying. The 179-- array should not be modified after the conversion. 180unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a) 181{-# INLINE unsafeFreezeArray #-} 182unsafeFreezeArray arr 183 = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of 184 (# s'#, arr'# #) -> 185 let a = Array arr'# 186 in (# s'#, a #)) 187 188-- | Create a mutable array from a slice of an immutable array. 189-- 190-- This operation makes a copy of the specified slice, so it is safe to use the 191-- immutable array afterward. 192thawArray 193 :: PrimMonad m 194 => Array a -- ^ source 195 -> Int -- ^ offset 196 -> Int -- ^ length 197 -> m (MutableArray (PrimState m) a) 198{-# INLINE thawArray #-} 199thawArray (Array a#) (I# off#) (I# len#) = 200 primitive $ \s -> case thawArray# a# off# len# s of 201 (# s', ma# #) -> (# s', MutableArray ma# #) 202 203-- | Convert an immutable array to an mutable one without copying. The 204-- immutable array should not be used after the conversion. 205unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a) 206{-# INLINE unsafeThawArray #-} 207unsafeThawArray a 208 = primitive (\s# -> case unsafeThawArray# (array# a) s# of 209 (# s'#, arr'# #) -> 210 let ma = MutableArray arr'# 211 in (# s'#, ma #)) 212 213-- | Check whether the two arrays refer to the same memory block. 214sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool 215{-# INLINE sameMutableArray #-} 216sameMutableArray arr brr 217 = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) 218 219-- | Copy a slice of an immutable array to a mutable array. 220copyArray :: PrimMonad m 221 => MutableArray (PrimState m) a -- ^ destination array 222 -> Int -- ^ offset into destination array 223 -> Array a -- ^ source array 224 -> Int -- ^ offset into source array 225 -> Int -- ^ number of elements to copy 226 -> m () 227{-# INLINE copyArray #-} 228#if __GLASGOW_HASKELL__ > 706 229-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier 230copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) 231 = primitive_ (copyArray# src# soff# dst# doff# len#) 232#else 233copyArray !dst !doff !src !soff !len = go 0 234 where 235 go i | i < len = do 236 x <- indexArrayM src (soff+i) 237 writeArray dst (doff+i) x 238 go (i+1) 239 | otherwise = return () 240#endif 241 242-- | Copy a slice of a mutable array to another array. The two arrays must 243-- not be the same when using this library with GHC versions 7.6 and older. 244-- In GHC 7.8 and newer, overlapping arrays will behave correctly. 245-- 246-- Note: The order of arguments is different from that of 'copyMutableArray#'. The primop 247-- has the source first while this wrapper has the destination first. 248copyMutableArray :: PrimMonad m 249 => MutableArray (PrimState m) a -- ^ destination array 250 -> Int -- ^ offset into destination array 251 -> MutableArray (PrimState m) a -- ^ source array 252 -> Int -- ^ offset into source array 253 -> Int -- ^ number of elements to copy 254 -> m () 255{-# INLINE copyMutableArray #-} 256#if __GLASGOW_HASKELL__ > 706 257-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier 258copyMutableArray (MutableArray dst#) (I# doff#) 259 (MutableArray src#) (I# soff#) (I# len#) 260 = primitive_ (copyMutableArray# src# soff# dst# doff# len#) 261#else 262copyMutableArray !dst !doff !src !soff !len = go 0 263 where 264 go i | i < len = do 265 x <- readArray src (soff+i) 266 writeArray dst (doff+i) x 267 go (i+1) 268 | otherwise = return () 269#endif 270 271-- | Return a newly allocated Array with the specified subrange of the 272-- provided Array. The provided Array should contain the full subrange 273-- specified by the two Ints, but this is not checked. 274cloneArray :: Array a -- ^ source array 275 -> Int -- ^ offset into destination array 276 -> Int -- ^ number of elements to copy 277 -> Array a 278{-# INLINE cloneArray #-} 279cloneArray (Array arr#) (I# off#) (I# len#) 280 = case cloneArray# arr# off# len# of arr'# -> Array arr'# 281 282-- | Return a newly allocated MutableArray. with the specified subrange of 283-- the provided MutableArray. The provided MutableArray should contain the 284-- full subrange specified by the two Ints, but this is not checked. 285cloneMutableArray :: PrimMonad m 286 => MutableArray (PrimState m) a -- ^ source array 287 -> Int -- ^ offset into destination array 288 -> Int -- ^ number of elements to copy 289 -> m (MutableArray (PrimState m) a) 290{-# INLINE cloneMutableArray #-} 291cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive 292 (\s# -> case cloneMutableArray# arr# off# len# s# of 293 (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) 294 295emptyArray :: Array a 296emptyArray = 297 runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray 298{-# NOINLINE emptyArray #-} 299 300#if !MIN_VERSION_base(4,9,0) 301createArray 302 :: Int 303 -> a 304 -> (forall s. MutableArray s a -> ST s ()) 305 -> Array a 306createArray 0 _ _ = emptyArray 307createArray n x f = runArray $ do 308 mary <- newArray n x 309 f mary 310 pure mary 311 312runArray 313 :: (forall s. ST s (MutableArray s a)) 314 -> Array a 315runArray m = runST $ m >>= unsafeFreezeArray 316 317#else /* Below, runRW# is available. */ 318 319-- This low-level business is designed to work with GHC's worker-wrapper 320-- transformation. A lot of the time, we don't actually need an Array 321-- constructor. By putting it on the outside, and being careful about 322-- how we special-case the empty array, we can make GHC smarter about this. 323-- The only downside is that separately created 0-length arrays won't share 324-- their Array constructors, although they'll share their underlying 325-- Array#s. 326createArray 327 :: Int 328 -> a 329 -> (forall s. MutableArray s a -> ST s ()) 330 -> Array a 331createArray 0 _ _ = Array (emptyArray# (# #)) 332createArray n x f = runArray $ do 333 mary <- newArray n x 334 f mary 335 pure mary 336 337runArray 338 :: (forall s. ST s (MutableArray s a)) 339 -> Array a 340runArray m = Array (runArray# m) 341 342runArray# 343 :: (forall s. ST s (MutableArray s a)) 344 -> Array# a 345runArray# m = case runRW# $ \s -> 346 case unST m s of { (# s', MutableArray mary# #) -> 347 unsafeFreezeArray# mary# s'} of (# _, ary# #) -> ary# 348 349unST :: ST s a -> State# s -> (# State# s, a #) 350unST (GHCST.ST f) = f 351 352emptyArray# :: (# #) -> Array# a 353emptyArray# _ = case emptyArray of Array ar -> ar 354{-# NOINLINE emptyArray# #-} 355#endif 356 357 358die :: String -> String -> a 359die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem 360 361arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool 362arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1) 363 where loop i | i < 0 = True 364 | (# x1 #) <- indexArray## a1 i 365 , (# x2 #) <- indexArray## a2 i 366 , otherwise = p x1 x2 && loop (i-1) 367 368instance Eq a => Eq (Array a) where 369 a1 == a2 = arrayLiftEq (==) a1 a2 370 371#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 372-- | @since 0.6.4.0 373instance Eq1 Array where 374#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 375 liftEq = arrayLiftEq 376#else 377 eq1 = arrayLiftEq (==) 378#endif 379#endif 380 381instance Eq (MutableArray s a) where 382 ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) 383 384arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering 385arrayLiftCompare elemCompare a1 a2 = loop 0 386 where 387 mn = sizeofArray a1 `min` sizeofArray a2 388 loop i 389 | i < mn 390 , (# x1 #) <- indexArray## a1 i 391 , (# x2 #) <- indexArray## a2 i 392 = elemCompare x1 x2 `mappend` loop (i+1) 393 | otherwise = compare (sizeofArray a1) (sizeofArray a2) 394 395-- | Lexicographic ordering. Subject to change between major versions. 396instance Ord a => Ord (Array a) where 397 compare a1 a2 = arrayLiftCompare compare a1 a2 398 399#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 400-- | @since 0.6.4.0 401instance Ord1 Array where 402#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 403 liftCompare = arrayLiftCompare 404#else 405 compare1 = arrayLiftCompare compare 406#endif 407#endif 408 409instance Foldable Array where 410 -- Note: we perform the array lookups eagerly so we won't 411 -- create thunks to perform lookups even if GHC can't see 412 -- that the folding function is strict. 413 foldr f = \z !ary -> 414 let 415 !sz = sizeofArray ary 416 go i 417 | i == sz = z 418 | (# x #) <- indexArray## ary i 419 = f x (go (i+1)) 420 in go 0 421 {-# INLINE foldr #-} 422 foldl f = \z !ary -> 423 let 424 go i 425 | i < 0 = z 426 | (# x #) <- indexArray## ary i 427 = f (go (i-1)) x 428 in go (sizeofArray ary - 1) 429 {-# INLINE foldl #-} 430 foldr1 f = \ !ary -> 431 let 432 !sz = sizeofArray ary - 1 433 go i = 434 case indexArray## ary i of 435 (# x #) | i == sz -> x 436 | otherwise -> f x (go (i+1)) 437 in if sz < 0 438 then die "foldr1" "empty array" 439 else go 0 440 {-# INLINE foldr1 #-} 441 foldl1 f = \ !ary -> 442 let 443 !sz = sizeofArray ary - 1 444 go i = 445 case indexArray## ary i of 446 (# x #) | i == 0 -> x 447 | otherwise -> f (go (i - 1)) x 448 in if sz < 0 449 then die "foldl1" "empty array" 450 else go sz 451 {-# INLINE foldl1 #-} 452#if MIN_VERSION_base(4,6,0) 453 foldr' f = \z !ary -> 454 let 455 go i !acc 456 | i == -1 = acc 457 | (# x #) <- indexArray## ary i 458 = go (i-1) (f x acc) 459 in go (sizeofArray ary - 1) z 460 {-# INLINE foldr' #-} 461 foldl' f = \z !ary -> 462 let 463 !sz = sizeofArray ary 464 go i !acc 465 | i == sz = acc 466 | (# x #) <- indexArray## ary i 467 = go (i+1) (f acc x) 468 in go 0 z 469 {-# INLINE foldl' #-} 470#endif 471#if MIN_VERSION_base(4,8,0) 472 null a = sizeofArray a == 0 473 {-# INLINE null #-} 474 length = sizeofArray 475 {-# INLINE length #-} 476 maximum ary | sz == 0 = die "maximum" "empty array" 477 | (# frst #) <- indexArray## ary 0 478 = go 1 frst 479 where 480 sz = sizeofArray ary 481 go i !e 482 | i == sz = e 483 | (# x #) <- indexArray## ary i 484 = go (i+1) (max e x) 485 {-# INLINE maximum #-} 486 minimum ary | sz == 0 = die "minimum" "empty array" 487 | (# frst #) <- indexArray## ary 0 488 = go 1 frst 489 where sz = sizeofArray ary 490 go i !e 491 | i == sz = e 492 | (# x #) <- indexArray## ary i 493 = go (i+1) (min e x) 494 {-# INLINE minimum #-} 495 sum = foldl' (+) 0 496 {-# INLINE sum #-} 497 product = foldl' (*) 1 498 {-# INLINE product #-} 499#endif 500 501newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} 502 503runSTA :: Int -> STA a -> Array a 504runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar) 505{-# INLINE runSTA #-} 506 507newArray_ :: Int -> ST s (MutableArray s a) 508newArray_ !n = newArray n badTraverseValue 509 510badTraverseValue :: a 511badTraverseValue = die "traverse" "bad indexing" 512{-# NOINLINE badTraverseValue #-} 513 514instance Traversable Array where 515 traverse f = traverseArray f 516 {-# INLINE traverse #-} 517 518traverseArray 519 :: Applicative f 520 => (a -> f b) 521 -> Array a 522 -> f (Array b) 523traverseArray f = \ !ary -> 524 let 525 !len = sizeofArray ary 526 go !i 527 | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary) 528 | (# x #) <- indexArray## ary i 529 = liftA2 (\b (STA m) -> STA $ \mary -> 530 writeArray (MutableArray mary) i b >> m mary) 531 (f x) (go (i + 1)) 532 in if len == 0 533 then pure emptyArray 534 else runSTA len <$> go 0 535{-# INLINE [1] traverseArray #-} 536 537{-# RULES 538"traverse/ST" forall (f :: a -> ST s b). traverseArray f = 539 traverseArrayP f 540"traverse/IO" forall (f :: a -> IO b). traverseArray f = 541 traverseArrayP f 542 #-} 543#if MIN_VERSION_base(4,8,0) 544{-# RULES 545"traverse/Id" forall (f :: a -> Identity b). traverseArray f = 546 (coerce :: (Array a -> Array (Identity b)) 547 -> Array a -> Identity (Array b)) (fmap f) 548 #-} 549#endif 550 551-- | This is the fastest, most straightforward way to traverse 552-- an array, but it only works correctly with a sufficiently 553-- "affine" 'PrimMonad' instance. In particular, it must only produce 554-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed 555-- monads, for example, will not work right at all. 556traverseArrayP 557 :: PrimMonad m 558 => (a -> m b) 559 -> Array a 560 -> m (Array b) 561traverseArrayP f = \ !ary -> 562 let 563 !sz = sizeofArray ary 564 go !i !mary 565 | i == sz 566 = unsafeFreezeArray mary 567 | otherwise 568 = do 569 a <- indexArrayM ary i 570 b <- f a 571 writeArray mary i b 572 go (i + 1) mary 573 in do 574 mary <- newArray sz badTraverseValue 575 go 0 mary 576{-# INLINE traverseArrayP #-} 577 578-- | Strict map over the elements of the array. 579mapArray' :: (a -> b) -> Array a -> Array b 580mapArray' f a = 581 createArray (sizeofArray a) (die "mapArray'" "impossible") $ \mb -> 582 let go i | i == sizeofArray a 583 = return () 584 | otherwise 585 = do x <- indexArrayM a i 586 -- We use indexArrayM here so that we will perform the 587 -- indexing eagerly even if f is lazy. 588 let !y = f x 589 writeArray mb i y >> go (i+1) 590 in go 0 591{-# INLINE mapArray' #-} 592 593arrayFromListN :: Int -> [a] -> Array a 594arrayFromListN n l = 595 createArray n (die "fromListN" "uninitialized element") $ \sma -> 596 let go !ix [] = if ix == n 597 then return () 598 else die "fromListN" "list length less than specified size" 599 go !ix (x : xs) = if ix < n 600 then do 601 writeArray sma ix x 602 go (ix+1) xs 603 else die "fromListN" "list length greater than specified size" 604 in go 0 l 605 606arrayFromList :: [a] -> Array a 607arrayFromList l = arrayFromListN (length l) l 608 609#if MIN_VERSION_base(4,7,0) 610instance Exts.IsList (Array a) where 611 type Item (Array a) = a 612 fromListN = arrayFromListN 613 fromList = arrayFromList 614 toList = toList 615#else 616fromListN :: Int -> [a] -> Array a 617fromListN = arrayFromListN 618 619fromList :: [a] -> Array a 620fromList = arrayFromList 621#endif 622 623instance Functor Array where 624 fmap f a = 625 createArray (sizeofArray a) (die "fmap" "impossible") $ \mb -> 626 let go i | i == sizeofArray a 627 = return () 628 | otherwise 629 = do x <- indexArrayM a i 630 writeArray mb i (f x) >> go (i+1) 631 in go 0 632#if MIN_VERSION_base(4,8,0) 633 e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ()) 634#endif 635 636instance Applicative Array where 637 pure x = runArray $ newArray 1 x 638 ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb -> 639 let go1 i = when (i < szab) $ 640 do 641 f <- indexArrayM ab i 642 go2 (i*sza) f 0 643 go1 (i+1) 644 go2 off f j = when (j < sza) $ 645 do 646 x <- indexArrayM a j 647 writeArray mb (off + j) (f x) 648 go2 off f (j + 1) 649 in go1 0 650 where szab = sizeofArray ab ; sza = sizeofArray a 651 a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb -> 652 let go i | i < sza = copyArray mb (i * szb) b 0 szb 653 | otherwise = return () 654 in go 0 655 where sza = sizeofArray a ; szb = sizeofArray b 656 a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma -> 657 let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e 658 | otherwise = return () 659 go i | i < sza 660 = do x <- indexArrayM a i 661 fill (i*szb) 0 x >> go (i+1) 662 | otherwise = return () 663 in go 0 664 where sza = sizeofArray a ; szb = sizeofArray b 665 666instance Alternative Array where 667 empty = emptyArray 668 a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> 669 copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2 670 where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2 671 some a | sizeofArray a == 0 = emptyArray 672 | otherwise = die "some" "infinite arrays are not well defined" 673 many a | sizeofArray a == 0 = pure [] 674 | otherwise = die "many" "infinite arrays are not well defined" 675 676data ArrayStack a 677 = PushArray !(Array a) !(ArrayStack a) 678 | EmptyStack 679-- See the note in SmallArray about how we might improve this. 680 681instance Monad Array where 682 return = pure 683 (>>) = (*>) 684 685 ary >>= f = collect 0 EmptyStack (la-1) 686 where 687 la = sizeofArray ary 688 collect sz stk i 689 | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk 690 | (# x #) <- indexArray## ary i 691 , let sb = f x 692 lsb = sizeofArray sb 693 -- If we don't perform this check, we could end up allocating 694 -- a stack full of empty arrays if someone is filtering most 695 -- things out. So we refrain from pushing empty arrays. 696 = if lsb == 0 697 then collect sz stk (i - 1) 698 else collect (sz + lsb) (PushArray sb stk) (i-1) 699 700 fill _ EmptyStack _ = return () 701 fill off (PushArray sb sbs) smb 702 | let lsb = sizeofArray sb 703 = copyArray smb off sb 0 (lsb) 704 *> fill (off + lsb) sbs smb 705 706#if !(MIN_VERSION_base(4,13,0)) 707 fail = Fail.fail 708#endif 709 710instance Fail.MonadFail Array where 711 fail _ = empty 712 713instance MonadPlus Array where 714 mzero = empty 715 mplus = (<|>) 716 717zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c 718zipW s f aa ab = createArray mn (die s "impossible") $ \mc -> 719 let go i | i < mn 720 = do 721 x <- indexArrayM aa i 722 y <- indexArrayM ab i 723 writeArray mc i (f x y) 724 go (i+1) 725 | otherwise = return () 726 in go 0 727 where mn = sizeofArray aa `min` sizeofArray ab 728{-# INLINE zipW #-} 729 730#if MIN_VERSION_base(4,4,0) 731instance MonadZip Array where 732 mzip aa ab = zipW "mzip" (,) aa ab 733 mzipWith f aa ab = zipW "mzipWith" f aa ab 734 munzip aab = runST $ do 735 let sz = sizeofArray aab 736 ma <- newArray sz (die "munzip" "impossible") 737 mb <- newArray sz (die "munzip" "impossible") 738 let go i | i < sz = do 739 (a, b) <- indexArrayM aab i 740 writeArray ma i a 741 writeArray mb i b 742 go (i+1) 743 go _ = return () 744 go 0 745 (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb 746#endif 747 748instance MonadFix Array where 749 mfix f = createArray (sizeofArray (f err)) 750 (die "mfix" "impossible") $ flip fix 0 $ 751 \r !i !mary -> when (i < sz) $ do 752 writeArray mary i (fix (\xi -> f xi `indexArray` i)) 753 r (i + 1) mary 754 where 755 sz = sizeofArray (f err) 756 err = error "mfix for Data.Primitive.Array applied to strict function." 757 758#if MIN_VERSION_base(4,9,0) 759-- | @since 0.6.3.0 760instance Semigroup (Array a) where 761 (<>) = (<|>) 762 sconcat = mconcat . F.toList 763#endif 764 765instance Monoid (Array a) where 766 mempty = empty 767#if !(MIN_VERSION_base(4,11,0)) 768 mappend = (<|>) 769#endif 770 mconcat l = createArray sz (die "mconcat" "impossible") $ \ma -> 771 let go !_ [ ] = return () 772 go off (a:as) = 773 copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as 774 in go 0 l 775 where sz = sum . fmap sizeofArray $ l 776 777arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS 778arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $ 779 showString "fromListN " . shows (sizeofArray a) . showString " " 780 . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a) 781 782-- this need to be included for older ghcs 783listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS 784listLiftShowsPrec _ sl _ = sl 785 786instance Show a => Show (Array a) where 787 showsPrec p a = arrayLiftShowsPrec showsPrec showList p a 788 789#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 790-- | @since 0.6.4.0 791instance Show1 Array where 792#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 793 liftShowsPrec = arrayLiftShowsPrec 794#else 795 showsPrec1 = arrayLiftShowsPrec showsPrec showList 796#endif 797#endif 798 799instance Read a => Read (Array a) where 800 readPrec = arrayLiftReadPrec readPrec readListPrec 801 802#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 803-- | @since 0.6.4.0 804instance Read1 Array where 805#if MIN_VERSION_base(4,10,0) 806 liftReadPrec = arrayLiftReadPrec 807#elif MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 808 liftReadsPrec = arrayLiftReadsPrec 809#else 810 readsPrec1 = arrayLiftReadsPrec readsPrec readList 811#endif 812#endif 813 814-- We're really forgiving here. We accept 815-- "[1,2,3]", "fromList [1,2,3]", and "fromListN 3 [1,2,3]". 816-- We consider fromListN with an invalid length to be an 817-- error, rather than a parse failure, because doing otherwise 818-- seems weird and likely to make debugging difficult. 819arrayLiftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Array a) 820arrayLiftReadPrec _ read_list = parens $ prec app_prec $ RdPrc.lift skipSpaces >> 821 ((fromList <$> read_list) RdPrc.+++ 822 do 823 tag <- RdPrc.lift lexTag 824 case tag of 825 FromListTag -> fromList <$> read_list 826 FromListNTag -> liftM2 fromListN readPrec read_list) 827 where 828 app_prec = 10 829 830data Tag = FromListTag | FromListNTag 831 832-- Why don't we just use lexP? The general problem with lexP is that 833-- it doesn't always fail as fast as we might like. It will 834-- happily read to the end of an absurdly long lexeme (e.g., a 200MB string 835-- literal) before returning, at which point we'll immediately discard 836-- the result because it's not an identifier. Doing the job ourselves, we 837-- can see very quickly when we've run into a problem. We should also get 838-- a slight efficiency boost by going through the string just once. 839lexTag :: ReadP Tag 840lexTag = do 841 _ <- string "fromList" 842 s <- look 843 case s of 844 'N':c:_ 845 | '0' <= c && c <= '9' 846 -> fail "" -- We have fromListN3 or similar 847 | otherwise -> FromListNTag <$ get -- Skip the 'N' 848 _ -> return FromListTag 849 850#if !MIN_VERSION_base(4,10,0) 851arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a) 852arrayLiftReadsPrec reads_prec list_reads_prec = RdPrc.readPrec_to_S $ 853 arrayLiftReadPrec (RdPrc.readS_to_Prec reads_prec) (RdPrc.readS_to_Prec (const list_reads_prec)) 854#endif 855 856 857arrayDataType :: DataType 858arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr] 859 860fromListConstr :: Constr 861fromListConstr = mkConstr arrayDataType "fromList" [] Prefix 862 863instance Data a => Data (Array a) where 864 toConstr _ = fromListConstr 865 dataTypeOf _ = arrayDataType 866 gunfold k z c = case constrIndex c of 867 1 -> k (z fromList) 868 _ -> error "gunfold" 869 gfoldl f z m = z fromList `f` toList m 870 871instance (Typeable s, Typeable a) => Data (MutableArray s a) where 872 toConstr _ = error "toConstr" 873 gunfold _ _ = error "gunfold" 874 dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray" 875