diff --git a/library/PrimitiveExtras/Bitmap.hs b/library/PrimitiveExtras/Bitmap.hs --- a/library/PrimitiveExtras/Bitmap.hs +++ b/library/PrimitiveExtras/Bitmap.hs @@ -27,6 +27,8 @@ import qualified DeferredFolds.Unfold as Unfold +deriving instance Eq Bitmap + {-# NOINLINE maxSize #-} maxSize :: Int maxSize = finiteBitSize (undefined :: Int) diff --git a/library/PrimitiveExtras/SmallArray.hs b/library/PrimitiveExtras/SmallArray.hs --- a/library/PrimitiveExtras/SmallArray.hs +++ b/library/PrimitiveExtras/SmallArray.hs @@ -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) diff --git a/library/PrimitiveExtras/SparseSmallArray.hs b/library/PrimitiveExtras/SparseSmallArray.hs --- a/library/PrimitiveExtras/SparseSmallArray.hs +++ b/library/PrimitiveExtras/SparseSmallArray.hs @@ -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 #-} diff --git a/primitive-extras.cabal b/primitive-extras.cabal --- a/primitive-extras.cabal +++ b/primitive-extras.cabal @@ -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, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 , diff --git a/test/Main/Gens.hs b/test/Main/Gens.hs --- a/test/Main/Gens.hs +++ b/test/Main/Gens.hs @@ -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] diff --git a/test/Main/Transaction.hs b/test/Main/Transaction.hs --- a/test/Main/Transaction.hs +++ b/test/Main/Transaction.hs @@ -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