diff --git a/src/lib/Qd/Observable/ObservableHashMap.hs b/src/lib/Qd/Observable/ObservableHashMap.hs index 7e60d3d1dafa0ee6169e17e92a784e8d370426fe..7067fd9367712bd893b6729884f46209d722cb23 100644 --- a/src/lib/Qd/Observable/ObservableHashMap.hs +++ b/src/lib/Qd/Observable/ObservableHashMap.hs @@ -2,7 +2,7 @@ module Qd.Observable.ObservableHashMap ( ObservableHashMap, - create, + new, observeKey, insert, delete, @@ -10,78 +10,155 @@ module Qd.Observable.ObservableHashMap ( ) where import Qd.Observable +import Qd.Observable.Delta import Qd.Prelude hiding (lookup, lookupDelete) import Qd.Utils.GetT import Control.Concurrent.MVar import qualified Data.HashMap.Strict as HM +import Data.Maybe (isJust) import Data.Unique +import Language.Haskell.TH.Syntax (mkName, nameBase) +import Lens.Micro.Platform -newtype ObservableHashMap k v = ObservableHashMap (MVar (HM.HashMap k (ObservableValue v))) -data ObservableValue v = ObservableValue { +newtype ObservableHashMap k v = ObservableHashMap (MVar (Handle k v)) +data Handle k v = Handle { + keyHandles :: HM.HashMap k (KeyHandle v), + subscribers :: HM.HashMap Unique (ObservableMessage (HM.HashMap k v) -> IO ()), + deltaSubscribers :: HM.HashMap Unique (Delta k v -> IO ()) +} + +data KeyHandle v = KeyHandle { value :: Maybe v, - subscribers :: (HM.HashMap Unique (ObservableMessage (Maybe v) -> IO ())) + keySubscribers :: (HM.HashMap Unique (ObservableMessage (Maybe v) -> IO ())) } -modifyValue :: forall k v a. (Eq k, Hashable k) => (ObservableValue v -> IO (ObservableValue v, a)) -> k -> ObservableHashMap k v -> IO a -modifyValue f k (ObservableHashMap mvar) = modifyMVar mvar $ \hashmap -> runGetT (HM.alterF update k hashmap) +makeLensesWith (lensField .~ (\_ _ -> pure . TopName . mkName . ("_" <>) . nameBase) $ lensRules) ''Handle +makeLensesWith (lensField .~ (\_ _ -> pure . TopName . mkName . ("_" <>) . nameBase) $ lensRules) ''KeyHandle + +instance Gettable (HM.HashMap k v) (ObservableHashMap k v) where + getValue (ObservableHashMap mvar) = HM.mapMaybe value . keyHandles <$> readMVar mvar +instance Observable (HM.HashMap k v) (ObservableHashMap k v) where + subscribe ohm callback = modifyHandle update ohm + where + update :: Handle k v -> IO (Handle k v, SubscriptionHandle) + update handle = do + callback (Current, toHashMap handle) + unique <- newUnique + let handle' = handle & set (_subscribers . at unique) (Just callback) + return (handle', SubscriptionHandle $ unsubscribe unique) + unsubscribe :: Unique -> IO () + unsubscribe unique = modifyHandle_ (return . set (_subscribers . at unique) Nothing) ohm + +instance DeltaObservable k v (ObservableHashMap k v) where + subscribeDelta ohm callback = modifyHandle update ohm + where + update :: Handle k v -> IO (Handle k v, SubscriptionHandle) + update handle = do + callback (Reset $ toHashMap handle) + unique <- newUnique + let handle' = handle & set (_deltaSubscribers . at unique) (Just callback) + return (handle', SubscriptionHandle $ unsubscribe unique) + unsubscribe :: Unique -> IO () + unsubscribe unique = modifyHandle_ (return . set (_deltaSubscribers . at unique) Nothing) ohm + +-- TODO +--subscribeAbstraction :: SomeIndexedLens -> (a -> v) -> (IO (a, r) -> IO r) -> (v -> IO ()) -> IO r +--subscribeAbstraction setter getCurrent modifyMVar callback = modify $ do + + +toHashMap :: Handle k v -> HM.HashMap k v +toHashMap = HM.mapMaybe value . keyHandles + +modifyHandle :: (Handle k v -> IO (Handle k v, a)) -> ObservableHashMap k v -> IO a +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 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) + +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 f k = runGetT . (_keyHandles (HM.alterF updateMaybe k)) where - update :: Maybe (ObservableValue v) -> GetT a IO (Maybe (ObservableValue v)) - update = fmap toMaybe . (GetT . f) . fromMaybe emptyObservableValue - emptyObservableValue :: ObservableValue v - emptyObservableValue = ObservableValue Nothing HM.empty - toMaybe :: ObservableValue v -> Maybe (ObservableValue v) - toMaybe (ObservableValue Nothing (HM.null -> True)) = Nothing - toMaybe ov = Just ov + updateMaybe :: Maybe (KeyHandle v) -> GetT a IO (Maybe (KeyHandle v)) + updateMaybe = fmap toMaybe . (GetT . f) . fromMaybe emptyKeyHandle + 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 f k = modifyHandle $ \handle -> do + (newHandle, (delta, result)) <- updateKeyHandle f k handle + notifySubscribers newHandle delta + return (newHandle, result) + +modifyKeyHandleNotifying_ :: (Eq k, Hashable k) => (KeyHandle v -> IO (KeyHandle v, Maybe (Delta k v))) -> k -> ObservableHashMap k v -> IO () +modifyKeyHandleNotifying_ f k = modifyHandle_ $ \handle -> do + (newHandle, delta) <- updateKeyHandle f k handle + notifySubscribers newHandle delta + return newHandle -modifyValue_ :: forall k v. (Eq k, Hashable k) => (ObservableValue v -> IO (ObservableValue v)) -> k -> ObservableHashMap k v -> IO () -modifyValue_ f = modifyValue (fmap (,()) . f) +notifySubscribers :: Handle k v -> Maybe (Delta k v) -> IO () +notifySubscribers _ Nothing = return () +notifySubscribers handle@Handle{deltaSubscribers, subscribers} (Just delta) = do + mapM_ ($ delta) $ HM.elems deltaSubscribers + mapM_ ($ (Update, toHashMap handle)) $ HM.elems subscribers -modifySubscribers :: (HM.HashMap Unique (ObservableMessage (Maybe v) -> IO ()) -> HM.HashMap Unique (ObservableMessage (Maybe v) -> IO ())) -> ObservableValue v -> ObservableValue v -modifySubscribers f ov@ObservableValue{subscribers} = ov{subscribers=f subscribers} +modifyKeySubscribers :: (HM.HashMap Unique (ObservableMessage (Maybe v) -> IO ()) -> HM.HashMap Unique (ObservableMessage (Maybe v) -> IO ())) -> KeyHandle v -> KeyHandle v +modifyKeySubscribers f = over _keySubscribers f -create :: IO (ObservableHashMap k v) -create = ObservableHashMap <$> newMVar HM.empty +new :: IO (ObservableHashMap k v) +new = ObservableHashMap <$> newMVar Handle{keyHandles=HM.empty, subscribers=HM.empty, deltaSubscribers=HM.empty} observeKey :: forall k v. (Eq k, Hashable k) => k -> ObservableHashMap k v -> SomeObservable (Maybe v) -observeKey key om@(ObservableHashMap mvar) = SomeObservable FnObservable{getValueFn, subscribeFn} +observeKey key ohm@(ObservableHashMap mvar) = SomeObservable FnObservable{getValueFn, subscribeFn} where getValueFn :: IO (Maybe v) - getValueFn = (value <=< HM.lookup key) <$> readMVar mvar + getValueFn = join . preview (_keyHandles . at key . _Just . _value) <$> readMVar mvar subscribeFn :: ((ObservableMessage (Maybe v) -> IO ()) -> IO SubscriptionHandle) subscribeFn callback = do subscriptionKey <- newUnique - modifyValue_ (subscribeFn' subscriptionKey) key om + modifyKeyHandle_ (subscribeFn' subscriptionKey) key ohm return $ SubscriptionHandle $ unsubscribe subscriptionKey where - subscribeFn' :: Unique -> ObservableValue v -> IO (ObservableValue v) - subscribeFn' subKey ov@ObservableValue{value} = do + subscribeFn' :: Unique -> KeyHandle v -> IO (KeyHandle v) + subscribeFn' subKey keyHandle@KeyHandle{value} = do callback (Current, value) - return $ modifySubscribers (HM.insert subKey callback) ov + return $ modifyKeySubscribers (HM.insert subKey callback) keyHandle unsubscribe :: Unique -> IO () - unsubscribe subKey = modifyValue_ (return . modifySubscribers (HM.delete subKey)) key om + unsubscribe subKey = modifyKeyHandle_ (return . modifyKeySubscribers (HM.delete subKey)) key ohm insert :: forall k v. (Eq k, Hashable k) => k -> v -> ObservableHashMap k v -> IO () -insert key value = modifyValue_ fn key +insert key value = modifyKeyHandleNotifying_ fn key where - fn :: ObservableValue v -> IO (ObservableValue v) - fn ov@ObservableValue{subscribers} = do - mapM_ ($ (Update, Just value)) $ HM.elems subscribers - return ov{value=Just value} + fn :: KeyHandle v -> IO (KeyHandle v, Maybe (Delta k v)) + fn keyHandle@KeyHandle{value=oldValue, keySubscribers} = do + mapM_ ($ (Update, Just value)) $ HM.elems keySubscribers + let delta = if isJust oldValue then Change key value else Add key value + return (keyHandle{value=Just value}, Just delta) delete :: forall k v. (Eq k, Hashable k) => k -> ObservableHashMap k v -> IO () -delete = modifyValue_ fn +delete key = modifyKeyHandleNotifying_ fn key where - fn :: ObservableValue v -> IO (ObservableValue v) - fn ov@ObservableValue{subscribers} = do - mapM_ ($ (Update, Nothing)) $ HM.elems subscribers - return ov{value=Nothing} + fn :: KeyHandle v -> IO (KeyHandle v, Maybe (Delta k v)) + fn keyHandle@KeyHandle{value=oldValue, keySubscribers} = do + mapM_ ($ (Update, Nothing)) $ HM.elems keySubscribers + let delta = if isJust oldValue then Just (Remove key) else Nothing + return (keyHandle{value=Nothing}, delta) lookupDelete :: forall k v. (Eq k, Hashable k) => k -> ObservableHashMap k v -> IO (Maybe v) -lookupDelete = modifyValue fn +lookupDelete key = modifyKeyHandleNotifying fn key where - fn :: ObservableValue v -> IO (ObservableValue v, Maybe v) - fn ov@ObservableValue{value=oldValue, subscribers} = do - mapM_ ($ (Update, Nothing)) $ HM.elems subscribers - return (ov{value=Nothing}, oldValue) + fn :: KeyHandle v -> IO (KeyHandle v, (Maybe (Delta k v), Maybe v)) + fn keyHandle@KeyHandle{value=oldValue, keySubscribers} = do + mapM_ ($ (Update, Nothing)) $ HM.elems keySubscribers + let delta = if isJust oldValue then Just (Remove key) else Nothing + return (keyHandle{value=Nothing}, (delta, oldValue))