diff --git a/library/PrimitiveExtras/Bitmap.hs b/library/PrimitiveExtras/Bitmap.hs --- a/library/PrimitiveExtras/Bitmap.hs +++ b/library/PrimitiveExtras/Bitmap.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-orphans #-} + module PrimitiveExtras.Bitmap ( Bitmap (..), empty, diff --git a/library/PrimitiveExtras/By6Bits.hs b/library/PrimitiveExtras/By6Bits.hs --- a/library/PrimitiveExtras/By6Bits.hs +++ b/library/PrimitiveExtras/By6Bits.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-orphans #-} + module PrimitiveExtras.By6Bits ( By6Bits, empty, @@ -154,8 +155,8 @@ 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 + fmap (fmap aChangeToSsaChange) + $ if Bitmap.isPopulated index indices then do a <- indexSmallArrayM array (Bitmap.populatedIndex index indices) revealA a diff --git a/library/PrimitiveExtras/Prelude.hs b/library/PrimitiveExtras/Prelude.hs --- a/library/PrimitiveExtras/Prelude.hs +++ b/library/PrimitiveExtras/Prelude.hs @@ -7,28 +7,15 @@ ) where --- base -------------------------- import Control.Applicative as Exports import Control.Arrow as Exports import Control.Category as Exports import Control.Concurrent as Exports import Control.Exception as Exports --- profunctors -------------------------- - --- deferred-folds -------------------------- - --- foldl -------------------------- import Control.Foldl as Exports (Fold (..), FoldM (..)) import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_) import Control.Monad.Fix as Exports hiding (fix) import Control.Monad.IO.Class as Exports --- primitive -------------------------- - import Control.Monad.Primitive as Exports import Control.Monad.ST as Exports import Data.Bits as Exports @@ -42,7 +29,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports +import Data.Functor as Exports hiding (unzip) import Data.Functor.Identity as Exports import Data.IORef as Exports import Data.Int as Exports @@ -52,8 +39,6 @@ import Data.Monoid as Exports hiding (First (..), Last (..)) import Data.Ord as Exports import Data.Primitive as Exports --- primitive-unlifted -------------------------- import Data.Primitive.Unlifted.Array as Exports import Data.Primitive.Unlifted.Class as Exports import Data.Profunctor.Choice as Exports @@ -71,8 +56,6 @@ import Debug.Trace as Exports import DeferredFolds.Unfoldl as Exports (Unfoldl (..)) import DeferredFolds.UnfoldlM as Exports (UnfoldlM (..)) --- focus -------------------------- import Focus as Exports (Focus (..)) import Foreign.ForeignPtr as Exports import Foreign.Ptr as Exports @@ -82,8 +65,6 @@ import GHC.Exts as Exports (groupWith, inline, lazy, sortWith) import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports --- list-t -------------------------- import ListT as Exports (ListT (..)) import Numeric as Exports import System.Environment as Exports diff --git a/library/PrimitiveExtras/PrimArray.hs b/library/PrimitiveExtras/PrimArray.hs --- a/library/PrimitiveExtras/PrimArray.hs +++ b/library/PrimitiveExtras/PrimArray.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} + module PrimitiveExtras.PrimArray where import qualified Data.ByteString.Short.Internal as ShortByteString diff --git a/library/PrimitiveExtras/PrimMultiArray.hs b/library/PrimitiveExtras/PrimMultiArray.hs --- a/library/PrimitiveExtras/PrimMultiArray.hs +++ b/library/PrimitiveExtras/PrimMultiArray.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints -Wno-orphans #-} + module PrimitiveExtras.PrimMultiArray ( PrimMultiArray, create, diff --git a/library/PrimitiveExtras/SmallArray.hs b/library/PrimitiveExtras/SmallArray.hs --- a/library/PrimitiveExtras/SmallArray.hs +++ b/library/PrimitiveExtras/SmallArray.hs @@ -100,19 +100,19 @@ 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 + 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 findAndReplace #-} findAndReplace :: (a -> Maybe a) -> SmallArray a -> SmallArray a diff --git a/primitive-extras.cabal b/primitive-extras.cabal --- a/primitive-extras.cabal +++ b/primitive-extras.cabal @@ -1,12 +1,15 @@ cabal-version: 3.0 name: primitive-extras -version: 0.10.1.8 -category: Primitive synopsis: Extras for the "primitive" library +description: + Raw collection of extra utiltilies for the "primitive" library. + +version: 0.10.1.9 +category: Primitive homepage: https://github.com/metrix-ai/primitive-extras bug-reports: https://github.com/metrix-ai/primitive-extras/issues author: Nikita Volkov -maintainer: Metrix.AI Tech Team +maintainer: Nikita Volkov copyright: (c) 2018, Metrix.AI license: MIT license-file: LICENSE @@ -71,7 +74,7 @@ PrimitiveExtras.Types build-depends: - base >=4.7 && <5 + , base >=4.7 && <5 , bytestring >=0.10 && <0.12 , cereal >=0.5.5 && <0.6 , deferred-folds >=0.9 && <0.10 @@ -131,7 +134,7 @@ Main.Transaction build-depends: - cereal + , cereal , deferred-folds , focus , primitive diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -18,95 +18,95 @@ main :: IO () 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)), - testCase "focus insert, when exists" $ - let array = SmallArray.list [1, 2, 3] - in assertEqual - "" - [1, 4, 3] - (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement (Focus.insert 4) (== 2) (const False) array)))), - testCase "focus insert, when doesn't exist" $ - let array = SmallArray.list [1, 2, 3] - in assertEqual - "" - [4, 1, 2, 3] - (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement (Focus.insert 4) (== 4) (const False) array)))), - testCase "focus delete" $ - let array = SmallArray.list [1, 2, 3] - in assertEqual - "" - [1, 3] - (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement Focus.delete (== 2) (const False) array)))) - ], - testGroup "By6Bits" $ - [ testCase "empty" $ do - assertEqual - "" - (replicate (finiteBitSize (undefined :: Int)) Nothing) - (By6Bits.toMaybeList (By6Bits.empty :: By6Bits Int32)), - testProperty "toMaybeList, maybeList" $ forAll Gen.maybeList $ \maybeList -> - maybeList === By6Bits.toMaybeList (By6Bits.maybeList maybeList), - testCase "unset" $ - assertEqual - "" - ([Just 1, Nothing, Nothing, Just 3] <> replicate (finiteBitSize (undefined :: Int) - 4) Nothing) - (By6Bits.toMaybeList (By6Bits.unset 1 (By6Bits.maybeList [Just 1, Just 2, Nothing, Just 3]))), - testTransactionProperty "set" Gen.setTransaction, - testTransactionProperty "unset" Gen.unsetTransaction, - testTransactionProperty "focusInsert" Gen.focusInsertTransaction, - testTransactionProperty "focusDelete" Gen.focusDeleteTransaction, - testTransactionProperty "unfoldl" Gen.unfoldlTransaction, - testTransactionProperty "lookup" Gen.lookupTransaction, - testTransactionProperty "composite" Gen.transaction - ], - testGroup "PrimArray" $ - [ testProperty "Construction from primitive vector" $ - let gen = do - offset <- choose (0, 2) - length <- choose (0, 100) - listSize <- - let minSize = offset + length - in choose (minSize, minSize + 100) - list :: [Int32] <- replicateM listSize arbitrary - return (list, offset, length) - in forAll gen $ \(inputList, offset, length) -> - let !inputVec = PrimitiveVector.fromList inputList - !sliceVec = PrimitiveVector.slice offset length inputVec - !sliceList = PrimitiveVector.toList sliceVec - in sliceList === primArrayToList (PrimArray.primitiveVector sliceVec), - testProperty "Serializes well with as in memory" $ forAll (Gen.primArray Gen.element) $ \primArray -> - Right primArray - === Serialize.runGet - (PrimArray.cerealGetAsInMemory Serialize.get) - (Serialize.runPut ((PrimArray.cerealPutAsInMemory Serialize.put) primArray)) - ] + 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)), + testCase "focus insert, when exists" + $ let array = SmallArray.list [1, 2, 3] + in assertEqual + "" + [1, 4, 3] + (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement (Focus.insert 4) (== 2) (const False) array)))), + testCase "focus insert, when doesn't exist" + $ let array = SmallArray.list [1, 2, 3] + in assertEqual + "" + [4, 1, 2, 3] + (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement (Focus.insert 4) (== 4) (const False) array)))), + testCase "focus delete" + $ let array = SmallArray.list [1, 2, 3] + in assertEqual + "" + [1, 3] + (SmallArray.toList (snd (runIdentity (SmallArray.focusOnFoundElement Focus.delete (== 2) (const False) array)))) + ], + testGroup "By6Bits" + $ [ testCase "empty" $ do + assertEqual + "" + (replicate (finiteBitSize (undefined :: Int)) Nothing) + (By6Bits.toMaybeList (By6Bits.empty :: By6Bits Int32)), + testProperty "toMaybeList, maybeList" $ forAll Gen.maybeList $ \maybeList -> + maybeList === By6Bits.toMaybeList (By6Bits.maybeList maybeList), + testCase "unset" + $ assertEqual + "" + ([Just 1, Nothing, Nothing, Just 3] <> replicate (finiteBitSize (undefined :: Int) - 4) Nothing) + (By6Bits.toMaybeList (By6Bits.unset 1 (By6Bits.maybeList [Just 1, Just 2, Nothing, Just 3]))), + testTransactionProperty "set" Gen.setTransaction, + testTransactionProperty "unset" Gen.unsetTransaction, + testTransactionProperty "focusInsert" Gen.focusInsertTransaction, + testTransactionProperty "focusDelete" Gen.focusDeleteTransaction, + testTransactionProperty "unfoldl" Gen.unfoldlTransaction, + testTransactionProperty "lookup" Gen.lookupTransaction, + testTransactionProperty "composite" Gen.transaction + ], + testGroup "PrimArray" + $ [ testProperty "Construction from primitive vector" + $ let gen = do + offset <- choose (0, 2) + length <- choose (0, 100) + listSize <- + let minSize = offset + length + in choose (minSize, minSize + 100) + list :: [Int32] <- replicateM listSize arbitrary + return (list, offset, length) + in forAll gen $ \(inputList, offset, length) -> + let !inputVec = PrimitiveVector.fromList inputList + !sliceVec = PrimitiveVector.slice offset length inputVec + !sliceList = PrimitiveVector.toList sliceVec + in sliceList === primArrayToList (PrimArray.primitiveVector sliceVec), + testProperty "Serializes well with as in memory" $ forAll (Gen.primArray Gen.element) $ \primArray -> + Right primArray + === Serialize.runGet + (PrimArray.cerealGetAsInMemory Serialize.get) + (Serialize.runPut ((PrimArray.cerealPutAsInMemory Serialize.put) primArray)) + ] ] - testTransactionProperty :: String -> Gen (Transaction.Transaction Int) -> TestTree testTransactionProperty name transactionGen = - testProperty (showString "Transaction: " name) $ - forAll ((,) <$> Gen.maybeList <*> transactionGen) $ \(maybeList, transaction) -> + testProperty (showString "Transaction: " name) + $ forAll ((,) <$> Gen.maybeList <*> transactionGen) + $ \(maybeList, transaction) -> case transaction of Transaction.Transaction name applyToMaybeList applyToBy6Bits -> let ssa = By6Bits.maybeList maybeList diff --git a/test/Main/Gens.hs b/test/Main/Gens.hs --- a/test/Main/Gens.hs +++ b/test/Main/Gens.hs @@ -43,9 +43,9 @@ maybeList :: Gen [Maybe Int] maybeList = - replicateM (finiteBitSize (undefined :: Int)) $ - frequency $ - [ (4, fmap Just element), + replicateM (finiteBitSize (undefined :: Int)) + $ frequency + $ [ (4, fmap Just element), (1, pure Nothing) ] diff --git a/test/Main/Transaction.hs b/test/Main/Transaction.hs --- a/test/Main/Transaction.hs +++ b/test/Main/Transaction.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} + module Main.Transaction where import qualified Data.Text as Text