From 0efd90e5f01996ceb01f5a2889f9e2986322c371 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 2 Aug 2026 22:22:15 +0200 Subject: Fix state consistency in MonadHead instaces --- main/Main.hs | 6 ++++-- main/Test.hs | 6 ++++-- 2 files changed, 8 insertions(+), 4 deletions(-) (limited to 'main') diff --git a/main/Main.hs b/main/Main.hs index 8d135d5..604d58f 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -628,8 +628,10 @@ instance MonadStorage CommandM where instance MonadHead LocalState CommandM where updateLocalHead f = do - h <- gets csHead - (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h + h <- maybe (fail "failed to reload head") return =<< reloadHead =<< gets csHead + ( Just h', x ) <- updateHead' h $ \h' -> do + modify $ \s -> s { csHead = h' } + f (headStoredObject h') modify $ \s -> s { csHead = h' } return x diff --git a/main/Test.hs b/main/Test.hs index 1755031..9038083 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -282,8 +282,10 @@ instance MonadStorage CommandM where instance MonadHead LocalState CommandM where updateLocalHead f = do - Just h <- gets tsHead - (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h + h <- maybe (fail "failed to reload head") return =<< reloadHead =<< getOrLoadHead + ( Just h', x ) <- updateHead' h $ \h' -> do + modify $ \s -> s { tsHead = Just h' } + f (headStoredObject h') modify $ \s -> s { tsHead = Just h' } return x -- cgit v1.2.3