diff --git a/indexed-transformers.cabal b/indexed-transformers.cabal index 0bd88b1..ac01808 100644 --- a/indexed-transformers.cabal +++ b/indexed-transformers.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -57,7 +57,9 @@ library ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints build-depends: base >=4.7 && <5 + , exceptions , free + , mmorph , mtl , transformers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index e78950d..0c12122 100644 --- a/package.yaml +++ b/package.yaml @@ -16,7 +16,9 @@ description: Please see the README on GitHub at = 4.7 && < 5 +- exceptions - free +- mmorph - mtl - transformers diff --git a/src/Control/Monad/Trans/Indexed/State.hs b/src/Control/Monad/Trans/Indexed/State.hs index c2af5ea..113632b 100644 --- a/src/Control/Monad/Trans/Indexed/State.hs +++ b/src/Control/Monad/Trans/Indexed/State.hs @@ -17,6 +17,7 @@ module Control.Monad.Trans.Indexed.State , fromStateT ) where +import Control.Monad.Catch import Control.Monad.State import Control.Monad.Trans.Indexed @@ -36,6 +37,31 @@ instance i ~ j => MonadTrans (StateIx i j) where lift m = StateIx $ \i -> (, i) <$> m instance (i ~ j, Monad m) => MonadState i (StateIx i j m) where state f = StateIx (return . f) +instance (i ~ j, MonadThrow m) + => MonadThrow (StateIx i j m) where + throwM = lift . throwM +instance (i ~ j, MonadCatch m) + => MonadCatch (StateIx i j m) where + catch (StateIx m) h = StateIx $ \i -> + catch (m i) (\e -> runStateIx (h e) i) +instance (i ~ j, MonadMask m) + => MonadMask (StateIx i j m) where + mask a = StateIx $ \s -> mask $ \u -> runStateIx (a $ q u) s + where q u (StateIx b) = StateIx (u . b) + uninterruptibleMask a = + StateIx $ \s -> uninterruptibleMask $ \u -> runStateIx (a $ q u) s + where q u (StateIx b) = StateIx (u . b) + generalBracket acquire release use = StateIx $ \s0 -> do + ((b, _s2), (c, s3)) <- generalBracket + (runStateIx acquire s0) + (\(resource, s1) exitCase -> case exitCase of + ExitCaseSuccess (b, s2) -> runStateIx (release resource (ExitCaseSuccess b)) s2 + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @s1@. + ExitCaseException e -> runStateIx (release resource (ExitCaseException e)) s1 + ExitCaseAbort -> runStateIx (release resource ExitCaseAbort) s1) + (\(resource, s1) -> runStateIx (use resource) s1) + return ((b, c), s3) evalStateIx :: Monad m => StateIx i j m x -> i -> m x evalStateIx m i = fst <$> runStateIx m i diff --git a/src/Control/Monad/Trans/Indexed/Writer.hs b/src/Control/Monad/Trans/Indexed/Writer.hs index b9d29c0..223820a 100644 --- a/src/Control/Monad/Trans/Indexed/Writer.hs +++ b/src/Control/Monad/Trans/Indexed/Writer.hs @@ -20,8 +20,11 @@ module Control.Monad.Trans.Indexed.Writer ) where import Prelude hiding (id, (.)) +import Control.Applicative import Control.Category -import Control.Monad.Trans +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Morph import Control.Monad.Trans.Indexed newtype WriterIx w i j m x = WriterIx {runWriterIx :: m (x, w i j)} @@ -32,20 +35,67 @@ instance Category w => IxMonadTrans (WriterIx w) where (WriterIx m, ij) <- mm (x, jk) <- m return (x, ij >>> jk) -instance (i ~ j, Applicative m, Category w) => Applicative (WriterIx w i j m) where - pure x = WriterIx (pure (x, id)) - WriterIx mf <*> WriterIx mx = - let - apply (f, ij) (x, jk) = (f x, ij >>> jk) - in - WriterIx $ apply <$> mf <*> mx +instance (i ~ j, Applicative m, Category w) + => Applicative (WriterIx w i j m) where + pure x = WriterIx (pure (x, id)) + WriterIx mf <*> WriterIx mx = + let + apply (f, ij) (x, jk) = (f x, ij >>> jk) + in + WriterIx $ apply <$> mf <*> mx +instance (i ~ j, Alternative m, Category w) + => Alternative (WriterIx w i j m) where + empty = WriterIx empty + WriterIx mx <|> WriterIx my = WriterIx (mx <|> my) instance (i ~ j, Monad m, Category w) => Monad (WriterIx w i j m) where return = pure (>>=) = flip bindIx +instance (i ~ j, MonadPlus m, Category w) + => MonadPlus (WriterIx w i j m) where + mzero = WriterIx mzero + mplus (WriterIx mx) (WriterIx my) = WriterIx (mplus mx my) instance (i ~ j, Category w) => MonadTrans (WriterIx w i j) where lift m = WriterIx $ do x <- m return (x, id) +instance MFunctor (WriterIx w i j) where + hoist f (WriterIx m) = WriterIx $ f m +instance (i ~ j, Category w) => MMonad (WriterIx w i j) where + embed f (WriterIx m) = WriterIx $ do + ((b,w0),w1) <- runWriterIx $ f m + return (b, w0 >>> w1) +instance (i ~ j, Category w, MonadThrow m) + => MonadThrow (WriterIx w i j m) where + throwM = lift . throwM +instance (i ~ j, Category w, MonadCatch m) + => MonadCatch (WriterIx w i j m) where + catch (WriterIx m) h = WriterIx $ catch m (runWriterIx . h) +instance (i ~ j, Category w, MonadMask m) + => MonadMask (WriterIx w i j m) where + mask a = WriterIx $ mask $ \u -> runWriterIx (a $ q u) + where q u b = WriterIx $ u (runWriterIx b) + uninterruptibleMask a = + WriterIx $ uninterruptibleMask $ \u -> runWriterIx (a $ q u) + where q u b = WriterIx $ u (runWriterIx b) + generalBracket acquire release use = WriterIx $ do + ((b, _w12), (c, w123)) <- generalBracket + (runWriterIx acquire) + (\(resource, w1) exitCase -> case exitCase of + ExitCaseSuccess (b, w12) -> do + (c, w3) <- runWriterIx (release resource (ExitCaseSuccess b)) + return (c, w12 >>> w3) + -- In the two other cases, the base monad overrides @use@'s state + -- changes and the state reverts to @w1@. + ExitCaseException e -> do + (c, w3) <- runWriterIx (release resource (ExitCaseException e)) + return (c, w1 >>> w3) + ExitCaseAbort -> do + (c, w3) <- runWriterIx (release resource ExitCaseAbort) + return (c, w1 >>> w3)) + (\(resource, w1) -> do + (a, w2) <- runWriterIx (use resource) + return (a, w1 >>> w2)) + return ((b, c), w123) evalWriterIx :: Monad m => WriterIx w i j m x -> m x evalWriterIx (WriterIx m) = fst <$> m