packages feed

primitive-extras 0.3.0.1 → 0.4

raw patch · 24 files changed

+1046/−416 lines, 24 filesdep +QuickCheckdep +focusdep +primitive-extrasdep ~deferred-folds

Dependencies added: QuickCheck, focus, primitive-extras, quickcheck-instances, rerebase, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: deferred-folds

Files

+ library/PrimitiveExtras/Bitmap.hs view
@@ -0,0 +1,114 @@+module PrimitiveExtras.Bitmap+(+  Bitmap,+  empty,+  singleton,+  insert,+  invert,+  indexList,+  boolList,+  pair,+  populatedIndex,+  isPopulated,+  population,+  null,+  bits,+  populatedIndicesList,+  int,+  allBitsList,+  allBitsUnfold,+  populatedBitsUnfold,+  indicesAmongstPopulatedBitsUnfold,+)+where++import PrimitiveExtras.Prelude hiding (traverse_, insert, null, empty)+import PrimitiveExtras.Types+import qualified DeferredFolds.Unfold as Unfold+++{-# NOINLINE maxSize #-}+maxSize :: Int+maxSize = finiteBitSize (undefined :: Int)++{-# NOINLINE maxBit #-}+maxBit :: Int+maxBit = pred maxSize++{-# NOINLINE allBitsList #-}+allBitsList :: [Int]+allBitsList = [0 .. maxBit]++-- * Constructors+-------------------------++{-# INLINE empty #-}+empty :: Bitmap+empty = Bitmap 0++{-# INLINE singleton #-}+singleton :: Int -> Bitmap+singleton = Bitmap . bit++{-# INLINE insert #-}+insert :: Int -> Bitmap -> Bitmap+insert i = Bitmap . (bit i .|.) . int++{-# INLINE invert #-}+invert :: Int -> Bitmap -> Bitmap+invert i = Bitmap . (bit i `xor`) . int++{-# INLINE indexList #-}+indexList :: [Int] -> Bitmap+indexList = Bitmap . foldr (.|.) 0 . map bit++{-# INLINE boolList #-}+boolList :: [Bool] -> Bitmap+boolList = Bitmap . foldr (.|.) 0 . zipWith (\ index -> bool 0 (bit index)) allBitsList++{-# INLINE pair #-}+pair :: Int -> Int -> Bitmap+pair i1 i2 = Bitmap (bit i1 .|. bit i2)++-- * Accessors+-------------------------++-- |+-- A number of non-zero bits, preceding this one.+{-# INLINE populatedIndex #-}+populatedIndex :: Int -> Bitmap -> Int+populatedIndex i (Bitmap int) = popCount (int .&. (bit i - 1))++{-# INLINE isPopulated #-}+isPopulated :: Int -> Bitmap -> Bool+isPopulated index (Bitmap int) = testBit int index++{-# INLINE population #-}+population :: Bitmap -> Int+population (Bitmap int) = popCount int++{-# INLINE null #-}+null :: Bitmap -> Bool+null (Bitmap int) = int == 0++{-# INLINE bits #-}+bits :: Bitmap -> [Int]+bits (Bitmap int) = filter (testBit int) allBitsList++{-# INLINE populatedIndicesList #-}+populatedIndicesList :: Bitmap -> [Int]+populatedIndicesList = enumFromTo 0 . pred . population++{-# INLINE int #-}+int :: Bitmap -> Int+int (Bitmap int) = int++{-# NOINLINE allBitsUnfold #-}+allBitsUnfold :: Unfold Int+allBitsUnfold = Unfold.intsInRange 0 maxBit++populatedBitsUnfold :: Bitmap -> Unfold Int+populatedBitsUnfold bitmap = Unfold.filter (flip isPopulated bitmap) allBitsUnfold++indicesAmongstPopulatedBitsUnfold :: Bitmap -> Unfold Int+indicesAmongstPopulatedBitsUnfold bitmap = Unfold.intsInRange 0 (pred (population bitmap))
− library/PrimitiveExtras/Cereal/Get.hs 
@@ -1,20 +0,0 @@-module PrimitiveExtras.Cereal.Get-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types-import Data.Serialize.Get-import PrimitiveExtras.Monad---primArray :: Prim element => Get element -> Get (PrimArray element)-primArray element =-  do-    size <- fromIntegral <$> getInt64le-    replicateMPrimArray size element--primMultiArray :: Prim element => Get element -> Get (PrimMultiArray element)-primMultiArray element =-  do-    size <- fromIntegral <$> getInt64le-    replicateMMultiPrimArray size (primArray element)
− library/PrimitiveExtras/Cereal/Put.hs 
@@ -1,22 +0,0 @@-module PrimitiveExtras.Cereal.Put-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types-import Data.Serialize.Put-import qualified PrimitiveExtras.Monad as Monad---primArray :: Prim element => Putter element -> Putter (PrimArray element)-primArray element primArrayValue =-  size <> elements-  where-    size = putInt64le (fromIntegral (sizeofPrimArray primArrayValue))-    elements = traversePrimArray_ element primArrayValue--primMultiArray :: Prim element => Putter element -> Putter (PrimMultiArray element)-primMultiArray element (PrimMultiArray outerArrayValue) =-  size <> innerArrays-  where-    size = putInt64le (fromIntegral (sizeofUnliftedArray outerArrayValue))-    innerArrays = Monad.traverseUnliftedArray_ (primArray element) outerArrayValue
− library/PrimitiveExtras/Data.hs 
@@ -1,10 +0,0 @@-module PrimitiveExtras.Data-(-  PrimMultiArray,-  TVarArray,-)-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types-import PrimitiveExtras.Instances
− library/PrimitiveExtras/Fold.hs 
@@ -1,88 +0,0 @@-module PrimitiveExtras.Fold-(-  indexCounts,-  unliftedArray,-  primMultiArray,-)-where--import PrimitiveExtras.Prelude hiding (fold, foldM)-import PrimitiveExtras.Types-import Control.Foldl-import qualified PrimitiveExtras.UnliftedArray as UA---unsafeIO :: (state -> input -> IO state) -> IO state -> (state -> IO output) -> Fold input output-unsafeIO stepInIO initInIO extractInIO =-  Fold-    (\ !state input -> unsafeDupablePerformIO (stepInIO state input))-    (unsafeDupablePerformIO initInIO)-    (\ state -> let !output = unsafePerformIO (extractInIO state) in output)--foldMInUnsafeDupableIO :: FoldM IO input output -> Fold input output-foldMInUnsafeDupableIO (FoldM step init extract) = unsafeIO step init extract--{-|-Given a size of the array,-construct a fold, which produces an array of index counts.--}-indexCounts :: (Integral count, Prim count) => Int {-^ Array size -} -> Fold Int (PrimArray count)-indexCounts size = unsafeIO step init extract where-  init = unsafeThawPrimArray (replicatePrimArray size 0)-  step mutable i = do-    count <- readPrimArray mutable i-    writePrimArray mutable i (succ count)-    return mutable-  extract = unsafeFreezePrimArray--{-|-This function is partial in the sense that it expects the-index vector of produced elements to be within the specified amount.--}-unliftedArray :: PrimUnlifted element => Int {-^ Size of the array -} -> Fold (Int, element) (UnliftedArray element)-unliftedArray size =-  unsafeIO step init extract-  where-    step mutable (index, element) =-      writeUnliftedArray mutable index element $> mutable-    init =-      unsafeNewUnliftedArray size-    extract =-      unsafeFreezeUnliftedArray--{-|-Having a priorly computed array of inner dimension sizes,-e.g., using the 'indexCounts' fold,-construct a fold over indexed elements into a multi-array of elements.--Thus it allows to construct it in two passes over the indexed elements.--}-primMultiArray :: forall size element. (Integral size, Prim size, Prim element) => PrimArray size -> Fold (Int, element) (PrimMultiArray element)-primMultiArray sizeArray =-  unsafeIO step init extract-  where-    outerLength = sizeofPrimArray sizeArray-    init =-      Product2 <$> initIndexArray <*> initMultiArray-      where-        initIndexArray :: IO (MutablePrimArray RealWorld size)-        initIndexArray =-          unsafeThawPrimArray (replicatePrimArray outerLength 0)-        initMultiArray :: IO (UnliftedArray (MutablePrimArray RealWorld element))-        initMultiArray =-          UA.generate outerLength $ \ index -> do-            newPrimArray (fromIntegral (indexPrimArray sizeArray index))-    step (Product2 indexArray multiArray) (outerIndex, element) = do-      innerArray <- indexUnliftedArrayM multiArray outerIndex-      innerIndex <- readPrimArray indexArray outerIndex-      writePrimArray indexArray outerIndex (succ innerIndex)-      writePrimArray innerArray (fromIntegral innerIndex) element-      return (Product2 indexArray multiArray)-    extract (Product2 _ multiArray) = do-      copied <- unsafeNewUnliftedArray outerLength-      forMFromZero_ outerLength $ \ outerIndex -> do-        let mutableInnerArray = indexUnliftedArray multiArray outerIndex-        frozenInnerArray <- unsafeFreezePrimArray mutableInnerArray-        writeUnliftedArray copied outerIndex frozenInnerArray-      result <- unsafeFreezeUnliftedArray copied-      return $ PrimMultiArray $ result
+ library/PrimitiveExtras/Folds.hs view
@@ -0,0 +1,88 @@+module PrimitiveExtras.Folds+(+  indexCounts,+  unliftedArray,+  primMultiArray,+)+where++import PrimitiveExtras.Prelude hiding (fold, foldM)+import PrimitiveExtras.Types+import Control.Foldl+import qualified PrimitiveExtras.UnliftedArray as UA+++unsafeIO :: (state -> input -> IO state) -> IO state -> (state -> IO output) -> Fold input output+unsafeIO stepInIO initInIO extractInIO =+  Fold+    (\ !state input -> unsafeDupablePerformIO (stepInIO state input))+    (unsafeDupablePerformIO initInIO)+    (\ state -> let !output = unsafePerformIO (extractInIO state) in output)++foldMInUnsafeDupableIO :: FoldM IO input output -> Fold input output+foldMInUnsafeDupableIO (FoldM step init extract) = unsafeIO step init extract++{-|+Given a size of the array,+construct a fold, which produces an array of index counts.+-}+indexCounts :: (Integral count, Prim count) => Int {-^ Array size -} -> Fold Int (PrimArray count)+indexCounts size = unsafeIO step init extract where+  init = unsafeThawPrimArray (replicatePrimArray size 0)+  step mutable i = do+    count <- readPrimArray mutable i+    writePrimArray mutable i (succ count)+    return mutable+  extract = unsafeFreezePrimArray++{-|+This function is partial in the sense that it expects the+index vector of produced elements to be within the specified amount.+-}+unliftedArray :: PrimUnlifted element => Int {-^ Size of the array -} -> Fold (Int, element) (UnliftedArray element)+unliftedArray size =+  unsafeIO step init extract+  where+    step mutable (index, element) =+      writeUnliftedArray mutable index element $> mutable+    init =+      unsafeNewUnliftedArray size+    extract =+      unsafeFreezeUnliftedArray++{-|+Having a priorly computed array of inner dimension sizes,+e.g., using the 'indexCounts' fold,+construct a fold over indexed elements into a multi-array of elements.++Thus it allows to construct it in two passes over the indexed elements.+-}+primMultiArray :: forall size element. (Integral size, Prim size, Prim element) => PrimArray size -> Fold (Int, element) (PrimMultiArray element)+primMultiArray sizeArray =+  unsafeIO step init extract+  where+    outerLength = sizeofPrimArray sizeArray+    init =+      Product2 <$> initIndexArray <*> initMultiArray+      where+        initIndexArray :: IO (MutablePrimArray RealWorld size)+        initIndexArray =+          unsafeThawPrimArray (replicatePrimArray outerLength 0)+        initMultiArray :: IO (UnliftedArray (MutablePrimArray RealWorld element))+        initMultiArray =+          UA.generate outerLength $ \ index -> do+            newPrimArray (fromIntegral (indexPrimArray sizeArray index))+    step (Product2 indexArray multiArray) (outerIndex, element) = do+      innerArray <- indexUnliftedArrayM multiArray outerIndex+      innerIndex <- readPrimArray indexArray outerIndex+      writePrimArray indexArray outerIndex (succ innerIndex)+      writePrimArray innerArray (fromIntegral innerIndex) element+      return (Product2 indexArray multiArray)+    extract (Product2 _ multiArray) = do+      copied <- unsafeNewUnliftedArray outerLength+      forMFromZero_ outerLength $ \ outerIndex -> do+        let mutableInnerArray = indexUnliftedArray multiArray outerIndex+        frozenInnerArray <- unsafeFreezePrimArray mutableInnerArray+        writeUnliftedArray copied outerIndex frozenInnerArray+      result <- unsafeFreezeUnliftedArray copied+      return $ PrimMultiArray $ result
− library/PrimitiveExtras/IO.hs 
@@ -1,110 +0,0 @@-module PrimitiveExtras.IO-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types-import qualified PrimitiveExtras.UnliftedArray as A----- * UnliftedArray----------------------------generateUnliftedArray :: PrimUnlifted a => Int -> (Int -> IO a) -> IO (UnliftedArray a)-generateUnliftedArray = A.generate--replicateUnliftedArray :: PrimUnlifted a => Int -> IO a -> IO (UnliftedArray a)-replicateUnliftedArray = A.replicateIO---- * Array----------------------------generateArray :: Int -> (Int -> IO a) -> IO (Array a)-generateArray size elementIO =-  do-    array <- newArray size undefined-    let-      loop index =-        if index < size-          then do-            element <- elementIO index-            writeArray array index element-            loop (succ index)-          else unsafeFreezeArray array-      in loop 0--replicateArray :: Int -> IO a -> IO (Array a)-replicateArray size elementIO =-  do-    array <- newArray size undefined-    let-      loop index =-        if index < size-          then do-            element <- elementIO-            writeArray array index element-            loop (succ index)-          else unsafeFreezeArray array-      in loop 0---- * PrimArray----------------------------generatePrimArray :: Prim a => Int -> (Int -> IO a) -> IO (PrimArray a)-generatePrimArray size elementIO =-  do-    array <- newPrimArray size-    let-      loop index =-        if index < size-          then do-            element <- elementIO index-            writePrimArray array index element-            loop (succ index)-          else unsafeFreezePrimArray array-      in loop 0--replicatePrimArray :: Prim a => Int -> IO a -> IO (PrimArray a)-replicatePrimArray size elementIO =-  do-    array <- newPrimArray size-    let-      loop index =-        if index < size-          then do-            element <- elementIO-            writePrimArray array index element-            loop (succ index)-          else unsafeFreezePrimArray array-      in loop 0--traversePrimArrayWithIndexInRange :: Prim a => PrimArray a -> Int -> Int -> (Int -> a -> IO ()) -> IO ()-traversePrimArrayWithIndexInRange primArray from to action =-  let iterate index = if index < to-        then do-          action index $! indexPrimArray primArray index-          iterate (succ index)-        else return ()-      in iterate from---- * TVarArray----------------------------newTVarArray :: a -> Int -> IO (TVarArray a)-newTVarArray a size = TVarArray <$> replicateUnliftedArray size (newTVarIO a)--freezeTVarArrayAsPrimArray :: Prim a => TVarArray a -> IO (PrimArray a)-freezeTVarArrayAsPrimArray (TVarArray varArray) =-  do-    let size = sizeofUnliftedArray varArray-    mpa <- newPrimArray size-    forMFromZero_ size $ \ index -> do-      var <- indexUnliftedArrayM varArray index-      value <- atomically (readTVar var)-      writePrimArray mpa index value-    unsafeFreezePrimArray mpa--modifyTVarArrayAt :: TVarArray a -> Int -> (a -> a) -> IO ()-modifyTVarArrayAt (TVarArray array) index fn =-  do-    var <- indexUnliftedArrayM array index-    atomically $ modifyTVar' var fn
− library/PrimitiveExtras/Instances.hs 
@@ -1,15 +0,0 @@-module PrimitiveExtras.Instances-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types--deriving instance (Eq a, Prim a) => Eq (PrimMultiArray a)--deriving instance (Ord a, Prim a) => Ord (PrimMultiArray a)--instance (Show a, Prim a) => Show (PrimMultiArray a) where-  show (PrimMultiArray outerArray) =-    unliftedArrayToList outerArray &-    map primArrayToList &-    show
− library/PrimitiveExtras/Monad.hs 
@@ -1,56 +0,0 @@-module PrimitiveExtras.Monad-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types-import qualified PrimitiveExtras.Fold as A---{-| Given a size of the outer array and a function, which executes a fold over indexed elements in a monad,-constructs a prim multi-array -}-primMultiArray :: (Monad m, Prim element) => Int -> (forall x. Fold (Int, element) x -> m x) -> m (PrimMultiArray element)-primMultiArray outerArraySize runFold =-  do-    indexCounts <- runFold (lmap fst (A.indexCounts outerArraySize))-    runFold (A.primMultiArray (indexCounts :: PrimArray Word32))--replicateMMultiPrimArray :: (Monad m, Prim a) => Int -> m (PrimArray a) -> m (PrimMultiArray a)-replicateMMultiPrimArray size elementM =-  do-    !mutable <- return (unsafeDupablePerformIO (unsafeNewUnliftedArray size))-    let -      iterate index =-        if index < size-          then do-            element <- elementM-            let !() = unsafeDupablePerformIO (writeUnliftedArray mutable index element)-            iterate (succ index)-          else return (PrimMultiArray (unsafePerformIO (unsafeFreezeUnliftedArray mutable)))-      in iterate 0--{-| Please notice that this function is highly untested -}-replicateMPrimArray :: (Monad m, Prim element) => Int -> m element -> m (PrimArray element)-replicateMPrimArray size elementM =-  do-    !mutable <- return (unsafeDupablePerformIO (newPrimArray size))-    let -      iterate index =-        if index < size-          then do-            element <- elementM-            let !() = unsafeDupablePerformIO (writePrimArray mutable index element)-            iterate (succ index)-          else return (unsafePerformIO (unsafeFreezePrimArray mutable))-      in iterate 0--traverseUnliftedArray_ :: (Monad m, PrimUnlifted a) => (a -> m ()) -> UnliftedArray a -> m ()-traverseUnliftedArray_ action array =-  let-    size = sizeofUnliftedArray array-    iterate index = if index < size-      then do-        element <- indexUnliftedArrayM array index-        action element-        iterate (succ index)-      else return ()-    in iterate 0
library/PrimitiveExtras/Prelude.hs view
@@ -31,6 +31,7 @@ import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) import Data.Functor as Exports+import Data.Functor.Identity as Exports import Data.Int as Exports import Data.IORef as Exports import Data.Ix as Exports@@ -91,6 +92,10 @@ ------------------------- import Data.Primitive as Exports import Control.Monad.Primitive as Exports++-- focus+-------------------------+import Focus as Exports (Focus(..))   data Product2 a b = Product2 !a !b
+ library/PrimitiveExtras/PrimArray.hs view
@@ -0,0 +1,101 @@+module PrimitiveExtras.PrimArray+where++import PrimitiveExtras.Prelude hiding (replicateM, traverse_)+import PrimitiveExtras.Types+import qualified Data.Serialize as Cereal+import qualified Data.Vector.Unboxed as UnboxedVector+import qualified Data.Vector.Primitive as PrimitiveVector+++oneHot :: Prim a => Int {-^ Size -} -> Int {-^ Index -} -> a -> PrimArray a+oneHot size index value =+  runST $ do+    marr <- newPrimArray size+    writePrimArray marr index value+    unsafeFreezePrimArray marr++generate :: Prim a => Int -> (Int -> IO a) -> IO (PrimArray a)+generate size elementIO =+  do+    array <- newPrimArray size+    let+      loop index =+        if index < size+          then do+            element <- elementIO index+            writePrimArray array index element+            loop (succ index)+          else unsafeFreezePrimArray array+      in loop 0++replicate :: Prim a => Int -> IO a -> IO (PrimArray a)+replicate size elementIO =+  do+    array <- newPrimArray size+    let+      loop index =+        if index < size+          then do+            element <- elementIO+            writePrimArray array index element+            loop (succ index)+          else unsafeFreezePrimArray array+      in loop 0++{-| Please notice that this function is highly untested -}+replicateM :: (Monad m, Prim element) => Int -> m element -> m (PrimArray element)+replicateM size elementM =+  do+    !mutable <- return (unsafeDupablePerformIO (newPrimArray size))+    let +      iterate index =+        if index < size+          then do+            element <- elementM+            let !() = unsafeDupablePerformIO (writePrimArray mutable index element)+            iterate (succ index)+          else return (unsafePerformIO (unsafeFreezePrimArray mutable))+      in iterate 0++traverse_ = traversePrimArray_++traverseWithIndexInRange_ :: Prim a => PrimArray a -> Int -> Int -> (Int -> a -> IO ()) -> IO ()+traverseWithIndexInRange_ primArray from to action =+  let iterate index = if index < to+        then do+          action index $! indexPrimArray primArray index+          iterate (succ index)+        else return ()+      in iterate from++toElementsUnfold :: Prim prim => PrimArray prim -> Unfold prim+toElementsUnfold ba = Unfold $ \f z -> foldlPrimArray' f z ba++toElementsUnfoldM :: (Monad m, Prim prim) => PrimArray prim -> UnfoldM m prim+toElementsUnfoldM ba = UnfoldM $ \f z -> foldlPrimArrayM' f z ba++toByteArray :: PrimArray a -> ByteArray+toByteArray (PrimArray unliftedByteArray) =+  ByteArray unliftedByteArray++toPrimitiveVector :: Prim a => PrimArray a -> PrimitiveVector.Vector a+toPrimitiveVector primArray =+  PrimitiveVector.Vector 0 (sizeofPrimArray primArray) (toByteArray primArray)++toUnboxedVector :: Prim a => PrimArray a -> UnboxedVector.Vector a+toUnboxedVector primArray =+  unsafeCoerce (toPrimitiveVector primArray)++cerealGet :: Prim element => Cereal.Get element -> Cereal.Get (PrimArray element)+cerealGet element =+  do+    size <- fromIntegral <$> Cereal.getInt64le+    replicateM size element++cerealPut :: Prim element => Cereal.Putter element -> Cereal.Putter (PrimArray element)+cerealPut element primArrayValue =+  size <> elements+  where+    size = Cereal.putInt64le (fromIntegral (sizeofPrimArray primArrayValue))+    elements = traverse_ element primArrayValue
+ library/PrimitiveExtras/PrimMultiArray.hs view
@@ -0,0 +1,97 @@+module PrimitiveExtras.PrimMultiArray+(+  PrimMultiArray,+  create,+  replicateM,+  outerLength,+  toAssocsUnfold,+  toIndicesUnfold,+  toUnfoldAt,+  toAssocsUnfoldM,+  toIndicesUnfoldM,+  toUnfoldAtM,+  cerealGet,+  cerealPut,+)+where++import PrimitiveExtras.Prelude hiding (replicateM)+import PrimitiveExtras.Types+import qualified DeferredFolds.Unfold as Unfold+import qualified DeferredFolds.UnfoldM as UnfoldM+import qualified PrimitiveExtras.UnliftedArray as UnliftedArray+import qualified PrimitiveExtras.PrimArray as PrimArray+import qualified PrimitiveExtras.Folds as Folds+import qualified Data.Serialize as Cereal+++deriving instance (Eq a, Prim a) => Eq (PrimMultiArray a)++deriving instance (Ord a, Prim a) => Ord (PrimMultiArray a)++instance (Show a, Prim a) => Show (PrimMultiArray a) where+  show (PrimMultiArray outerArray) =+    unliftedArrayToList outerArray &+    map primArrayToList &+    show++{-| Given a size of the outer array and a function, which executes a fold over indexed elements in a monad,+constructs a prim multi-array -}+create :: (Monad m, Prim element) => Int -> (forall x. Fold (Int, element) x -> m x) -> m (PrimMultiArray element)+create outerArraySize runFold =+  do+    indexCounts <- runFold (lmap fst (Folds.indexCounts outerArraySize))+    runFold (Folds.primMultiArray (indexCounts :: PrimArray Word32))++replicateM :: (Monad m, Prim a) => Int -> m (PrimArray a) -> m (PrimMultiArray a)+replicateM size elementM =+  do+    !mutable <- return (unsafeDupablePerformIO (unsafeNewUnliftedArray size))+    let +      iterate index =+        if index < size+          then do+            element <- elementM+            let !() = unsafeDupablePerformIO (writeUnliftedArray mutable index element)+            iterate (succ index)+          else return (PrimMultiArray (unsafePerformIO (unsafeFreezeUnliftedArray mutable)))+      in iterate 0++{-| Get length of the outer dimension of a primitive multi array -}+outerLength :: PrimMultiArray a -> Int+outerLength (PrimMultiArray outerDimension) = sizeofUnliftedArray outerDimension++toAssocsUnfold :: Prim a => PrimMultiArray a -> Unfold (Int, a)+toAssocsUnfold = Unfold.unfoldM . toAssocsUnfoldM++toIndicesUnfold :: PrimMultiArray a -> Unfold Int+toIndicesUnfold (PrimMultiArray ua) = Unfold.intsInRange 0 (pred (sizeofUnliftedArray ua))++toUnfoldAt :: Prim prim => PrimMultiArray prim -> Int -> Unfold prim+toUnfoldAt (PrimMultiArray ua) index = UnliftedArray.at ua index empty PrimArray.toElementsUnfold++toAssocsUnfoldM :: (Monad m, Prim a) => PrimMultiArray a -> UnfoldM m (Int, a)+toAssocsUnfoldM pma =+  do+    index <- toIndicesUnfoldM pma+    element <- toUnfoldAtM pma index+    return (index, element)++toIndicesUnfoldM :: Monad m => PrimMultiArray a -> UnfoldM m Int+toIndicesUnfoldM (PrimMultiArray ua) = UnfoldM.intsInRange 0 (pred (sizeofUnliftedArray ua))++toUnfoldAtM :: (Monad m, Prim prim) => PrimMultiArray prim -> Int -> UnfoldM m prim+toUnfoldAtM (PrimMultiArray ua) index = UnliftedArray.at ua index empty PrimArray.toElementsUnfoldM++cerealGet :: Prim element => Cereal.Get element -> Cereal.Get (PrimMultiArray element)+cerealGet element =+  do+    size <- fromIntegral <$> Cereal.getInt64le+    replicateM size (PrimArray.cerealGet element)++cerealPut :: Prim element => Cereal.Putter element -> Cereal.Putter (PrimMultiArray element)+cerealPut element (PrimMultiArray outerArrayValue) =+  size <> innerArrays+  where+    size = Cereal.putInt64le (fromIntegral (sizeofUnliftedArray outerArrayValue))+    innerArrays = UnliftedArray.traverse_ (PrimArray.cerealPut element) outerArrayValue
− library/PrimitiveExtras/Pure.hs 
@@ -1,31 +0,0 @@-module PrimitiveExtras.Pure-where--import PrimitiveExtras.Prelude-import PrimitiveExtras.Types-import qualified Data.Vector.Unboxed as A-import qualified Data.Vector.Primitive as B---{-| Get length of the outer dimension of a primitive multi array -}-primMultiArrayOuterLength :: PrimMultiArray a -> Int-primMultiArrayOuterLength (PrimMultiArray outerDimension) = sizeofUnliftedArray outerDimension--oneHotPrimArray :: Prim a => Int {-^ Size -} -> Int {-^ Index -} -> a -> PrimArray a-oneHotPrimArray size index value =-  runST $ do-    marr <- newPrimArray size-    writePrimArray marr index value-    unsafeFreezePrimArray marr--primArrayByteArray :: PrimArray a -> ByteArray-primArrayByteArray (PrimArray unliftedByteArray) =-  ByteArray unliftedByteArray--primArrayPrimitiveVector :: Prim a => PrimArray a -> B.Vector a-primArrayPrimitiveVector primArray =-  B.Vector 0 (sizeofPrimArray primArray) (primArrayByteArray primArray)--primArrayUnboxedVector :: Prim a => PrimArray a -> A.Vector a-primArrayUnboxedVector primArray =-  unsafeCoerce (primArrayPrimitiveVector primArray)
+ library/PrimitiveExtras/SmallArray.hs view
@@ -0,0 +1,170 @@+module PrimitiveExtras.SmallArray+where++import PrimitiveExtras.Prelude+import PrimitiveExtras.Types+import GHC.Exts hiding (toList)+import qualified Focus+++{-# INLINE empty #-}+empty :: SmallArray a+empty = runSmallArray (newSmallArray 0 undefined)++{-| A workaround for the weird forcing of 'undefined' values int 'newSmallArray' -}+{-# INLINE newEmptySmallArray #-}+newEmptySmallArray :: PrimMonad m => Int -> m (SmallMutableArray (PrimState m) a)+newEmptySmallArray size = newSmallArray size (unsafeCoerce 0)++{-# INLINE list #-}+list :: [a] -> SmallArray a+list list =+  let+    !size = length list+    in runSmallArray $ do+      m <- newEmptySmallArray size+      let populate index list = case list of+            element : list -> do+              writeSmallArray m index element+              populate (succ index) list+            [] -> return m+          in populate 0 list++-- |+-- Remove an element.+{-# INLINE unset #-}+unset :: Int -> SmallArray a -> SmallArray a+unset index array =+  {-# SCC "unset" #-}+  let !size = sizeofSmallArray array+      !newSize = pred size+      !newIndex = succ index+      !amountOfFollowingElements = size - newIndex+      in runSmallArray $ do+        newMa <- newSmallArray newSize undefined+        copySmallArray newMa 0 array 0 index+        copySmallArray newMa index array newIndex amountOfFollowingElements+        return newMa++{-# INLINE set #-}+set :: Int -> a -> SmallArray a -> SmallArray a+set index a array =+  {-# SCC "set" #-} +  let+    !size = sizeofSmallArray array+    in runSmallArray $ do+      newMa <- newSmallArray size undefined+      copySmallArray newMa 0 array 0 size+      writeSmallArray newMa index a+      return newMa++{-# INLINE insert #-}+insert :: Int -> a -> SmallArray a -> SmallArray a+insert index a array =+  {-# SCC "insert" #-} +  let+    !size = sizeofSmallArray array+    !newSize = succ size+    !nextIndex = succ index+    !amountOfFollowingElements = size - index+    in runSmallArray $ do+      newMa <- newSmallArray newSize a+      copySmallArray newMa 0 array 0 index+      copySmallArray newMa nextIndex array index amountOfFollowingElements+      return newMa++{-# INLINE cons #-}+cons :: a -> SmallArray a -> SmallArray a+cons a array =+  {-# SCC "cons" #-} +  let+    size = sizeofSmallArray array+    newSize = succ size+    in runSmallArray $ do+      newMa <- newSmallArray newSize a+      copySmallArray newMa 1 array 0 size+      return newMa++{-# INLINABLE orderedPair #-}+orderedPair :: Int -> e -> Int -> e -> SmallArray e+orderedPair i1 e1 i2 e2 =+  {-# SCC "orderedPair" #-} +  runSmallArray $ if +    | i1 < i2 -> do+      a <- newSmallArray 2 e1+      writeSmallArray a 1 e2+      return a+    | i1 > i2 -> do+      a <- newSmallArray 2 e1+      writeSmallArray a 0 e2+      return a+    | otherwise -> do+      a <- newSmallArray 1 e2+      return a++{-# INLINE find #-}+find :: (a -> Bool) -> SmallArray a -> Maybe a+find test array =+  {-# SCC "find" #-} +  let+    !size = sizeofSmallArray array+    iterate index = if index < size+      then let+        element = indexSmallArray array index+        in if test element+          then Just element+          else iterate (succ index)+      else Nothing+    in iterate 0++{-# INLINE findWithIndex #-}+findWithIndex :: (a -> Bool) -> SmallArray a -> Maybe (Int, a)+findWithIndex test array =+  {-# SCC "findWithIndex" #-} +  let+    !size = sizeofSmallArray array+    iterate index = if index < size+      then let+        element = indexSmallArray array index+        in if test element+          then Just (index, element)+          else iterate (succ index)+      else Nothing+    in iterate 0++{-# INLINABLE elementsUnfoldM #-}+elementsUnfoldM :: Monad m => SmallArray e -> UnfoldM m e+elementsUnfoldM array = UnfoldM $ \ step initialState -> let+  !size = sizeofSmallArray array+  iterate index !state = if index < size+    then do+      element <- indexSmallArrayM array index+      newState <- step state element+      iterate (succ index) newState+    else return state+  in iterate 0 initialState++{-# INLINABLE onFoundElementFocus #-}+onFoundElementFocus :: (Monad m, Eq a) => (a -> Bool) -> Focus a m b -> Focus (SmallArray a) m b+onFoundElementFocus testA (Focus concealA revealA) = Focus concealArray revealArray where+  concealArray = fmap (fmap arrayChange) concealA where+    arrayChange = \ case+      Focus.Set newValue -> Focus.Set (pure newValue)+      _ -> Focus.Leave+  revealArray array = case findWithIndex testA array of+    Just (index, value) -> fmap (fmap arrayChange) (revealA value) where+      arrayChange = \ case+        Focus.Leave -> Focus.Leave+        Focus.Set newValue -> if newValue == value+          then Focus.Leave+          else Focus.Set (set index newValue array)+        Focus.Remove -> if sizeofSmallArray array > 1+          then Focus.Set (unset index array)+          else Focus.Remove+    Nothing -> fmap (fmap arrayChange) concealA where+      arrayChange = \ case+        Focus.Set newValue -> Focus.Set (cons newValue array)+        _ -> Focus.Leave++toList :: forall a. SmallArray a -> [a]+toList array = PrimitiveExtras.Prelude.toList (elementsUnfoldM array :: UnfoldM Identity a)
+ library/PrimitiveExtras/SparseSmallArray.hs view
@@ -0,0 +1,157 @@+module PrimitiveExtras.SparseSmallArray+(+  SparseSmallArray,+  empty,+  singleton,+  maybeList,+  pair,+  insert,+  replace,+  unset,+  lookup,+  toMaybeList,+  elementsUnfold,+  elementsUnfoldM,+  onElementAtFocus,+)+where++import PrimitiveExtras.Prelude hiding (lookup, empty, insert)+import PrimitiveExtras.Types+import qualified PrimitiveExtras.Bitmap as Bitmap+import qualified PrimitiveExtras.SmallArray as SmallArray+import qualified Focus+import qualified Control.Foldl as Foldl+++{-# INLINE empty #-}+empty :: SparseSmallArray e+empty = SparseSmallArray Bitmap.empty SmallArray.empty++-- |+-- An array with a single element at the specified index.+{-# INLINE singleton #-}+singleton :: Int -> e -> SparseSmallArray e+singleton i e = +  let b = Bitmap.singleton i+      a = runST $ newSmallArray 1 e >>= unsafeFreezeSmallArray+      in SparseSmallArray b a++{-# INLINE pair #-}+pair :: Int -> e -> Int -> e -> SparseSmallArray e+pair i1 e1 i2 e2 =+  {-# SCC "pair" #-} +  SparseSmallArray bitmap array+  where +    bitmap = Bitmap.pair i1 i2+    array = SmallArray.orderedPair i1 e1 i2 e2++{-# INLINE maybeList #-}+maybeList :: [Maybe e] -> SparseSmallArray e+maybeList list =+  SparseSmallArray (Bitmap.boolList (map isJust list)) (SmallArray.list (catMaybes list))++{-|+Insert an element value at the index.+It's your obligation to ensure that the index is empty before the operation.+-}+{-# INLINE insert #-}+insert :: Int -> e -> SparseSmallArray e -> SparseSmallArray e+insert i e (SparseSmallArray b a) =+  {-# SCC "insert" #-} +  let+    sparseIndex = Bitmap.populatedIndex i b+    in SparseSmallArray (Bitmap.insert i b) (SmallArray.insert sparseIndex e a)+    +{-# INLINE replace #-}+replace :: Int -> e -> SparseSmallArray e -> SparseSmallArray e+replace i e (SparseSmallArray b a) =+  {-# SCC "replace" #-} +  let+    sparseIndex = Bitmap.populatedIndex i b+    in SparseSmallArray b (SmallArray.set sparseIndex e a)++-- |+-- Remove an element.+{-# INLINE unset #-}+unset :: Int -> SparseSmallArray e -> SparseSmallArray e+unset i (SparseSmallArray b a) =+  {-# SCC "unset" #-}+  if Bitmap.isPopulated i b+    then+      let+        sparseIndex = Bitmap.populatedIndex i b+        b' = Bitmap.invert i b+        a' = SmallArray.unset sparseIndex a+        in SparseSmallArray b' a'+    else SparseSmallArray b a++-- |+-- Lookup an item at the index.+{-# INLINE lookup #-}+lookup :: Int -> SparseSmallArray e -> Maybe e+lookup i (SparseSmallArray b a) =+  {-# SCC "lookup" #-} +  if Bitmap.isPopulated i b+    then Just (indexSmallArray a (Bitmap.populatedIndex i b))+    else Nothing++-- |+-- Convert into a list representation.+{-# INLINE toMaybeList #-}+toMaybeList :: SparseSmallArray e -> [Maybe e]+toMaybeList ssa = do+  i <- Bitmap.allBitsList+  return (lookup i ssa)++{-# INLINE elementsUnfold #-}+elementsUnfold :: SparseSmallArray e -> Unfold e+elementsUnfold (SparseSmallArray _ array) = Unfold (\ f z -> foldl' f z array)++{-# INLINE elementsUnfoldM #-}+elementsUnfoldM :: Monad m => SparseSmallArray a -> UnfoldM m a+elementsUnfoldM (SparseSmallArray _ array) = SmallArray.elementsUnfoldM array++{-# INLINABLE onElementAtFocus #-}+onElementAtFocus :: Monad m => Int -> Focus a m b -> Focus (SparseSmallArray a) m b+onElementAtFocus index (Focus concealA revealA) = Focus concealSsa revealSsa where+  concealSsa = fmap (fmap aChangeToSsaChange) concealA where+    aChangeToSsaChange = \ case+      Focus.Leave -> Focus.Leave+      Focus.Set a -> Focus.Set (SparseSmallArray (Bitmap.singleton index) (pure a))+      Focus.Remove -> Focus.Leave+  revealSsa (SparseSmallArray indices array) =+    fmap (fmap aChangeToSsaChange) $+    if Bitmap.isPopulated index indices +      then do+        a <- indexSmallArrayM array (Bitmap.populatedIndex index indices)+        revealA a+      else concealA+    where+      aChangeToSsaChange = \ case+        Focus.Leave -> Focus.Leave+        Focus.Set a -> if Bitmap.isPopulated index indices+          then let+            newArray = SmallArray.set index a array+            in Focus.Set (SparseSmallArray indices newArray)+          else let+            newIndices = Bitmap.insert index indices+            newArray = SmallArray.insert index a array+            in Focus.Set (SparseSmallArray newIndices newArray)+        Focus.Remove -> let+          newIndices = Bitmap.invert index indices+          in if Bitmap.null newIndices+            then Focus.Remove+            else let+              newArray = SmallArray.unset index array+              in Focus.Set (SparseSmallArray newIndices newArray)++{-# INLINE focusAt #-}+focusAt :: Monad m => Focus a m b -> Int -> SparseSmallArray a -> m (b, SparseSmallArray a)+focusAt aFocus index = case onElementAtFocus index aFocus of+  Focus conceal reveal -> \ ssa -> do+    (b, change) <- reveal ssa+    return $ (b,) $ case change of+      Focus.Leave -> ssa+      Focus.Set newSsa -> newSsa+      Focus.Remove -> empty
+ library/PrimitiveExtras/TVarArray.hs view
@@ -0,0 +1,33 @@+module PrimitiveExtras.TVarArray+(+  TVarArray,+  new,+  freezeAsPrimArray,+  modifyAt,+)+where++import PrimitiveExtras.Prelude+import PrimitiveExtras.Types+import qualified PrimitiveExtras.UnliftedArray as UnliftedArray+++new :: a -> Int -> IO (TVarArray a)+new a size = TVarArray <$> UnliftedArray.replicateIO size (newTVarIO a)++freezeAsPrimArray :: Prim a => TVarArray a -> IO (PrimArray a)+freezeAsPrimArray (TVarArray varArray) =+  do+    let size = sizeofUnliftedArray varArray+    mpa <- newPrimArray size+    forMFromZero_ size $ \ index -> do+      var <- indexUnliftedArrayM varArray index+      value <- atomically (readTVar var)+      writePrimArray mpa index value+    unsafeFreezePrimArray mpa++modifyAt :: TVarArray a -> Int -> (a -> a) -> IO ()+modifyAt (TVarArray array) index fn =+  do+    var <- indexUnliftedArrayM array index+    atomically $ modifyTVar' var fn
library/PrimitiveExtras/Types.hs view
@@ -7,3 +7,14 @@ newtype PrimMultiArray a = PrimMultiArray (UnliftedArray (PrimArray a))  newtype TVarArray a = TVarArray (UnliftedArray (TVar a))++{-|+An immutable space-efficient sparse array, +which can only store not more than 32 or 64 elements depending on the system architecure.+-}+data SparseSmallArray e = SparseSmallArray !Bitmap !(SmallArray e)++{-|+A word-size set of ints.+-}+newtype Bitmap = Bitmap Int
− library/PrimitiveExtras/Unfold.hs 
@@ -1,24 +0,0 @@-module PrimitiveExtras.Unfold-where--import PrimitiveExtras.Prelude hiding (fold)-import PrimitiveExtras.Types-import DeferredFolds.Unfold-import qualified PrimitiveExtras.Fold as A-import qualified PrimitiveExtras.UnliftedArray as B-import qualified PrimitiveExtras.UnfoldM as C---primMultiArrayAssocs :: Prim a => PrimMultiArray a -> Unfold (Int, a)-primMultiArrayAssocs = unfoldM . C.primMultiArrayAssocs--primMultiArrayIndices :: PrimMultiArray a -> Unfold Int-primMultiArrayIndices (PrimMultiArray ua) =-  intsInRange 0 (pred (sizeofUnliftedArray ua))--primMultiArrayAt :: Prim prim => PrimMultiArray prim -> Int -> Unfold prim-primMultiArrayAt (PrimMultiArray ua) index =-  B.at ua index empty primArray--primArray :: Prim prim => PrimArray prim -> Unfold prim-primArray ba = Unfold $ \f z -> foldlPrimArray' f z ba
− library/PrimitiveExtras/UnfoldM.hs 
@@ -1,27 +0,0 @@-module PrimitiveExtras.UnfoldM-where--import PrimitiveExtras.Prelude hiding (fold)-import PrimitiveExtras.Types-import DeferredFolds.UnfoldM-import qualified PrimitiveExtras.Fold as A-import qualified PrimitiveExtras.UnliftedArray as B---primMultiArrayAssocs :: (Monad m, Prim a) => PrimMultiArray a -> UnfoldM m (Int, a)-primMultiArrayAssocs pma =-  do-    index <- primMultiArrayIndices pma-    element <- primMultiArrayAt pma index-    return (index, element)--primMultiArrayIndices :: Monad m => PrimMultiArray a -> UnfoldM m Int-primMultiArrayIndices (PrimMultiArray ua) =-  intsInRange 0 (pred (sizeofUnliftedArray ua))--primMultiArrayAt :: (Monad m, Prim prim) => PrimMultiArray prim -> Int -> UnfoldM m prim-primMultiArrayAt (PrimMultiArray ua) index =-  B.at ua index empty primArray--primArray :: (Monad m, Prim prim) => PrimArray prim -> UnfoldM m prim-primArray ba = UnfoldM $ \f z -> foldlPrimArrayM' f z ba
library/PrimitiveExtras/UnliftedArray.hs view
@@ -11,6 +11,7 @@     then none     else some (indexUnliftedArray ua index) +{-# INLINABLE replicateIO #-} replicateIO :: PrimUnlifted a => Int -> IO a -> IO (UnliftedArray a) replicateIO size elementIO =   do@@ -25,6 +26,7 @@           else unsafeFreezeUnliftedArray array       in loop 0 +{-# INLINABLE generate #-} generate :: PrimUnlifted a => Int -> (Int -> IO a) -> IO (UnliftedArray a) generate size elementIO =   do@@ -38,3 +40,15 @@             loop (succ index)           else unsafeFreezeUnliftedArray array       in loop 0++traverse_ :: (Monad m, PrimUnlifted a) => (a -> m ()) -> UnliftedArray a -> m ()+traverse_ action array =+  let+    size = sizeofUnliftedArray array+    iterate index = if index < size+      then do+        element <- indexUnliftedArrayM array index+        action element+        iterate (succ index)+      else return ()+    in iterate 0
primitive-extras.cabal view
@@ -1,7 +1,7 @@ name:   primitive-extras version:-  0.3.0.1+  0.4 category:   Primitive synopsis:@@ -39,25 +39,48 @@   default-language:     Haskell2010   exposed-modules:-    PrimitiveExtras.Data-    PrimitiveExtras.Monad-    PrimitiveExtras.IO-    PrimitiveExtras.Unfold-    PrimitiveExtras.UnfoldM-    PrimitiveExtras.Fold-    PrimitiveExtras.Pure-    PrimitiveExtras.Cereal.Get-    PrimitiveExtras.Cereal.Put-  other-modules:+    PrimitiveExtras.Bitmap+    PrimitiveExtras.SmallArray+    PrimitiveExtras.SparseSmallArray+    PrimitiveExtras.TVarArray+    PrimitiveExtras.PrimArray     PrimitiveExtras.UnliftedArray+    PrimitiveExtras.PrimMultiArray+  other-modules:     PrimitiveExtras.Prelude     PrimitiveExtras.Types-    PrimitiveExtras.Instances+    PrimitiveExtras.Folds   build-depends:     base >=4.7 && <5,     cereal >=0.5.5 && <0.6,-    deferred-folds >=0.6 && <0.7,+    deferred-folds >=0.6.5 && <0.7,+    focus >=0.11.2.1 && <0.12,     foldl >=1 && <2,     primitive >=0.6.4 && <0.7,     profunctors >=5 && <6,     vector >=0.12 && <0.13++test-suite test+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    test+  main-is:+    Main.hs+  other-modules:+    Main.Gens+    Main.Transaction+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    deferred-folds,+    focus,+    primitive-extras,+    QuickCheck >=2.8.1 && <3,+    quickcheck-instances >=0.3.11 && <0.4,+    rerebase <2,+    tasty >=0.12 && <2,+    tasty-hunit >=0.9 && <0.11,+    tasty-quickcheck >=0.9 && <0.11
+ test/Main.hs view
@@ -0,0 +1,81 @@+module Main where++import Prelude+import Test.QuickCheck.Instances+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import PrimitiveExtras.SparseSmallArray (SparseSmallArray)+import qualified Test.QuickCheck as QuickCheck+import qualified Test.QuickCheck.Property as QuickCheck+import qualified Main.Transaction as Transaction+import qualified Main.Gens as Gen+import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+import qualified PrimitiveExtras.SmallArray as SmallArray+++main =+  defaultMain $+  testGroup "All" $+  [+    testGroup "SmallArray" $+    [+      testCase "set" $ let+        array = SmallArray.list [1, 2, 3]+        in assertEqual ""+          [1, 4, 3]+          (SmallArray.toList (SmallArray.set 1 4 array))+      ,+      testCase "insert" $ let+        array = SmallArray.list [1, 2, 3]+        in assertEqual ""+          [1, 4, 2, 3]+          (SmallArray.toList (SmallArray.insert 1 4 array))+      ,+      testCase "unset" $ let+        array = SmallArray.list [1, 2, 3]+        in assertEqual ""+          [1, 3]+          (SmallArray.toList (SmallArray.unset 1 array))+    ]+    ,+    testGroup "SparseSmallArray" $+    [+      testCase "empty" $ do+        assertEqual ""+          (replicate (finiteBitSize (undefined :: Int)) Nothing)+          (SparseSmallArray.toMaybeList (SparseSmallArray.empty :: SparseSmallArray Int32))+      ,+      testProperty "toMaybeList, maybeList" $ forAll Gen.maybeList $ \ maybeList ->+      maybeList === SparseSmallArray.toMaybeList (SparseSmallArray.maybeList maybeList)+      ,+      testCase "unset" $ assertEqual ""+        ([Just 1, Nothing, Nothing, Just 3] <> replicate (finiteBitSize (undefined :: Int) - 4) Nothing)+        (SparseSmallArray.toMaybeList (SparseSmallArray.unset 1 (SparseSmallArray.maybeList [Just 1, Just 2, Nothing, Just 3])))+      ,+      testTransactionProperty "set" Gen.setTransaction+      ,+      testTransactionProperty "unset" Gen.unsetTransaction+      ,+      testTransactionProperty "unfold" Gen.unfoldTransaction+      ,+      testTransactionProperty "lookup" Gen.lookupTransaction+      ,+      testTransactionProperty "composite" Gen.transaction+    ]+  ]++testTransactionProperty name transactionGen =+  testProperty (showString "Transaction: " name) $+  forAll ((,) <$> Gen.maybeList <*> transactionGen) $ \ (maybeList, transaction) ->+  case transaction of+    Transaction.Transaction name applyToMaybeList applyToSparseSmallArray -> let+      ssa = SparseSmallArray.maybeList maybeList+      (result1, newMaybeList) = runState applyToMaybeList maybeList+      (result2, newSsa) = runState applyToSparseSmallArray ssa+      newSsaMaybeList = SparseSmallArray.toMaybeList newSsa+      in+        QuickCheck.counterexample+          ("transaction: " <> show name <> "\nnewMaybeList1: " <> show newMaybeList <> "\nnewMaybeList2: " <> show newSsaMaybeList <> "\nresult1: " <> show result1 <> "\nresult2: " <> show result2)+          (newMaybeList == SparseSmallArray.toMaybeList newSsa && result1 == result2)
+ test/Main/Gens.hs view
@@ -0,0 +1,48 @@+module Main.Gens where++import Prelude hiding (choose, index)+import Test.QuickCheck.Gen+import Focus (Focus(..))+import Main.Transaction (Transaction)+import qualified Main.Transaction as Transaction+import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+++element :: Gen Int+element = choose (0, 999)++index :: Gen Int+index = choose (0, 9)++lookupTransaction :: (Show element, Eq element) => Gen (Transaction element)+lookupTransaction = Transaction.lookup <$> index++setTransaction :: Gen (Transaction Int)+setTransaction = Transaction.set <$> index <*> element++unsetTransaction :: Gen (Transaction element)+unsetTransaction = Transaction.unset <$> index++unfoldTransaction :: (Show element, Eq element) => Gen (Transaction element)+unfoldTransaction = pure Transaction.elementsUnfold++transaction :: Gen (Transaction Int)+transaction =+  frequency+    [+      (9, lookupTransaction),+      (9, setTransaction),+      (9, unsetTransaction)+    ]++maybeList :: Gen [Maybe Int]+maybeList =+  replicateM (finiteBitSize (undefined :: Int)) $ frequency $+  [+    (4, fmap Just element),+    (1, pure Nothing)+  ]++sparseSmallArray :: Gen (SparseSmallArray.SparseSmallArray Int)+sparseSmallArray =+  SparseSmallArray.maybeList <$> maybeList
+ test/Main/Transaction.hs view
@@ -0,0 +1,91 @@+module Main.Transaction where++import Prelude+import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+import qualified Data.Text as Text+import qualified DeferredFolds.Unfold as Unfold+++data Transaction element = forall result. (Show result, Eq result) => Transaction {+  name :: Text,+  applyToMaybeList :: State [Maybe element] result,+  applyToSparseSmallArray :: State (SparseSmallArray.SparseSmallArray element) result+}++instance Show (Transaction element) where+  show = Text.unpack . name++singleton :: Show element => Int -> element -> Transaction element+singleton index element =+  Transaction {+    name = "singleton " <> (fromString . show) index <> " " <> fromString (show element)+    ,+    applyToMaybeList =+      put $ map (\i' -> if index == i' then Just element else Nothing) [0 .. pred (finiteBitSize (undefined :: Int))]+    ,+    applyToSparseSmallArray =+      put $ SparseSmallArray.singleton index element+  }++set :: Show element => Int -> element -> Transaction element+set index element =+  Transaction {+    name = "set " <> (fromString . show) index <> " " <> (fromString . show) element+    ,+    applyToMaybeList = do+      l <- get+      put $ do+        (i', e') <- zip [0..] l+        return $ if index == i' then Just element else e'+    ,+    applyToSparseSmallArray = do+      ssa <- get+      case SparseSmallArray.lookup index ssa of+        Just _ -> put (SparseSmallArray.replace index element ssa)+        Nothing -> put (SparseSmallArray.insert index element ssa)+  }++unset :: Int -> Transaction element+unset index =+  Transaction {+    name = "unset " <> fromString (show index)+    ,+    applyToMaybeList = do+      l <- get+      put $ do+        (i', e') <- zip [0..] l+        return $ if index == i' then Nothing else e'+    ,+    applyToSparseSmallArray =+      get >>= put . (SparseSmallArray.unset index)+  }++lookup :: (Show element, Eq element) => Int -> Transaction element+lookup index =+  Transaction {+    name = "lookup " <> fromString (show index),+    applyToMaybeList = fmap (join . fmap fst . uncons . drop index) get,+    applyToSparseSmallArray = fmap (SparseSmallArray.lookup index) get+  }++elementsUnfold :: (Show element, Eq element) => Transaction element+elementsUnfold =+  Transaction {+    name = "elementsUnfold",+    applyToMaybeList = do+      list <- get+      return $ do+        maybeElement <- Unfold.foldable list+        element <- Unfold.foldable maybeElement+        return element,+    applyToSparseSmallArray = fmap SparseSmallArray.elementsUnfold get+  }++-- focusInsert :: Show element => Int -> element -> Transaction element+-- focusInsert index element =+--   Transaction {+--     name = "focusInsert " <> (fromString . show) index <> " " <> (fromString . show) element,+--     applyToMaybeList = do+--       list <- get++--   }