diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 0.3.28.2 + +* Support for exceptions 0.9 and 0.10 [#158](https://github.com/kazu-yamamoto/logger/issues/158) +* Drop blaze-builder dependency + ## 0.3.28.1 * Fix support for GHC 7.8 [#154](https://github.com/kazu-yamamoto/logger/pull/154) diff --git a/Control/Monad/Logger.hs b/Control/Monad/Logger.hs --- a/Control/Monad/Logger.hs +++ b/Control/Monad/Logger.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DefaultSignatures #-} #if WITH_CALLSTACK {-# LANGUAGE ImplicitParams #-} @@ -119,7 +120,11 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Resource (MonadResource (liftResourceT)) -import Control.Monad.Catch (MonadThrow (..), MonadCatch (..), MonadMask (..)) +import Control.Monad.Catch (MonadThrow (..), MonadCatch (..), MonadMask (..) +#if MIN_VERSION_exceptions(0, 10, 0) + , ExitCase (..) +#endif + ) import Control.Monad.Trans.Identity ( IdentityT) import Control.Monad.Trans.List ( ListT ) @@ -354,57 +359,11 @@ -- -- @since 0.2.4 newtype NoLoggingT m a = NoLoggingT { runNoLoggingT :: m a } - -#if __GLASGOW_HASKELL__ < 710 -instance Monad m => Functor (NoLoggingT m) where - fmap = liftM - -instance Monad m => Applicative (NoLoggingT m) where - pure = return - (<*>) = ap -#else -instance Functor m => Functor (NoLoggingT m) where - fmap f = NoLoggingT . fmap f . runNoLoggingT - {-# INLINE fmap #-} - -instance Applicative m => Applicative (NoLoggingT m) where - pure = NoLoggingT . pure - {-# INLINE pure #-} - f <*> a = NoLoggingT (runNoLoggingT f <*> runNoLoggingT a) - {-# INLINE (<*>) #-} -#endif - -instance Monad m => Monad (NoLoggingT m) where - return = NoLoggingT . return - NoLoggingT ma >>= f = NoLoggingT $ ma >>= runNoLoggingT . f - -instance MonadIO m => MonadIO (NoLoggingT m) where - liftIO = Trans.lift . liftIO - -instance MonadThrow m => MonadThrow (NoLoggingT m) where - throwM = Trans.lift . throwM - -instance MonadCatch m => MonadCatch (NoLoggingT m) where - catch (NoLoggingT m) c = - NoLoggingT $ m `catch` \e -> runNoLoggingT (c e) -instance MonadMask m => MonadMask (NoLoggingT m) where - mask a = NoLoggingT $ mask $ \u -> runNoLoggingT (a $ q u) - where q u (NoLoggingT b) = NoLoggingT $ u b - uninterruptibleMask a = - NoLoggingT $ uninterruptibleMask $ \u -> runNoLoggingT (a $ q u) - where q u (NoLoggingT b) = NoLoggingT $ u b + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadActive, MonadResource, MonadBase b) -instance MonadActive m => MonadActive (NoLoggingT m) where - monadActive = Trans.lift monadActive instance MonadActive m => MonadActive (LoggingT m) where monadActive = Trans.lift monadActive -instance MonadResource m => MonadResource (NoLoggingT m) where - liftResourceT = Trans.lift . liftResourceT - -instance MonadBase b m => MonadBase b (NoLoggingT m) where - liftBase = Trans.lift . liftBase - instance Trans.MonadTrans NoLoggingT where lift = NoLoggingT @@ -518,6 +477,41 @@ uninterruptibleMask a = WriterLoggingT $ uninterruptibleMask $ \u -> unWriterLoggingT (a $ q u) where q u b = WriterLoggingT $ u (unWriterLoggingT b) +#if MIN_VERSION_exceptions(0, 10, 0) + generalBracket acquire release use = WriterLoggingT $ do + ((b, _w12), (c, w123)) <- generalBracket + (unWriterLoggingT acquire) + (\(resource, w1) exitCase -> case exitCase of + ExitCaseSuccess (b, w12) -> do + (c, w3) <- unWriterLoggingT (release resource (ExitCaseSuccess b)) + return (c, appendDList 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) <- unWriterLoggingT (release resource (ExitCaseException e)) + return (c, appendDList w1 w3) + ExitCaseAbort -> do + (c, w3) <- unWriterLoggingT (release resource ExitCaseAbort) + return (c, appendDList w1 w3)) + (\(resource, w1) -> do + (a, w2) <- unWriterLoggingT (use resource) + return (a, appendDList w1 w2)) + return ((b, c), w123) +#elif MIN_VERSION_exceptions(0, 9, 0) + generalBracket acquire release releaseEx use = + WriterLoggingT $ generalBracket + (unWriterLoggingT acquire) + (\(x, w1) -> do + (y, w2) <- unWriterLoggingT (release x) + return (y, appendDList w1 w2)) + (\(x, w1) ex -> do + (y, w2) <- unWriterLoggingT (releaseEx x ex) + return (y, appendDList w1 w2)) + (\(x, w1) -> do + (y, w2) <- unWriterLoggingT (use x) + return (y, appendDList w1 w2)) +#endif + -- | Monad transformer that adds a new logging function. -- -- @since 0.2.2 @@ -565,6 +559,20 @@ uninterruptibleMask a = LoggingT $ \e -> uninterruptibleMask $ \u -> runLoggingT (a $ q u) e where q u (LoggingT b) = LoggingT (u . b) +#if MIN_VERSION_exceptions(0, 10, 0) + generalBracket acquire release use = + LoggingT $ \e -> generalBracket + (runLoggingT acquire e) + (\x ec -> runLoggingT (release x ec) e) + (\x -> runLoggingT (use x) e) +#elif MIN_VERSION_exceptions(0, 9, 0) + generalBracket acquire release releaseEx use = + LoggingT $ \e -> generalBracket + (runLoggingT acquire e) + (\x -> runLoggingT (release x) e) + (\x y -> runLoggingT (releaseEx x y) e) + (\x -> runLoggingT (use x) e) +#endif instance MonadResource m => MonadResource (LoggingT m) where liftResourceT = Trans.lift . liftResourceT diff --git a/monad-logger.cabal b/monad-logger.cabal --- a/monad-logger.cabal +++ b/monad-logger.cabal @@ -1,5 +1,5 @@ name: monad-logger -version: 0.3.28.1 +version: 0.3.28.2 synopsis: A class of monads which can log messages. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/kazu-yamamoto/logger @@ -42,8 +42,7 @@ , monad-loops , mtl , bytestring >= 0.10.2 - , blaze-builder - , exceptions >= 0.6 + , exceptions >= 0.6 && < 0.11 , unliftio-core if impl(ghc >= 8.0.1)