primitive-extras 0.8.2 → 0.9
raw patch · 8 files changed
+236/−236 lines, 8 files
Files
- library/PrimitiveExtras/Bitmap.hs +6/−6
- library/PrimitiveExtras/By6Bits.hs +198/−0
- library/PrimitiveExtras/SparseSmallArray.hs +0/−198
- library/PrimitiveExtras/Types.hs +3/−3
- primitive-extras.cabal +2/−2
- test/Main.hs +11/−11
- test/Main/Gens.hs +3/−3
- test/Main/Transaction.hs +13/−13
library/PrimitiveExtras/Bitmap.hs view
@@ -14,7 +14,7 @@ null, bits, populatedIndicesList,- int,+ int64, allBitsList, allBitsUnfoldl, populatedBitsUnfoldl,@@ -54,11 +54,11 @@ {-# INLINE insert #-} insert :: Int -> Bitmap -> Bitmap-insert i = Bitmap . (bit i .|.) . int+insert i = Bitmap . (bit i .|.) . int64 {-# INLINE invert #-} invert :: Int -> Bitmap -> Bitmap-invert i = Bitmap . (bit i `xor`) . int+invert i = Bitmap . (bit i `xor`) . int64 {-# INLINE indexList #-} indexList :: [Int] -> Bitmap@@ -101,9 +101,9 @@ populatedIndicesList :: Bitmap -> [Int] populatedIndicesList = enumFromTo 0 . pred . population -{-# INLINE int #-}-int :: Bitmap -> Int-int (Bitmap int) = int+{-# INLINE int64 #-}+int64 :: Bitmap -> Int64+int64 (Bitmap int) = int {-# NOINLINE allBitsUnfoldl #-} allBitsUnfoldl :: Unfoldl Int
+ library/PrimitiveExtras/By6Bits.hs view
@@ -0,0 +1,198 @@+module PrimitiveExtras.By6Bits+(+ By6Bits,+ empty,+ singleton,+ maybeList,+ pair,+ insert,+ replace,+ update,+ unset,+ lookup,+ focusAt,+ toMaybeList,+ toIndexedList,+ elementsUnfoldl,+ elementsUnfoldlM,+ elementsListT,+ onElementAtFocus,+ null,+)+where++import PrimitiveExtras.Prelude hiding (lookup, empty, insert, null)+import PrimitiveExtras.Types+import qualified PrimitiveExtras.Prelude as Prelude+import qualified PrimitiveExtras.Bitmap as Bitmap+import qualified PrimitiveExtras.SmallArray as SmallArray+import qualified Focus+import qualified Control.Foldl as Foldl+++instance Show a => Show (By6Bits a) where+ show = show . toMaybeList++deriving instance Eq a => Eq (By6Bits a)++instance Foldable By6Bits where+ {-# INLINE foldr #-}+ foldr step state = foldr step state . elementsUnfoldl+ {-# INLINE foldl' #-}+ foldl' step state = foldl' step state . elementsUnfoldl+ {-# INLINE foldMap #-}+ foldMap monoid = foldMap monoid . elementsUnfoldl++{-# INLINE empty #-}+empty :: By6Bits e+empty = By6Bits Bitmap.empty Prelude.empty++-- |+-- An array with a single element at the specified index.+{-# INLINE singleton #-}+singleton :: Int -> e -> By6Bits e+singleton i e = + let b = Bitmap.singleton i+ a = runST $ newSmallArray 1 e >>= unsafeFreezeSmallArray+ in By6Bits b a++{-# INLINE pair #-}+pair :: Int -> e -> Int -> e -> By6Bits e+pair i1 e1 i2 e2 =+ {-# SCC "pair" #-} + By6Bits bitmap array+ where + bitmap = Bitmap.pair i1 i2+ array = SmallArray.orderedPair i1 e1 i2 e2++{-# INLINE maybeList #-}+maybeList :: [Maybe e] -> By6Bits e+maybeList list =+ By6Bits (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 -> By6Bits e -> By6Bits e+insert i e (By6Bits b a) =+ {-# SCC "insert" #-} + let+ sparseIndex = Bitmap.populatedIndex i b+ in By6Bits (Bitmap.insert i b) (SmallArray.insert sparseIndex e a)+ +{-# INLINE replace #-}+replace :: Int -> e -> By6Bits e -> By6Bits e+replace i e (By6Bits b a) =+ {-# SCC "replace" #-} + let+ sparseIndex = Bitmap.populatedIndex i b+ in By6Bits b (SmallArray.set sparseIndex e a)++{-# INLINE update #-}+update :: (e -> e) -> Int -> By6Bits e -> By6Bits e+update fn i (By6Bits b a) =+ let+ sparseIndex = Bitmap.populatedIndex i b+ in+ By6Bits b+ (SmallArray.unsafeUpdate fn sparseIndex a)++-- |+-- Remove an element.+{-# INLINE unset #-}+unset :: Int -> By6Bits e -> By6Bits e+unset i (By6Bits 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 By6Bits b' a'+ else By6Bits b a++-- |+-- Lookup an item at the index.+{-# INLINE lookup #-}+lookup :: Int -> By6Bits e -> Maybe e+lookup i (By6Bits 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 :: By6Bits e -> [Maybe e]+toMaybeList ssa = do+ i <- Bitmap.allBitsList+ return (lookup i ssa)++{-# INLINE toIndexedList #-}+toIndexedList :: By6Bits e -> [(Int, e)]+toIndexedList = catMaybes . zipWith (\i -> fmap (i,)) [0..] . toMaybeList++{-# INLINE elementsUnfoldl #-}+elementsUnfoldl :: By6Bits e -> Unfoldl e+elementsUnfoldl (By6Bits _ array) = Unfoldl (\ f z -> foldl' f z array)++{-# INLINE elementsUnfoldlM #-}+elementsUnfoldlM :: Monad m => By6Bits a -> UnfoldlM m a+elementsUnfoldlM (By6Bits _ array) = SmallArray.elementsUnfoldlM array++{-# INLINE elementsListT #-}+elementsListT :: By6Bits a -> ListT STM a+elementsListT (By6Bits _ array) = SmallArray.elementsListT array++{-# INLINE onElementAtFocus #-}+onElementAtFocus :: Monad m => Int -> Focus a m b -> Focus (By6Bits 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 (By6Bits (Bitmap.singleton index) (pure a))+ Focus.Remove -> Focus.Leave+ revealSsa (By6Bits indices array) =+ fmap (fmap aChangeToSsaChange) $+ if Bitmap.isPopulated index indices + then do+ a <- indexSmallArrayM array (Bitmap.populatedIndex index indices)+ revealA a+ else concealA+ where+ sparseIndex = Bitmap.populatedIndex index indices+ aChangeToSsaChange = \ case+ Focus.Leave -> Focus.Leave+ Focus.Set a -> if Bitmap.isPopulated index indices+ then let+ newArray = SmallArray.set sparseIndex a array+ in Focus.Set (By6Bits indices newArray)+ else let+ newIndices = Bitmap.insert index indices+ newArray = SmallArray.insert sparseIndex a array+ in Focus.Set (By6Bits newIndices newArray)+ Focus.Remove -> let+ newIndices = Bitmap.invert index indices+ in if Bitmap.null newIndices+ then Focus.Remove+ else let+ newArray = SmallArray.unset sparseIndex array+ in Focus.Set (By6Bits newIndices newArray)++{-# INLINE focusAt #-}+focusAt :: Monad m => Focus a m b -> Int -> By6Bits a -> m (b, By6Bits 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++{-# INLINE null #-}+null :: By6Bits a -> Bool+null (By6Bits bm _) = Bitmap.null bm
− library/PrimitiveExtras/SparseSmallArray.hs
@@ -1,198 +0,0 @@-module PrimitiveExtras.SparseSmallArray-(- SparseSmallArray,- empty,- singleton,- maybeList,- pair,- insert,- replace,- update,- unset,- lookup,- focusAt,- toMaybeList,- toIndexedList,- elementsUnfoldl,- elementsUnfoldlM,- elementsListT,- onElementAtFocus,- null,-)-where--import PrimitiveExtras.Prelude hiding (lookup, empty, insert, null)-import PrimitiveExtras.Types-import qualified PrimitiveExtras.Prelude as Prelude-import qualified PrimitiveExtras.Bitmap as Bitmap-import qualified PrimitiveExtras.SmallArray as SmallArray-import qualified Focus-import qualified Control.Foldl as Foldl---instance Show a => Show (SparseSmallArray a) where- show = show . toMaybeList--deriving instance Eq a => Eq (SparseSmallArray a)--instance Foldable SparseSmallArray where- {-# INLINE foldr #-}- foldr step state = foldr step state . elementsUnfoldl- {-# INLINE foldl' #-}- foldl' step state = foldl' step state . elementsUnfoldl- {-# INLINE foldMap #-}- foldMap monoid = foldMap monoid . elementsUnfoldl--{-# INLINE empty #-}-empty :: SparseSmallArray e-empty = SparseSmallArray Bitmap.empty Prelude.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)--{-# INLINE update #-}-update :: (e -> e) -> Int -> SparseSmallArray e -> SparseSmallArray e-update fn i (SparseSmallArray b a) =- let- sparseIndex = Bitmap.populatedIndex i b- in- SparseSmallArray b- (SmallArray.unsafeUpdate fn sparseIndex 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 toIndexedList #-}-toIndexedList :: SparseSmallArray e -> [(Int, e)]-toIndexedList = catMaybes . zipWith (\i -> fmap (i,)) [0..] . toMaybeList--{-# INLINE elementsUnfoldl #-}-elementsUnfoldl :: SparseSmallArray e -> Unfoldl e-elementsUnfoldl (SparseSmallArray _ array) = Unfoldl (\ f z -> foldl' f z array)--{-# INLINE elementsUnfoldlM #-}-elementsUnfoldlM :: Monad m => SparseSmallArray a -> UnfoldlM m a-elementsUnfoldlM (SparseSmallArray _ array) = SmallArray.elementsUnfoldlM array--{-# INLINE elementsListT #-}-elementsListT :: SparseSmallArray a -> ListT STM a-elementsListT (SparseSmallArray _ array) = SmallArray.elementsListT array--{-# INLINE 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- sparseIndex = Bitmap.populatedIndex index indices- aChangeToSsaChange = \ case- Focus.Leave -> Focus.Leave- Focus.Set a -> if Bitmap.isPopulated index indices- then let- newArray = SmallArray.set sparseIndex a array- in Focus.Set (SparseSmallArray indices newArray)- else let- newIndices = Bitmap.insert index indices- newArray = SmallArray.insert sparseIndex 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 sparseIndex 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--{-# INLINE null #-}-null :: SparseSmallArray a -> Bool-null (SparseSmallArray bm _) = Bitmap.null bm
library/PrimitiveExtras/Types.hs view
@@ -8,11 +8,11 @@ {-| An immutable space-efficient sparse array, -which can only store not more than 32 or 64 elements depending on the system architecure.+which can only store not more than 64 elements. -}-data SparseSmallArray e = SparseSmallArray {-# UNPACK #-} !Bitmap {-# UNPACK #-} !(SmallArray e)+data By6Bits e = By6Bits {-# UNPACK #-} !Bitmap {-# UNPACK #-} !(SmallArray e) {-| A word-size set of ints. -}-newtype Bitmap = Bitmap Int+newtype Bitmap = Bitmap Int64
primitive-extras.cabal view
@@ -1,5 +1,5 @@ name: primitive-extras-version: 0.8.2+version: 0.9 category: Primitive synopsis: Extras for the "primitive" library homepage: https://github.com/metrix-ai/primitive-extras@@ -22,8 +22,8 @@ default-language: Haskell2010 exposed-modules: PrimitiveExtras.Bitmap+ PrimitiveExtras.By6Bits PrimitiveExtras.SmallArray- PrimitiveExtras.SparseSmallArray PrimitiveExtras.PrimArray PrimitiveExtras.UnliftedArray PrimitiveExtras.PrimMultiArray
test/Main.hs view
@@ -7,13 +7,13 @@ import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import PrimitiveExtras.SparseSmallArray (SparseSmallArray)+import PrimitiveExtras.By6Bits (By6Bits) import qualified Focus 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.By6Bits as By6Bits import qualified PrimitiveExtras.SmallArray as SmallArray import qualified PrimitiveExtras.PrimArray as PrimArray import qualified Data.Serialize as Serialize@@ -63,19 +63,19 @@ (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement Focus.delete (== 2) (const False) array)))) ] ,- testGroup "SparseSmallArray" $+ testGroup "By6Bits" $ [ testCase "empty" $ do assertEqual "" (replicate (finiteBitSize (undefined :: Int)) Nothing)- (SparseSmallArray.toMaybeList (SparseSmallArray.empty :: SparseSmallArray Int32))+ (By6Bits.toMaybeList (By6Bits.empty :: By6Bits Int32)) , testProperty "toMaybeList, maybeList" $ forAll Gen.maybeList $ \ maybeList ->- maybeList === SparseSmallArray.toMaybeList (SparseSmallArray.maybeList maybeList)+ maybeList === By6Bits.toMaybeList (By6Bits.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])))+ (By6Bits.toMaybeList (By6Bits.unset 1 (By6Bits.maybeList [Just 1, Just 2, Nothing, Just 3]))) , testTransactionProperty "set" Gen.setTransaction ,@@ -120,12 +120,12 @@ testProperty (showString "Transaction: " name) $ forAll ((,) <$> Gen.maybeList <*> transactionGen) $ \ (maybeList, transaction) -> case transaction of- Transaction.Transaction name applyToMaybeList applyToSparseSmallArray -> let- ssa = SparseSmallArray.maybeList maybeList+ Transaction.Transaction name applyToMaybeList applyToBy6Bits -> let+ ssa = By6Bits.maybeList maybeList (result1, newMaybeList) = runState applyToMaybeList maybeList- (result2, newSsa) = runState applyToSparseSmallArray ssa- newSsaMaybeList = SparseSmallArray.toMaybeList newSsa+ (result2, newSsa) = runState applyToBy6Bits ssa+ newSsaMaybeList = By6Bits.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)+ (newMaybeList == By6Bits.toMaybeList newSsa && result1 == result2)
test/Main/Gens.hs view
@@ -6,7 +6,7 @@ import Main.Transaction (Transaction) import Data.Primitive import qualified Main.Transaction as Transaction-import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+import qualified PrimitiveExtras.By6Bits as By6Bits element :: Gen Int@@ -52,9 +52,9 @@ (1, pure Nothing) ] -sparseSmallArray :: Gen (SparseSmallArray.SparseSmallArray Int)+sparseSmallArray :: Gen (By6Bits.By6Bits Int) sparseSmallArray =- SparseSmallArray.maybeList <$> maybeList+ By6Bits.maybeList <$> maybeList primArray :: Prim a => Gen a -> Gen (PrimArray a) primArray aGen = do
test/Main/Transaction.hs view
@@ -3,7 +3,7 @@ import Prelude import Focus (Focus(..)) import qualified Focus-import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray+import qualified PrimitiveExtras.By6Bits as By6Bits import qualified Data.Text as Text import qualified DeferredFolds.Unfoldl as Unfoldl @@ -11,7 +11,7 @@ data Transaction element = forall result. (Show result, Eq result) => Transaction { name :: Text, applyToMaybeList :: State [Maybe element] result,- applyToSparseSmallArray :: State (SparseSmallArray.SparseSmallArray element) result+ applyToBy6Bits :: State (By6Bits.By6Bits element) result } instance Show (Transaction element) where@@ -25,8 +25,8 @@ applyToMaybeList = put $ map (\i' -> if index == i' then Just element else Nothing) [0 .. pred (finiteBitSize (undefined :: Int))] ,- applyToSparseSmallArray =- put $ SparseSmallArray.singleton index element+ applyToBy6Bits =+ put $ By6Bits.singleton index element } set :: Show element => Int -> element -> Transaction element@@ -40,11 +40,11 @@ (i', e') <- zip [0..] l return $ if index == i' then Just element else e' ,- applyToSparseSmallArray = do+ applyToBy6Bits = do ssa <- get- case SparseSmallArray.lookup index ssa of- Just _ -> put (SparseSmallArray.replace index element ssa)- Nothing -> put (SparseSmallArray.insert index element ssa)+ case By6Bits.lookup index ssa of+ Just _ -> put (By6Bits.replace index element ssa)+ Nothing -> put (By6Bits.insert index element ssa) } unset :: Int -> Transaction element@@ -58,8 +58,8 @@ (i', e') <- zip [0..] l return $ if index == i' then Nothing else e' ,- applyToSparseSmallArray =- get >>= put . (SparseSmallArray.unset index)+ applyToBy6Bits =+ get >>= put . (By6Bits.unset index) } lookup :: (Show element, Eq element) => Int -> Transaction element@@ -67,7 +67,7 @@ Transaction { name = "lookup " <> fromString (show index), applyToMaybeList = fmap (join . fmap fst . uncons . drop index) get,- applyToSparseSmallArray = fmap (SparseSmallArray.lookup index) get+ applyToBy6Bits = fmap (By6Bits.lookup index) get } elementsUnfoldl :: (Show element, Eq element) => Transaction element@@ -80,7 +80,7 @@ maybeElement <- Unfoldl.foldable list element <- Unfoldl.foldable maybeElement return element,- applyToSparseSmallArray = fmap SparseSmallArray.elementsUnfoldl get+ applyToBy6Bits = fmap By6Bits.elementsUnfoldl get } focusAt :: (Show element, Eq result, Show result) => Text -> Focus element Identity result -> Int -> Transaction element@@ -101,7 +101,7 @@ return result _ -> error "Index out of bounds" ,- applyToSparseSmallArray = StateT (SparseSmallArray.focusAt focus index)+ applyToBy6Bits = StateT (By6Bits.focusAt focus index) } focusInsert :: Show element => Int -> element -> Transaction element