From fa0770354af372f785608fad98d4949ba1508ddc Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Thu, 10 Feb 2022 20:05:43 +0100
Subject: [PATCH] Reorder some returned tuples to better fit stateTVar and
runStateT
---
src/Quasar/Observable/ObservableHashMap.hs | 29 +++++++++++-----------
src/Quasar/PreludeExtras.hs | 19 ++++++++++----
src/Quasar/Utils/ExtraT.hs | 8 +++---
3 files changed, 33 insertions(+), 23 deletions(-)
diff --git a/src/Quasar/Observable/ObservableHashMap.hs b/src/Quasar/Observable/ObservableHashMap.hs
index 4a38848..8923275 100644
--- a/src/Quasar/Observable/ObservableHashMap.hs
+++ b/src/Quasar/Observable/ObservableHashMap.hs
@@ -68,32 +68,33 @@ modifyHandle f (ObservableHashMap mvar) = modifyMVar mvar f
modifyHandle_ :: (Handle k v -> IO (Handle k v)) -> ObservableHashMap k v -> IO ()
modifyHandle_ f = modifyHandle (fmap (,()) . f)
-modifyKeyHandle :: (Eq k, Hashable k) => (KeyHandle v -> IO (KeyHandle v, a)) -> k -> ObservableHashMap k v -> IO a
+modifyKeyHandle :: (Eq k, Hashable k) => (KeyHandle v -> IO (a, KeyHandle v)) -> k -> ObservableHashMap k v -> IO a
modifyKeyHandle f k = modifyHandle (updateKeyHandle f k)
modifyKeyHandle_ :: forall k v. (Eq k, Hashable k) => (KeyHandle v -> IO (KeyHandle v)) -> k -> ObservableHashMap k v -> IO ()
-modifyKeyHandle_ f = modifyKeyHandle (fmap (,()) . f)
+modifyKeyHandle_ f = modifyKeyHandle (fmap ((), ) . f)
-updateKeyHandle :: forall k v a. (Eq k, Hashable k) => (KeyHandle v -> IO (KeyHandle v, a)) -> k -> Handle k v -> IO (Handle k v, a)
+updateKeyHandle :: forall k v a. (Eq k, Hashable k) => (KeyHandle v -> IO (a, KeyHandle v)) -> k -> Handle k v -> IO (Handle k v, a)
updateKeyHandle f k handle = do
- (keyHandles', result) <- runExtraT $ HM.alterF updateMaybe k (keyHandles handle)
+ (result, keyHandles') <- runExtraT $ HM.alterF updateMaybe k (keyHandles handle)
pure (handle {keyHandles = keyHandles'}, result)
where
updateMaybe :: Maybe (KeyHandle v) -> ExtraT a IO (Maybe (KeyHandle v))
updateMaybe = fmap toMaybe . (ExtraT . f) . fromMaybe emptyKeyHandle
+ --updateMaybe = undefined
emptyKeyHandle :: KeyHandle v
emptyKeyHandle = KeyHandle Nothing HM.empty
toMaybe :: KeyHandle v -> Maybe (KeyHandle v)
toMaybe (KeyHandle Nothing (HM.null -> True)) = Nothing
toMaybe keyHandle = Just keyHandle
-modifyKeyHandleNotifying :: (Eq k, Hashable k) => (KeyHandle v -> IO (KeyHandle v, (Maybe (Delta k v), a))) -> k -> ObservableHashMap k v -> IO a
+modifyKeyHandleNotifying :: (Eq k, Hashable k) => (KeyHandle v -> IO ((a, Maybe (Delta k v)), KeyHandle v)) -> k -> ObservableHashMap k v -> IO a
modifyKeyHandleNotifying f k = modifyHandle $ \handle -> do
- (newHandle, (delta, result)) <- updateKeyHandle f k handle
+ (newHandle, (result, delta)) <- updateKeyHandle f k handle
notifySubscribers newHandle delta
pure (newHandle, result)
-modifyKeyHandleNotifying_ :: (Eq k, Hashable k) => (KeyHandle v -> IO (KeyHandle v, Maybe (Delta k v))) -> k -> ObservableHashMap k v -> IO ()
+modifyKeyHandleNotifying_ :: (Eq k, Hashable k) => (KeyHandle v -> IO (Maybe (Delta k v), KeyHandle v)) -> k -> ObservableHashMap k v -> IO ()
modifyKeyHandleNotifying_ f k = modifyHandle_ $ \handle -> do
(newHandle, delta) <- updateKeyHandle f k handle
notifySubscribers newHandle delta
@@ -135,30 +136,30 @@ observeKey = undefined
insert :: forall k v m. (Eq k, Hashable k, MonadIO m) => k -> v -> ObservableHashMap k v -> m ()
insert key value = liftIO . modifyKeyHandleNotifying_ fn key
where
- fn :: KeyHandle v -> IO (KeyHandle v, Maybe (Delta k v))
+ fn :: KeyHandle v -> IO (Maybe (Delta k v), KeyHandle v)
fn keyHandle@KeyHandle{keySubscribers} = do
mapM_ ($ pure $ Just value) $ HM.elems keySubscribers
- pure (keyHandle{value=Just value}, Just (Insert key value))
+ pure (Just (Insert key value), keyHandle{value=Just value})
delete :: forall k v m. (Eq k, Hashable k, MonadIO m) => k -> ObservableHashMap k v -> m ()
delete key = liftIO . modifyKeyHandleNotifying_ fn key
where
- fn :: KeyHandle v -> IO (KeyHandle v, Maybe (Delta k v))
+ fn :: KeyHandle v -> IO (Maybe (Delta k v), KeyHandle v)
fn keyHandle@KeyHandle{value=oldValue, keySubscribers} = do
mapM_ ($ pure $ Nothing) $ HM.elems keySubscribers
let delta = if isJust oldValue then Just (Delete key) else Nothing
- pure (keyHandle{value=Nothing}, delta)
+ pure (delta, keyHandle{value=Nothing})
lookup :: forall k v m. (Eq k, Hashable k, MonadIO m) => k -> ObservableHashMap k v -> m (Maybe v)
lookup key (ObservableHashMap mvar) = liftIO do
Handle{keyHandles} <- readMVar mvar
- pure $ join $ value <$> HM.lookup key keyHandles
+ pure $ value =<< HM.lookup key keyHandles
lookupDelete :: forall k v m. (Eq k, Hashable k, MonadIO m) => k -> ObservableHashMap k v -> m (Maybe v)
lookupDelete key = liftIO . modifyKeyHandleNotifying fn key
where
- fn :: KeyHandle v -> IO (KeyHandle v, (Maybe (Delta k v), Maybe v))
+ fn :: KeyHandle v -> IO ((Maybe v, Maybe (Delta k v)), KeyHandle v)
fn keyHandle@KeyHandle{value=oldValue, keySubscribers} = do
mapM_ ($ pure $ Nothing) $ HM.elems keySubscribers
let delta = if isJust oldValue then Just (Delete key) else Nothing
- pure (keyHandle{value=Nothing}, (delta, oldValue))
+ pure ((oldValue, delta), keyHandle{value=Nothing})
diff --git a/src/Quasar/PreludeExtras.hs b/src/Quasar/PreludeExtras.hs
index c229dd6..6c00003 100644
--- a/src/Quasar/PreludeExtras.hs
+++ b/src/Quasar/PreludeExtras.hs
@@ -17,6 +17,7 @@ import Data.HashSet qualified as HS
import Data.Hashable qualified as Hashable
import Data.List qualified as List
import Data.Maybe qualified as Maybe
+import Data.Tuple (swap)
import Data.Unique (Unique, newUnique)
import GHC.Conc (unsafeIOToSTM)
import GHC.Stack.Types qualified
@@ -79,19 +80,27 @@ duplicates = HS.toList . duplicates' HS.empty
otherDuplicates = duplicates' (HS.insert x set) xs
-- | Lookup and delete a value from a HashMap in one operation
-lookupDelete :: forall k v. (Eq k, Hashable.Hashable k) => k -> HM.HashMap k v -> (HM.HashMap k v, Maybe v)
-lookupDelete key m = State.runState fn Nothing
+lookupDelete :: forall k v. (Eq k, Hashable.Hashable k) => k -> HM.HashMap k v -> (Maybe v, HM.HashMap k v)
+lookupDelete key m = swap $ State.runState fn Nothing
where
fn :: State.State (Maybe v) (HM.HashMap k v)
fn = HM.alterF (\c -> State.put c >> return Nothing) key m
-- | Lookup a value and insert the given value if it is not already a member of the HashMap.
-lookupInsert :: forall k v. (Eq k, Hashable.Hashable k) => k -> v -> HM.HashMap k v -> (HM.HashMap k v, v)
+lookupInsert :: forall k v. (Eq k, Hashable.Hashable k) => k -> v -> HM.HashMap k v -> (v, HM.HashMap k v)
lookupInsert key value hm = runExtra $ HM.alterF fn key hm
where
fn :: Maybe v -> Extra v (Maybe v)
- fn Nothing = Extra (Just value, value)
- fn (Just oldValue) = Extra (Just oldValue, oldValue)
+ fn Nothing = Extra (value, Just value)
+ fn (Just oldValue) = Extra (oldValue, Just oldValue)
+
+-- | Insert the given value if it is not already a member of the HashMap. Returns `True` if the element was inserted.
+checkInsert :: forall k v. (Eq k, Hashable.Hashable k) => k -> v -> HM.HashMap k v -> (Bool, HM.HashMap k v)
+checkInsert key value hm = runExtra $ HM.alterF fn key hm
+ where
+ fn :: Maybe v -> Extra Bool (Maybe v)
+ fn Nothing = Extra (True, Just value)
+ fn (Just oldValue) = Extra (False, Just oldValue)
infixl 4 <<$>>
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
diff --git a/src/Quasar/Utils/ExtraT.hs b/src/Quasar/Utils/ExtraT.hs
index e198863..e1335bc 100644
--- a/src/Quasar/Utils/ExtraT.hs
+++ b/src/Quasar/Utils/ExtraT.hs
@@ -9,15 +9,15 @@ import Prelude
import Data.Bifunctor
newtype ExtraT s m r = ExtraT {
- runExtraT :: m (r, s)
+ runExtraT :: m (s, r)
}
instance Functor m => Functor (ExtraT s m) where
fmap :: (a -> b) -> ExtraT s m a -> ExtraT s m b
- fmap fn = ExtraT . fmap (first fn) . runExtraT
+ fmap fn = ExtraT . fmap (second fn) . runExtraT
newtype Extra s r = Extra {
- runExtra :: (r, s)
+ runExtra :: (s, r)
}
instance Functor (Extra s) where
fmap :: (a -> b) -> Extra s a -> Extra s b
- fmap fn = Extra . first fn . runExtra
+ fmap fn = Extra . second fn . runExtra
--
GitLab