From 7a9ef992afa96ed177ae9a4a67d302017ab73852 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Wed, 5 Apr 2023 22:03:43 +0200 Subject: Fix non-exhaustive pattern match warnings --- src/State.hs | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) (limited to 'src/State.hs') diff --git a/src/State.hs b/src/State.hs index 6790d45..280e505 100644 --- a/src/State.hs +++ b/src/State.hs @@ -17,6 +17,7 @@ module State ( interactiveIdentityUpdate, ) where +import Control.Monad.Except import Control.Monad.Reader import Data.Foldable @@ -96,10 +97,10 @@ instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where snd <$> updateHead h f -loadLocalStateHead :: Storage -> IO (Head LocalState) +loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState) loadLocalStateHead st = loadHeads st >>= \case (h:_) -> return h - [] -> do + [] -> liftIO $ do putStr "Name: " hFlush stdout name <- T.getLine @@ -166,14 +167,18 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState } -mergeSharedIdentity :: MonadHead LocalState m => m UnifiedIdentity -mergeSharedIdentity = updateSharedState $ \(Just cidentity) -> do - identity <- liftIO $ mergeIdentity cidentity - return (Just $ toComposedIdentity identity, identity) +mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity +mergeSharedIdentity = updateSharedState $ \case + Just cidentity -> do + identity <- liftIO $ mergeIdentity cidentity + return (Just $ toComposedIdentity identity, identity) + Nothing -> throwError "no existing shared identity" -updateSharedIdentity :: MonadHead LocalState m => m () -updateSharedIdentity = updateSharedState_ $ \(Just identity) -> do - Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity) +updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m () +updateSharedIdentity = updateSharedState_ $ \case + Just identity -> do + Just . toComposedIdentity <$> liftIO (interactiveIdentityUpdate identity) + Nothing -> throwError "no existing shared identity" interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity interactiveIdentityUpdate identity = do -- cgit v1.2.3