1{-# LANGUAGE CPP #-} 2{-# LANGUAGE MagicHash #-} 3{-# LANGUAGE RankNTypes #-} 4{-# LANGUAGE TypeFamilies #-} 5{-# LANGUAGE UnboxedTuples #-} 6{-# LANGUAGE DeriveTraversable #-} 7{-# LANGUAGE DeriveDataTypeable #-} 8{-# LANGUAGE GeneralizedNewtypeDeriving #-} 9{-# LANGUAGE BangPatterns #-} 10 11-- | 12-- Module : Data.Primitive.SmallArray 13-- Copyright: (c) 2015 Dan Doel 14-- License: BSD3 15-- 16-- Maintainer: libraries@haskell.org 17-- Portability: non-portable 18-- 19-- Small arrays are boxed (im)mutable arrays. 20-- 21-- The underlying structure of the 'Array' type contains a card table, allowing 22-- segments of the array to be marked as having been mutated. This allows the 23-- garbage collector to only re-traverse segments of the array that have been 24-- marked during certain phases, rather than having to traverse the entire 25-- array. 26-- 27-- 'SmallArray' lacks this table. This means that it takes up less memory and 28-- has slightly faster writes. It is also more efficient during garbage 29-- collection so long as the card table would have a single entry covering the 30-- entire array. These advantages make them suitable for use as arrays that are 31-- known to be small. 32-- 33-- The card size is 128, so for uses much larger than that, 'Array' would likely 34-- be superior. 35-- 36-- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to 37-- that version, this module simply implements small arrays as 'Array'. 38 39module Data.Primitive.SmallArray 40 ( SmallArray(..) 41 , SmallMutableArray(..) 42 , newSmallArray 43 , readSmallArray 44 , writeSmallArray 45 , copySmallArray 46 , copySmallMutableArray 47 , indexSmallArray 48 , indexSmallArrayM 49 , indexSmallArray## 50 , cloneSmallArray 51 , cloneSmallMutableArray 52 , freezeSmallArray 53 , unsafeFreezeSmallArray 54 , thawSmallArray 55 , runSmallArray 56 , unsafeThawSmallArray 57 , sizeofSmallArray 58 , sizeofSmallMutableArray 59 , smallArrayFromList 60 , smallArrayFromListN 61 , mapSmallArray' 62 , traverseSmallArrayP 63 ) where 64 65 66#if (__GLASGOW_HASKELL__ >= 710) 67#define HAVE_SMALL_ARRAY 1 68#endif 69 70#if MIN_VERSION_base(4,7,0) 71import GHC.Exts hiding (toList) 72import qualified GHC.Exts 73#endif 74 75import Control.Applicative 76import Control.Monad 77import qualified Control.Monad.Fail as Fail 78import Control.Monad.Fix 79import Control.Monad.Primitive 80import Control.Monad.ST 81import Control.Monad.Zip 82import Data.Data 83import Data.Foldable as Foldable 84import Data.Functor.Identity 85#if !(MIN_VERSION_base(4,10,0)) 86import Data.Monoid 87#endif 88#if MIN_VERSION_base(4,9,0) 89import qualified GHC.ST as GHCST 90import qualified Data.Semigroup as Sem 91#endif 92import Text.ParserCombinators.ReadP 93#if MIN_VERSION_base(4,10,0) 94import GHC.Exts (runRW#) 95#elif MIN_VERSION_base(4,9,0) 96import GHC.Base (runRW#) 97#endif 98 99#if !(HAVE_SMALL_ARRAY) 100import Data.Primitive.Array 101import Data.Traversable 102import qualified Data.Primitive.Array as Array 103#endif 104 105#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 106import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) 107#endif 108 109#if HAVE_SMALL_ARRAY 110data SmallArray a = SmallArray (SmallArray# a) 111 deriving Typeable 112#else 113newtype SmallArray a = SmallArray (Array a) deriving 114 ( Eq 115 , Ord 116 , Show 117 , Read 118 , Foldable 119 , Traversable 120 , Functor 121 , Applicative 122 , Alternative 123 , Monad 124 , MonadPlus 125 , MonadZip 126 , MonadFix 127 , Monoid 128 , Typeable 129#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 130 , Eq1 131 , Ord1 132 , Show1 133 , Read1 134#endif 135 ) 136 137#if MIN_VERSION_base(4,7,0) 138instance IsList (SmallArray a) where 139 type Item (SmallArray a) = a 140 fromListN n l = SmallArray (fromListN n l) 141 fromList l = SmallArray (fromList l) 142 toList a = Foldable.toList a 143#endif 144#endif 145 146#if HAVE_SMALL_ARRAY 147data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) 148 deriving Typeable 149#else 150newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a) 151 deriving (Eq, Typeable) 152#endif 153 154-- | Create a new small mutable array. 155newSmallArray 156 :: PrimMonad m 157 => Int -- ^ size 158 -> a -- ^ initial contents 159 -> m (SmallMutableArray (PrimState m) a) 160#if HAVE_SMALL_ARRAY 161newSmallArray (I# i#) x = primitive $ \s -> 162 case newSmallArray# i# x s of 163 (# s', sma# #) -> (# s', SmallMutableArray sma# #) 164#else 165newSmallArray n e = SmallMutableArray `liftM` newArray n e 166#endif 167{-# INLINE newSmallArray #-} 168 169-- | Read the element at a given index in a mutable array. 170readSmallArray 171 :: PrimMonad m 172 => SmallMutableArray (PrimState m) a -- ^ array 173 -> Int -- ^ index 174 -> m a 175#if HAVE_SMALL_ARRAY 176readSmallArray (SmallMutableArray sma#) (I# i#) = 177 primitive $ readSmallArray# sma# i# 178#else 179readSmallArray (SmallMutableArray a) = readArray a 180#endif 181{-# INLINE readSmallArray #-} 182 183-- | Write an element at the given idex in a mutable array. 184writeSmallArray 185 :: PrimMonad m 186 => SmallMutableArray (PrimState m) a -- ^ array 187 -> Int -- ^ index 188 -> a -- ^ new element 189 -> m () 190#if HAVE_SMALL_ARRAY 191writeSmallArray (SmallMutableArray sma#) (I# i#) x = 192 primitive_ $ writeSmallArray# sma# i# x 193#else 194writeSmallArray (SmallMutableArray a) = writeArray a 195#endif 196{-# INLINE writeSmallArray #-} 197 198-- | Look up an element in an immutable array. 199-- 200-- The purpose of returning a result using a monad is to allow the caller to 201-- avoid retaining references to the array. Evaluating the return value will 202-- cause the array lookup to be performed, even though it may not require the 203-- element of the array to be evaluated (which could throw an exception). For 204-- instance: 205-- 206-- > data Box a = Box a 207-- > ... 208-- > 209-- > f sa = case indexSmallArrayM sa 0 of 210-- > Box x -> ... 211-- 212-- 'x' is not a closure that references 'sa' as it would be if we instead 213-- wrote: 214-- 215-- > let x = indexSmallArray sa 0 216-- 217-- And does not prevent 'sa' from being garbage collected. 218-- 219-- Note that 'Identity' is not adequate for this use, as it is a newtype, and 220-- cannot be evaluated without evaluating the element. 221indexSmallArrayM 222 :: Monad m 223 => SmallArray a -- ^ array 224 -> Int -- ^ index 225 -> m a 226#if HAVE_SMALL_ARRAY 227indexSmallArrayM (SmallArray sa#) (I# i#) = 228 case indexSmallArray# sa# i# of 229 (# x #) -> pure x 230#else 231indexSmallArrayM (SmallArray a) = indexArrayM a 232#endif 233{-# INLINE indexSmallArrayM #-} 234 235-- | Look up an element in an immutable array. 236indexSmallArray 237 :: SmallArray a -- ^ array 238 -> Int -- ^ index 239 -> a 240#if HAVE_SMALL_ARRAY 241indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i 242#else 243indexSmallArray (SmallArray a) = indexArray a 244#endif 245{-# INLINE indexSmallArray #-} 246 247-- | Read a value from the immutable array at the given index, returning 248-- the result in an unboxed unary tuple. This is currently used to implement 249-- folds. 250indexSmallArray## :: SmallArray a -> Int -> (# a #) 251#if HAVE_SMALL_ARRAY 252indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i 253#else 254indexSmallArray## (SmallArray a) = indexArray## a 255#endif 256{-# INLINE indexSmallArray## #-} 257 258-- | Create a copy of a slice of an immutable array. 259cloneSmallArray 260 :: SmallArray a -- ^ source 261 -> Int -- ^ offset 262 -> Int -- ^ length 263 -> SmallArray a 264#if HAVE_SMALL_ARRAY 265cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = 266 SmallArray (cloneSmallArray# sa# i# j#) 267#else 268cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j 269#endif 270{-# INLINE cloneSmallArray #-} 271 272-- | Create a copy of a slice of a mutable array. 273cloneSmallMutableArray 274 :: PrimMonad m 275 => SmallMutableArray (PrimState m) a -- ^ source 276 -> Int -- ^ offset 277 -> Int -- ^ length 278 -> m (SmallMutableArray (PrimState m) a) 279#if HAVE_SMALL_ARRAY 280cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = 281 primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of 282 (# s', smb# #) -> (# s', SmallMutableArray smb# #) 283#else 284cloneSmallMutableArray (SmallMutableArray ma) i j = 285 SmallMutableArray `liftM` cloneMutableArray ma i j 286#endif 287{-# INLINE cloneSmallMutableArray #-} 288 289-- | Create an immutable array corresponding to a slice of a mutable array. 290-- 291-- This operation copies the portion of the array to be frozen. 292freezeSmallArray 293 :: PrimMonad m 294 => SmallMutableArray (PrimState m) a -- ^ source 295 -> Int -- ^ offset 296 -> Int -- ^ length 297 -> m (SmallArray a) 298#if HAVE_SMALL_ARRAY 299freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = 300 primitive $ \s -> case freezeSmallArray# sma# i# j# s of 301 (# s', sa# #) -> (# s', SmallArray sa# #) 302#else 303freezeSmallArray (SmallMutableArray ma) i j = 304 SmallArray `liftM` freezeArray ma i j 305#endif 306{-# INLINE freezeSmallArray #-} 307 308-- | Render a mutable array immutable. 309-- 310-- This operation performs no copying, so care must be taken not to modify the 311-- input array after freezing. 312unsafeFreezeSmallArray 313 :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) 314#if HAVE_SMALL_ARRAY 315unsafeFreezeSmallArray (SmallMutableArray sma#) = 316 primitive $ \s -> case unsafeFreezeSmallArray# sma# s of 317 (# s', sa# #) -> (# s', SmallArray sa# #) 318#else 319unsafeFreezeSmallArray (SmallMutableArray ma) = 320 SmallArray `liftM` unsafeFreezeArray ma 321#endif 322{-# INLINE unsafeFreezeSmallArray #-} 323 324-- | Create a mutable array corresponding to a slice of an immutable array. 325-- 326-- This operation copies the portion of the array to be thawed. 327thawSmallArray 328 :: PrimMonad m 329 => SmallArray a -- ^ source 330 -> Int -- ^ offset 331 -> Int -- ^ length 332 -> m (SmallMutableArray (PrimState m) a) 333#if HAVE_SMALL_ARRAY 334thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = 335 primitive $ \s -> case thawSmallArray# sa# o# l# s of 336 (# s', sma# #) -> (# s', SmallMutableArray sma# #) 337#else 338thawSmallArray (SmallArray a) off len = 339 SmallMutableArray `liftM` thawArray a off len 340#endif 341{-# INLINE thawSmallArray #-} 342 343-- | Render an immutable array mutable. 344-- 345-- This operation performs no copying, so care must be taken with its use. 346unsafeThawSmallArray 347 :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) 348#if HAVE_SMALL_ARRAY 349unsafeThawSmallArray (SmallArray sa#) = 350 primitive $ \s -> case unsafeThawSmallArray# sa# s of 351 (# s', sma# #) -> (# s', SmallMutableArray sma# #) 352#else 353unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a 354#endif 355{-# INLINE unsafeThawSmallArray #-} 356 357-- | Copy a slice of an immutable array into a mutable array. 358copySmallArray 359 :: PrimMonad m 360 => SmallMutableArray (PrimState m) a -- ^ destination 361 -> Int -- ^ destination offset 362 -> SmallArray a -- ^ source 363 -> Int -- ^ source offset 364 -> Int -- ^ length 365 -> m () 366#if HAVE_SMALL_ARRAY 367copySmallArray 368 (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = 369 primitive_ $ copySmallArray# src# so# dst# do# l# 370#else 371copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src 372#endif 373{-# INLINE copySmallArray #-} 374 375-- | Copy a slice of one mutable array into another. 376copySmallMutableArray 377 :: PrimMonad m 378 => SmallMutableArray (PrimState m) a -- ^ destination 379 -> Int -- ^ destination offset 380 -> SmallMutableArray (PrimState m) a -- ^ source 381 -> Int -- ^ source offset 382 -> Int -- ^ length 383 -> m () 384#if HAVE_SMALL_ARRAY 385copySmallMutableArray 386 (SmallMutableArray dst#) (I# do#) 387 (SmallMutableArray src#) (I# so#) 388 (I# l#) = 389 primitive_ $ copySmallMutableArray# src# so# dst# do# l# 390#else 391copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) = 392 copyMutableArray dst i src 393#endif 394{-# INLINE copySmallMutableArray #-} 395 396sizeofSmallArray :: SmallArray a -> Int 397#if HAVE_SMALL_ARRAY 398sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) 399#else 400sizeofSmallArray (SmallArray a) = sizeofArray a 401#endif 402{-# INLINE sizeofSmallArray #-} 403 404sizeofSmallMutableArray :: SmallMutableArray s a -> Int 405#if HAVE_SMALL_ARRAY 406sizeofSmallMutableArray (SmallMutableArray sa#) = 407 I# (sizeofSmallMutableArray# sa#) 408#else 409sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma 410#endif 411{-# INLINE sizeofSmallMutableArray #-} 412 413-- | This is the fastest, most straightforward way to traverse 414-- an array, but it only works correctly with a sufficiently 415-- "affine" 'PrimMonad' instance. In particular, it must only produce 416-- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed 417-- monads, for example, will not work right at all. 418traverseSmallArrayP 419 :: PrimMonad m 420 => (a -> m b) 421 -> SmallArray a 422 -> m (SmallArray b) 423#if HAVE_SMALL_ARRAY 424traverseSmallArrayP f = \ !ary -> 425 let 426 !sz = sizeofSmallArray ary 427 go !i !mary 428 | i == sz 429 = unsafeFreezeSmallArray mary 430 | otherwise 431 = do 432 a <- indexSmallArrayM ary i 433 b <- f a 434 writeSmallArray mary i b 435 go (i + 1) mary 436 in do 437 mary <- newSmallArray sz badTraverseValue 438 go 0 mary 439#else 440traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar 441#endif 442{-# INLINE traverseSmallArrayP #-} 443 444-- | Strict map over the elements of the array. 445mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b 446#if HAVE_SMALL_ARRAY 447mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> 448 fix ? 0 $ \go i -> 449 when (i < length sa) $ do 450 x <- indexSmallArrayM sa i 451 let !y = f x 452 writeSmallArray smb i y *> go (i+1) 453#else 454mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar) 455#endif 456{-# INLINE mapSmallArray' #-} 457 458#ifndef HAVE_SMALL_ARRAY 459runSmallArray 460 :: (forall s. ST s (SmallMutableArray s a)) 461 -> SmallArray a 462runSmallArray m = SmallArray $ runArray $ 463 m >>= \(SmallMutableArray mary) -> return mary 464 465#elif !MIN_VERSION_base(4,9,0) 466runSmallArray 467 :: (forall s. ST s (SmallMutableArray s a)) 468 -> SmallArray a 469runSmallArray m = runST $ m >>= unsafeFreezeSmallArray 470 471#else 472-- This low-level business is designed to work with GHC's worker-wrapper 473-- transformation. A lot of the time, we don't actually need an Array 474-- constructor. By putting it on the outside, and being careful about 475-- how we special-case the empty array, we can make GHC smarter about this. 476-- The only downside is that separately created 0-length arrays won't share 477-- their Array constructors, although they'll share their underlying 478-- Array#s. 479runSmallArray 480 :: (forall s. ST s (SmallMutableArray s a)) 481 -> SmallArray a 482runSmallArray m = SmallArray (runSmallArray# m) 483 484runSmallArray# 485 :: (forall s. ST s (SmallMutableArray s a)) 486 -> SmallArray# a 487runSmallArray# m = case runRW# $ \s -> 488 case unST m s of { (# s', SmallMutableArray mary# #) -> 489 unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary# 490 491unST :: ST s a -> State# s -> (# State# s, a #) 492unST (GHCST.ST f) = f 493 494#endif 495 496#if HAVE_SMALL_ARRAY 497-- See the comment on runSmallArray for why we use emptySmallArray#. 498createSmallArray 499 :: Int 500 -> a 501 -> (forall s. SmallMutableArray s a -> ST s ()) 502 -> SmallArray a 503createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) 504createSmallArray n x f = runSmallArray $ do 505 mary <- newSmallArray n x 506 f mary 507 pure mary 508 509emptySmallArray# :: (# #) -> SmallArray# a 510emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar 511{-# NOINLINE emptySmallArray# #-} 512 513die :: String -> String -> a 514die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem 515 516emptySmallArray :: SmallArray a 517emptySmallArray = 518 runST $ newSmallArray 0 (die "emptySmallArray" "impossible") 519 >>= unsafeFreezeSmallArray 520{-# NOINLINE emptySmallArray #-} 521 522 523infixl 1 ? 524(?) :: (a -> b -> c) -> (b -> a -> c) 525(?) = flip 526{-# INLINE (?) #-} 527 528noOp :: a -> ST s () 529noOp = const $ pure () 530 531smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool 532smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1) 533 where 534 loop i 535 | i < 0 536 = True 537 | (# x #) <- indexSmallArray## sa1 i 538 , (# y #) <- indexSmallArray## sa2 i 539 = p x y && loop (i-1) 540 541#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 542-- | @since 0.6.4.0 543instance Eq1 SmallArray where 544#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 545 liftEq = smallArrayLiftEq 546#else 547 eq1 = smallArrayLiftEq (==) 548#endif 549#endif 550 551instance Eq a => Eq (SmallArray a) where 552 sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2 553 554instance Eq (SmallMutableArray s a) where 555 SmallMutableArray sma1# == SmallMutableArray sma2# = 556 isTrue# (sameSmallMutableArray# sma1# sma2#) 557 558smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering 559smallArrayLiftCompare elemCompare a1 a2 = loop 0 560 where 561 mn = length a1 `min` length a2 562 loop i 563 | i < mn 564 , (# x1 #) <- indexSmallArray## a1 i 565 , (# x2 #) <- indexSmallArray## a2 i 566 = elemCompare x1 x2 `mappend` loop (i+1) 567 | otherwise = compare (length a1) (length a2) 568 569#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 570-- | @since 0.6.4.0 571instance Ord1 SmallArray where 572#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 573 liftCompare = smallArrayLiftCompare 574#else 575 compare1 = smallArrayLiftCompare compare 576#endif 577#endif 578 579-- | Lexicographic ordering. Subject to change between major versions. 580instance Ord a => Ord (SmallArray a) where 581 compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2 582 583instance Foldable SmallArray where 584 -- Note: we perform the array lookups eagerly so we won't 585 -- create thunks to perform lookups even if GHC can't see 586 -- that the folding function is strict. 587 foldr f = \z !ary -> 588 let 589 !sz = sizeofSmallArray ary 590 go i 591 | i == sz = z 592 | (# x #) <- indexSmallArray## ary i 593 = f x (go (i+1)) 594 in go 0 595 {-# INLINE foldr #-} 596 foldl f = \z !ary -> 597 let 598 go i 599 | i < 0 = z 600 | (# x #) <- indexSmallArray## ary i 601 = f (go (i-1)) x 602 in go (sizeofSmallArray ary - 1) 603 {-# INLINE foldl #-} 604 foldr1 f = \ !ary -> 605 let 606 !sz = sizeofSmallArray ary - 1 607 go i = 608 case indexSmallArray## ary i of 609 (# x #) | i == sz -> x 610 | otherwise -> f x (go (i+1)) 611 in if sz < 0 612 then die "foldr1" "Empty SmallArray" 613 else go 0 614 {-# INLINE foldr1 #-} 615 foldl1 f = \ !ary -> 616 let 617 !sz = sizeofSmallArray ary - 1 618 go i = 619 case indexSmallArray## ary i of 620 (# x #) | i == 0 -> x 621 | otherwise -> f (go (i - 1)) x 622 in if sz < 0 623 then die "foldl1" "Empty SmallArray" 624 else go sz 625 {-# INLINE foldl1 #-} 626 foldr' f = \z !ary -> 627 let 628 go i !acc 629 | i == -1 = acc 630 | (# x #) <- indexSmallArray## ary i 631 = go (i-1) (f x acc) 632 in go (sizeofSmallArray ary - 1) z 633 {-# INLINE foldr' #-} 634 foldl' f = \z !ary -> 635 let 636 !sz = sizeofSmallArray ary 637 go i !acc 638 | i == sz = acc 639 | (# x #) <- indexSmallArray## ary i 640 = go (i+1) (f acc x) 641 in go 0 z 642 {-# INLINE foldl' #-} 643 null a = sizeofSmallArray a == 0 644 {-# INLINE null #-} 645 length = sizeofSmallArray 646 {-# INLINE length #-} 647 maximum ary | sz == 0 = die "maximum" "Empty SmallArray" 648 | (# frst #) <- indexSmallArray## ary 0 649 = go 1 frst 650 where 651 sz = sizeofSmallArray ary 652 go i !e 653 | i == sz = e 654 | (# x #) <- indexSmallArray## ary i 655 = go (i+1) (max e x) 656 {-# INLINE maximum #-} 657 minimum ary | sz == 0 = die "minimum" "Empty SmallArray" 658 | (# frst #) <- indexSmallArray## ary 0 659 = go 1 frst 660 where sz = sizeofSmallArray ary 661 go i !e 662 | i == sz = e 663 | (# x #) <- indexSmallArray## ary i 664 = go (i+1) (min e x) 665 {-# INLINE minimum #-} 666 sum = foldl' (+) 0 667 {-# INLINE sum #-} 668 product = foldl' (*) 1 669 {-# INLINE product #-} 670 671newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)} 672 673runSTA :: Int -> STA a -> SmallArray a 674runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>= 675 \ (SmallMutableArray ar#) -> m ar# 676{-# INLINE runSTA #-} 677 678newSmallArray_ :: Int -> ST s (SmallMutableArray s a) 679newSmallArray_ !n = newSmallArray n badTraverseValue 680 681badTraverseValue :: a 682badTraverseValue = die "traverse" "bad indexing" 683{-# NOINLINE badTraverseValue #-} 684 685instance Traversable SmallArray where 686 traverse f = traverseSmallArray f 687 {-# INLINE traverse #-} 688 689traverseSmallArray 690 :: Applicative f 691 => (a -> f b) -> SmallArray a -> f (SmallArray b) 692traverseSmallArray f = \ !ary -> 693 let 694 !len = sizeofSmallArray ary 695 go !i 696 | i == len 697 = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary) 698 | (# x #) <- indexSmallArray## ary i 699 = liftA2 (\b (STA m) -> STA $ \mary -> 700 writeSmallArray (SmallMutableArray mary) i b >> m mary) 701 (f x) (go (i + 1)) 702 in if len == 0 703 then pure emptySmallArray 704 else runSTA len <$> go 0 705{-# INLINE [1] traverseSmallArray #-} 706 707{-# RULES 708"traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f 709"traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f 710"traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f = 711 (coerce :: (SmallArray a -> SmallArray (Identity b)) 712 -> SmallArray a -> Identity (SmallArray b)) (fmap f) 713 #-} 714 715 716instance Functor SmallArray where 717 fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> 718 fix ? 0 $ \go i -> 719 when (i < length sa) $ do 720 x <- indexSmallArrayM sa i 721 writeSmallArray smb i (f x) *> go (i+1) 722 {-# INLINE fmap #-} 723 724 x <$ sa = createSmallArray (length sa) x noOp 725 726instance Applicative SmallArray where 727 pure x = createSmallArray 1 x noOp 728 729 sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> 730 fix ? 0 $ \go i -> 731 when (i < la) $ 732 copySmallArray smb 0 sb 0 lb *> go (i+1) 733 where 734 la = length sa ; lb = length sb 735 736 a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma -> 737 let fill off i e = when (i < szb) $ 738 writeSmallArray ma (off+i) e >> fill off (i+1) e 739 go i = when (i < sza) $ do 740 x <- indexSmallArrayM a i 741 fill (i*szb) 0 x 742 go (i+1) 743 in go 0 744 where sza = sizeofSmallArray a ; szb = sizeofSmallArray b 745 746 ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb -> 747 let go1 i = when (i < szab) $ 748 do 749 f <- indexSmallArrayM ab i 750 go2 (i*sza) f 0 751 go1 (i+1) 752 go2 off f j = when (j < sza) $ 753 do 754 x <- indexSmallArrayM a j 755 writeSmallArray mb (off + j) (f x) 756 go2 off f (j + 1) 757 in go1 0 758 where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a 759 760instance Alternative SmallArray where 761 empty = emptySmallArray 762 763 sl <|> sr = 764 createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> 765 copySmallArray sma 0 sl 0 (length sl) 766 *> copySmallArray sma (length sl) sr 0 (length sr) 767 768 many sa | null sa = pure [] 769 | otherwise = die "many" "infinite arrays are not well defined" 770 771 some sa | null sa = emptySmallArray 772 | otherwise = die "some" "infinite arrays are not well defined" 773 774data ArrayStack a 775 = PushArray !(SmallArray a) !(ArrayStack a) 776 | EmptyStack 777-- TODO: This isn't terribly efficient. It would be better to wrap 778-- ArrayStack with a type like 779-- 780-- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a) 781-- 782-- We'd copy incoming arrays into the mutable array until we would 783-- overflow it. Then we'd freeze it, push it on the stack, and continue. 784-- Any sufficiently large incoming arrays would go straight on the stack. 785-- Such a scheme would make the stack much more compact in the case 786-- of many small arrays. 787 788instance Monad SmallArray where 789 return = pure 790 (>>) = (*>) 791 792 sa >>= f = collect 0 EmptyStack (la-1) 793 where 794 la = length sa 795 collect sz stk i 796 | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk 797 | (# x #) <- indexSmallArray## sa i 798 , let sb = f x 799 lsb = length sb 800 -- If we don't perform this check, we could end up allocating 801 -- a stack full of empty arrays if someone is filtering most 802 -- things out. So we refrain from pushing empty arrays. 803 = if lsb == 0 804 then collect sz stk (i-1) 805 else collect (sz + lsb) (PushArray sb stk) (i-1) 806 807 fill _ EmptyStack _ = return () 808 fill off (PushArray sb sbs) smb = 809 copySmallArray smb off sb 0 (length sb) 810 *> fill (off + length sb) sbs smb 811 812#if !(MIN_VERSION_base(4,13,0)) 813 fail = Fail.fail 814#endif 815 816instance Fail.MonadFail SmallArray where 817 fail _ = emptySmallArray 818 819instance MonadPlus SmallArray where 820 mzero = empty 821 mplus = (<|>) 822 823zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c 824zipW nm = \f sa sb -> let mn = length sa `min` length sb in 825 createSmallArray mn (die nm "impossible") $ \mc -> 826 fix ? 0 $ \go i -> when (i < mn) $ do 827 x <- indexSmallArrayM sa i 828 y <- indexSmallArrayM sb i 829 writeSmallArray mc i (f x y) 830 go (i+1) 831{-# INLINE zipW #-} 832 833instance MonadZip SmallArray where 834 mzip = zipW "mzip" (,) 835 mzipWith = zipW "mzipWith" 836 {-# INLINE mzipWith #-} 837 munzip sab = runST $ do 838 let sz = length sab 839 sma <- newSmallArray sz $ die "munzip" "impossible" 840 smb <- newSmallArray sz $ die "munzip" "impossible" 841 fix ? 0 $ \go i -> 842 when (i < sz) $ case indexSmallArray sab i of 843 (x, y) -> do writeSmallArray sma i x 844 writeSmallArray smb i y 845 go $ i+1 846 (,) <$> unsafeFreezeSmallArray sma 847 <*> unsafeFreezeSmallArray smb 848 849instance MonadFix SmallArray where 850 mfix f = createSmallArray (sizeofSmallArray (f err)) 851 (die "mfix" "impossible") $ flip fix 0 $ 852 \r !i !mary -> when (i < sz) $ do 853 writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) 854 r (i + 1) mary 855 where 856 sz = sizeofSmallArray (f err) 857 err = error "mfix for Data.Primitive.SmallArray applied to strict function." 858 859#if MIN_VERSION_base(4,9,0) 860-- | @since 0.6.3.0 861instance Sem.Semigroup (SmallArray a) where 862 (<>) = (<|>) 863 sconcat = mconcat . toList 864#endif 865 866instance Monoid (SmallArray a) where 867 mempty = empty 868#if !(MIN_VERSION_base(4,11,0)) 869 mappend = (<|>) 870#endif 871 mconcat l = createSmallArray n (die "mconcat" "impossible") $ \ma -> 872 let go !_ [ ] = return () 873 go off (a:as) = 874 copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as 875 in go 0 l 876 where n = sum . fmap length $ l 877 878instance IsList (SmallArray a) where 879 type Item (SmallArray a) = a 880 fromListN = smallArrayFromListN 881 fromList = smallArrayFromList 882 toList = Foldable.toList 883 884smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS 885smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $ 886 showString "fromListN " . shows (length sa) . showString " " 887 . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa) 888 889-- this need to be included for older ghcs 890listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS 891listLiftShowsPrec _ sl _ = sl 892 893instance Show a => Show (SmallArray a) where 894 showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa 895 896#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 897-- | @since 0.6.4.0 898instance Show1 SmallArray where 899#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 900 liftShowsPrec = smallArrayLiftShowsPrec 901#else 902 showsPrec1 = smallArrayLiftShowsPrec showsPrec showList 903#endif 904#endif 905 906smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) 907smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do 908 () <$ string "fromListN" 909 skipSpaces 910 n <- readS_to_P reads 911 skipSpaces 912 l <- readS_to_P listReadsPrec 913 return $ smallArrayFromListN n l 914 915instance Read a => Read (SmallArray a) where 916 readsPrec = smallArrayLiftReadsPrec readsPrec readList 917 918#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) 919-- | @since 0.6.4.0 920instance Read1 SmallArray where 921#if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) 922 liftReadsPrec = smallArrayLiftReadsPrec 923#else 924 readsPrec1 = smallArrayLiftReadsPrec readsPrec readList 925#endif 926#endif 927 928 929 930smallArrayDataType :: DataType 931smallArrayDataType = 932 mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] 933 934fromListConstr :: Constr 935fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix 936 937instance Data a => Data (SmallArray a) where 938 toConstr _ = fromListConstr 939 dataTypeOf _ = smallArrayDataType 940 gunfold k z c = case constrIndex c of 941 1 -> k (z fromList) 942 _ -> die "gunfold" "SmallArray" 943 gfoldl f z m = z fromList `f` toList m 944 945instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where 946 toConstr _ = die "toConstr" "SmallMutableArray" 947 gunfold _ _ = die "gunfold" "SmallMutableArray" 948 dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" 949#endif 950 951-- | Create a 'SmallArray' from a list of a known length. If the length 952-- of the list does not match the given length, this throws an exception. 953smallArrayFromListN :: Int -> [a] -> SmallArray a 954#if HAVE_SMALL_ARRAY 955smallArrayFromListN n l = 956 createSmallArray n 957 (die "smallArrayFromListN" "uninitialized element") $ \sma -> 958 let go !ix [] = if ix == n 959 then return () 960 else die "smallArrayFromListN" "list length less than specified size" 961 go !ix (x : xs) = if ix < n 962 then do 963 writeSmallArray sma ix x 964 go (ix+1) xs 965 else die "smallArrayFromListN" "list length greater than specified size" 966 in go 0 l 967#else 968smallArrayFromListN n l = SmallArray (Array.fromListN n l) 969#endif 970 971-- | Create a 'SmallArray' from a list. 972smallArrayFromList :: [a] -> SmallArray a 973smallArrayFromList l = smallArrayFromListN (length l) l 974