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