Add default implementation for DeltaObservable.subscribe

src/lib/Qd/Observable/Delta.hs

@@ -6,6 +6,7 @@ import Qd.Prelude
 import Conduit
 import qualified Data.HashMap.Strict as HM
 import Data.Binary (Binary(..))
+import Data.IORef
 
 data Delta k v = Reset (HM.HashMap k v) | Add k v | Change k v | Remove k
   deriving (Eq, Show, Generic)
@@ -19,3 +20,16 @@ class Observable (HM.HashMap k v) o => DeltaObservable k v o | o -> k, o -> v wh
   subscribeDeltaC :: o -> ConduitT () (Delta k v) IO ()
   subscribeDeltaC = undefined
   {-# MINIMAL subscribeDelta | subscribeDeltaC #-}
+
+observeHashMapDefaultImpl :: forall k v o. (Eq k, Hashable k) => DeltaObservable k v o => o -> (HM.HashMap k v -> IO ()) -> IO SubscriptionHandle
+observeHashMapDefaultImpl o callback = do
+  hashMapRef <- newIORef HM.empty
+  subscribeDelta o (deltaCallback hashMapRef)
+  where
+    deltaCallback :: IORef (HM.HashMap k v) -> Delta k v -> IO ()
+    deltaCallback hashMapRef delta = callback =<< atomicModifyIORef' hashMapRef ((\x->(x,x)) . (applyDelta delta))
+    applyDelta :: Delta k v -> HM.HashMap k v -> HM.HashMap k v
+    applyDelta (Reset state) = const state
+    applyDelta (Add key value) = HM.insert key value
+    applyDelta (Change key value) = HM.insert key value
+    applyDelta (Remove key) = HM.delete key