primitive-extras 0.4 → 0.5.0.2
raw patch · 7 files changed
+111/−34 lines, 7 filesdep ~focus
Dependency ranges changed: focus
Files
- library/PrimitiveExtras/Bitmap.hs +2/−0
- library/PrimitiveExtras/SmallArray.hs +25/−19
- library/PrimitiveExtras/SparseSmallArray.hs +21/−5
- primitive-extras.cabal +2/−2
- test/Main.hs +23/−0
- test/Main/Gens.hs +9/−1
- test/Main/Transaction.hs +29/−7
library/PrimitiveExtras/Bitmap.hs view
@@ -27,6 +27,8 @@ import qualified DeferredFolds.Unfold as Unfold +deriving instance Eq Bitmap+ {-# NOINLINE maxSize #-} maxSize :: Int maxSize = finiteBitSize (undefined :: Int)
library/PrimitiveExtras/SmallArray.hs view
@@ -7,10 +7,6 @@ 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)@@ -85,7 +81,7 @@ copySmallArray newMa 1 array 0 size return newMa -{-# INLINABLE orderedPair #-}+{-# INLINE orderedPair #-} orderedPair :: Int -> e -> Int -> e -> SmallArray e orderedPair i1 e1 i2 e2 = {-# SCC "orderedPair" #-} @@ -108,9 +104,9 @@ {-# SCC "find" #-} let !size = sizeofSmallArray array- iterate index = if index < size+ iterate !index = if index < size then let- element = indexSmallArray array index+ !element = indexSmallArray array index in if test element then Just element else iterate (succ index)@@ -123,16 +119,16 @@ {-# SCC "findWithIndex" #-} let !size = sizeofSmallArray array- iterate index = if index < size+ iterate !index = if index < size then let- element = indexSmallArray array index+ !element = indexSmallArray array index in if test element then Just (index, element) else iterate (succ index) else Nothing in iterate 0 -{-# INLINABLE elementsUnfoldM #-}+{-# INLINE elementsUnfoldM #-} elementsUnfoldM :: Monad m => SmallArray e -> UnfoldM m e elementsUnfoldM array = UnfoldM $ \ step initialState -> let !size = sizeofSmallArray array@@ -144,27 +140,37 @@ 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+{-# INLINE onFoundElementFocus #-}+onFoundElementFocus :: Monad m => (a -> Bool) -> (a -> Bool) -> Focus a m b -> Focus (SmallArray a) m b+onFoundElementFocus testAsKey testWholeEntry (Focus concealA revealA) = Focus concealArray revealArray where concealArray = fmap (fmap arrayChange) concealA where arrayChange = \ case- Focus.Set newValue -> Focus.Set (pure newValue)+ Focus.Set newEntry -> Focus.Set (pure newEntry) _ -> Focus.Leave- revealArray array = case findWithIndex testA array of- Just (index, value) -> fmap (fmap arrayChange) (revealA value) where+ revealArray array = case findWithIndex testAsKey array of+ Just (index, entry) -> fmap (fmap arrayChange) (revealA entry) where arrayChange = \ case Focus.Leave -> Focus.Leave- Focus.Set newValue -> if newValue == value+ Focus.Set newEntry -> if testWholeEntry newEntry then Focus.Leave- else Focus.Set (set index newValue array)+ else Focus.Set (set index newEntry 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.Set newEntry -> Focus.Set (cons newEntry array) _ -> Focus.Leave++{-# INLINE focusOnFoundElement #-}+focusOnFoundElement :: Monad m => Focus a m b -> (a -> Bool) -> (a -> Bool) -> SmallArray a -> m (b, SmallArray a)+focusOnFoundElement focus testAsKey testWholeEntry = case onFoundElementFocus testAsKey testWholeEntry focus of+ Focus conceal reveal -> \ sa -> do+ (b, change) <- reveal sa+ return $ (b,) $ case change of+ Focus.Leave -> sa+ Focus.Set newSa -> newSa+ Focus.Remove -> empty toList :: forall a. SmallArray a -> [a] toList array = PrimitiveExtras.Prelude.toList (elementsUnfoldM array :: UnfoldM Identity a)
library/PrimitiveExtras/SparseSmallArray.hs view
@@ -9,6 +9,7 @@ replace, unset, lookup,+ focusAt, toMaybeList, elementsUnfold, elementsUnfoldM,@@ -18,15 +19,29 @@ import PrimitiveExtras.Prelude hiding (lookup, empty, insert) 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 . elementsUnfold+ {-# INLINE foldl' #-}+ foldl' step state = foldl' step state . elementsUnfold+ {-# INLINE foldMap #-}+ foldMap monoid = foldMap monoid . elementsUnfold+ {-# INLINE empty #-} empty :: SparseSmallArray e-empty = SparseSmallArray Bitmap.empty SmallArray.empty+empty = SparseSmallArray Bitmap.empty Prelude.empty -- | -- An array with a single element at the specified index.@@ -112,7 +127,7 @@ elementsUnfoldM :: Monad m => SparseSmallArray a -> UnfoldM m a elementsUnfoldM (SparseSmallArray _ array) = SmallArray.elementsUnfoldM array -{-# INLINABLE onElementAtFocus #-}+{-# 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@@ -128,22 +143,23 @@ 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 index a array+ newArray = SmallArray.set sparseIndex a array in Focus.Set (SparseSmallArray indices newArray) else let newIndices = Bitmap.insert index indices- newArray = SmallArray.insert index a array+ 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 index array+ newArray = SmallArray.unset sparseIndex array in Focus.Set (SparseSmallArray newIndices newArray) {-# INLINE focusAt #-}
primitive-extras.cabal view
@@ -1,7 +1,7 @@ name: primitive-extras version:- 0.4+ 0.5.0.2 category: Primitive synopsis:@@ -54,7 +54,7 @@ base >=4.7 && <5, cereal >=0.5.5 && <0.6, deferred-folds >=0.6.5 && <0.7,- focus >=0.11.2.1 && <0.12,+ focus >=1 && <1.1, foldl >=1 && <2, primitive >=0.6.4 && <0.7, profunctors >=5 && <6,
test/Main.hs view
@@ -7,6 +7,7 @@ import Test.Tasty.HUnit import Test.Tasty.QuickCheck import PrimitiveExtras.SparseSmallArray (SparseSmallArray)+import qualified Focus import qualified Test.QuickCheck as QuickCheck import qualified Test.QuickCheck.Property as QuickCheck import qualified Main.Transaction as Transaction@@ -38,6 +39,24 @@ 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 "SparseSmallArray" $@@ -57,6 +76,10 @@ testTransactionProperty "set" Gen.setTransaction , testTransactionProperty "unset" Gen.unsetTransaction+ ,+ testTransactionProperty "focusInsert" Gen.focusInsertTransaction+ ,+ testTransactionProperty "focusDelete" Gen.focusDeleteTransaction , testTransactionProperty "unfold" Gen.unfoldTransaction ,
test/Main/Gens.hs view
@@ -20,6 +20,12 @@ setTransaction :: Gen (Transaction Int) setTransaction = Transaction.set <$> index <*> element +focusInsertTransaction :: Gen (Transaction Int)+focusInsertTransaction = Transaction.focusInsert <$> index <*> element++focusDeleteTransaction :: Gen (Transaction Int)+focusDeleteTransaction = Transaction.focusDelete <$> index+ unsetTransaction :: Gen (Transaction element) unsetTransaction = Transaction.unset <$> index @@ -32,7 +38,9 @@ [ (9, lookupTransaction), (9, setTransaction),- (9, unsetTransaction)+ (9, unsetTransaction),+ (9, focusInsertTransaction),+ (9, focusDeleteTransaction) ] maybeList :: Gen [Maybe Int]
test/Main/Transaction.hs view
@@ -1,6 +1,8 @@ module Main.Transaction where import Prelude+import Focus (Focus(..))+import qualified Focus import qualified PrimitiveExtras.SparseSmallArray as SparseSmallArray import qualified Data.Text as Text import qualified DeferredFolds.Unfold as Unfold@@ -81,11 +83,31 @@ 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+focusAt :: (Show element, Eq result, Show result) => Text -> Focus element Identity result -> Int -> Transaction element+focusAt focusName focus index =+ Transaction {+ name = "focusAt (" <> (fromString . show) index <> " " <> focusName <> ")"+ ,+ applyToMaybeList = do+ list <- get+ case focus of+ Focus conceal reveal -> case splitAt index list of+ (precedingList, elementMaybe : trailingList) -> do+ (result, change) <- lift (maybe conceal reveal elementMaybe)+ case change of+ Focus.Leave -> return ()+ Focus.Set newElement -> put (precedingList <> [Just newElement] <> trailingList)+ Focus.Remove -> put (precedingList <> [Nothing] <> trailingList)+ return result+ _ -> error "Index out of bounds"+ ,+ applyToSparseSmallArray = StateT (SparseSmallArray.focusAt focus index)+ } --- }+focusInsert :: Show element => Int -> element -> Transaction element+focusInsert index element =+ focusAt ("Insert (" <> (fromString . show) element <> ")") (Focus.insert element) index++focusDelete :: Show element => Int -> Transaction element+focusDelete index =+ focusAt ("Delete") Focus.delete index