diff options
Diffstat (limited to 'src/Utils/Monad.hs')
| -rw-r--r-- | src/Utils/Monad.hs | 36 |
1 files changed, 36 insertions, 0 deletions
diff --git a/src/Utils/Monad.hs b/src/Utils/Monad.hs index 3c1ad17..b52b53b 100644 --- a/src/Utils/Monad.hs +++ b/src/Utils/Monad.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {-| Module : Utils.Monad Copyright : (c) UU, 2019 @@ -10,6 +13,11 @@ Some useful functions lifted to monadic actions. -} module Utils.Monad where +import Control.Monad.IO.Unlift +import Control.Monad.State.Strict (StateT (..), lift, get, put, MonadState, MonadTrans) +import Data.IORef +import Control.Exception (bracket, bracket_) + -- | If the boolean resolves to True, returns the first argument, else the -- second. @@ -24,3 +32,31 @@ whenM b t = ifM b t (return ()) -- fromJust. whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip (maybe (return ())) + +-- | 'bracket', but unlifted. +unliftBracket :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m b) -> m b +unliftBracket f g h = + withRunInIO $ \run -> + bracket (run f) (run . g) (run . h) + +-- | 'bracket_', but unlifted. +unliftBracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c +unliftBracket_ f g h = + withRunInIO $ \run -> + bracket_ (run f) (run g) (run h) + +newtype StateTUnliftIOWrapper s m a = StateTUnliftIOWrapper { runStateTUnliftIOWrapper :: StateT s m a } + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadState s, MonadTrans) + +instance MonadUnliftIO m => MonadUnliftIO (StateTUnliftIOWrapper s m) where + withRunInIO act = StateTUnliftIOWrapper $ do + state0 <- get + ref <- liftIO $ newIORef state0 + let runner mrun (StateT mf) = do + s1 <- readIORef ref + (res, s2) <- runStateT (StateT $ mrun . mf) s1 + writeIORef ref s2 + return res + res <- lift $ withRunInIO $ \mrun -> act (runner mrun . runStateTUnliftIOWrapper) + liftIO (readIORef ref) >>= put + return res |