From 479b63d8c30c0bc6e6475882d7fb573db5dad1f9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 17 Jul 2022 21:51:30 +0200
Subject: MonadStorage for context with Storage instance

---
 src/State.hs | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

(limited to 'src/State.hs')

diff --git a/src/State.hs b/src/State.hs
index 358d958..e112aca 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -2,7 +2,7 @@ module State (
     LocalState(..),
     SharedState, SharedType(..),
     SharedTypeID, mkSharedTypeID,
-    MonadHead(..),
+    MonadStorage(..), MonadHead(..),
 
     loadLocalStateHead,
     updateLocalState, updateLocalState_,
@@ -81,9 +81,15 @@ instance SharedType (Maybe ComposedIdentity) where
     sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
 
 
-class MonadHead a m where
+class Monad m => MonadStorage m where
+    getStorage :: m Storage
+
+class MonadStorage m => MonadHead a m where
     updateLocalHead :: (Stored a -> IO (Stored a, b)) -> m b
 
+instance Monad m => MonadStorage (ReaderT (Head a) m) where
+    getStorage = asks $ refStorage . headRef
+
 instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where
     updateLocalHead f = do
         h <- ask
-- 
cgit v1.2.3