Generalize local state helper functions

1 files changed, 6 insertions, 0 deletions

diff --git a/src/Service.hs b/src/Service.hs
index 0942159..1d506aa 100644
--- a/src/Service.hs
+++ b/src/Service.hs
@@ -110,6 +110,12 @@ data ServiceHandlerState s = ServiceHandlerState
 newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a)
     deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO)
 
+instance MonadHead LocalState (ServiceHandler s) where
+    updateLocalHead f = do
+        (ls, x) <- liftIO . f =<< gets svcLocal
+        modify $ \s -> s { svcLocal = ls }
+        return x
+
 runServiceHandler :: Service s => Head LocalState -> ServiceInput s -> ServiceState s -> ServiceGlobalState s -> ServiceHandler s () -> IO ([ServiceReply s], (ServiceState s, ServiceGlobalState s))
 runServiceHandler h input svc global shandler = do
     let sstate = ServiceHandlerState { svcValue = svc, svcGlobal = global, svcLocal = headStoredObject h }