From: BSRK Aditya <[email protected]>
Signed-off-by: BSRK Aditya <[email protected]> --- cabal/ganeti.template.cabal | 2 +- src/Ganeti/BasicTypes.hs | 18 +++++++++--------- src/Ganeti/Logging/WriterLog.hs | 17 ++++++++--------- src/Ganeti/THH/HsRPC.hs | 9 ++++----- src/Ganeti/WConfd/Monad.hs | 11 +++++------ 5 files changed, 27 insertions(+), 30 deletions(-) diff --git a/cabal/ganeti.template.cabal b/cabal/ganeti.template.cabal index 9067b51..07c435f 100644 --- a/cabal/ganeti.template.cabal +++ b/cabal/ganeti.template.cabal @@ -59,7 +59,7 @@ library , json >= 0.5 && < 0.9 , lens >= 3.10 && < 4.4 , lifted-base >= 0.2.0.3 && < 0.3 - , monad-control >= 0.3.1.3 && < 0.4 + , monad-control >= 1.0.0.1 , MonadCatchIO-transformers >= 0.3.0.0 && < 0.4 , network >= 2.3.0.13 && < 2.7 , parallel >= 3.2.0.2 && < 3.3 diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs index fb57d1a..8e08347 100644 --- a/src/Ganeti/BasicTypes.hs +++ b/src/Ganeti/BasicTypes.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UndecidableInstances #-} {- @@ -200,18 +201,18 @@ instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where . (try :: IO a -> IO (Either IOError a)) instance (Error a) => MonadTransControl (ResultT a) where - newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b } - liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT) - restoreT = ResultT . liftM runStResultT + type StT (ResultT a) b = GenericResult a b + liftWith f = ResultT . liftM return $ f runResultT + restoreT = ResultT {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance (Error a, MonadBaseControl IO m) => MonadBaseControl IO (ResultT a m) where - newtype StM (ResultT a m) b - = StMResultT { runStMResultT :: ComposeSt (ResultT a) m b } - liftBaseWith = defaultLiftBaseWith StMResultT - restoreM = defaultRestoreM runStMResultT + type StM (ResultT a m) b + = ComposeSt (ResultT a) m b + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} @@ -235,8 +236,7 @@ withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a withError f = genericResult (throwError . f) return -- | Changes the error message of a @ResultT@ value, if present. -withErrorT :: (Monad m, Error e) - => (e' -> e) -> ResultT e' m a -> ResultT e m a +withErrorT :: (Monad m, Error e) => (e' -> e) -> ResultT e' m a -> ResultT e m a withErrorT f = ResultT . liftM (withError f) . runResultT -- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its diff --git a/src/Ganeti/Logging/WriterLog.hs b/src/Ganeti/Logging/WriterLog.hs index 5e3d3bb..33bf53d 100644 --- a/src/Ganeti/Logging/WriterLog.hs +++ b/src/Ganeti/Logging/WriterLog.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies, MultiParamTypeClasses, GeneralizedNewtypeDeriving, - StandaloneDeriving #-} + StandaloneDeriving, UndecidableInstances #-} {-| A pure implementation of MonadLog using MonadWriter @@ -109,19 +109,18 @@ instance (Monad m) => MonadLog (WriterLogT m) where logAt = curry (WriterLogT . tell . singleton) instance MonadTransControl WriterLogT where - newtype StT WriterLogT a = - StWriterLog { unStWriterLog :: (a, LogSeq) } + type StT WriterLogT a = (a, LogSeq) liftWith f = WriterLogT . WriterT $ liftM (\x -> (x, mempty)) - (f $ liftM StWriterLog . runWriterLogT) - restoreT = WriterLogT . WriterT . liftM unStWriterLog + (f runWriterLogT) + restoreT = WriterLogT . WriterT {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance (MonadBaseControl IO m) => MonadBaseControl IO (WriterLogT m) where - newtype StM (WriterLogT m) a - = StMWriterLog { runStMWriterLog :: ComposeSt WriterLogT m a } - liftBaseWith = defaultLiftBaseWith StMWriterLog - restoreM = defaultRestoreM runStMWriterLog + type StM (WriterLogT m) a + = ComposeSt WriterLogT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} diff --git a/src/Ganeti/THH/HsRPC.hs b/src/Ganeti/THH/HsRPC.hs index 791b81d..e958591 100644 --- a/src/Ganeti/THH/HsRPC.hs +++ b/src/Ganeti/THH/HsRPC.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts, - GeneralizedNewtypeDeriving, TypeFamilies #-} + GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-} -- {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-| Creates a client out of list of RPC server components. @@ -70,11 +70,10 @@ newtype RpcClientMonad a = MonadError GanetiException) instance MonadBaseControl IO RpcClientMonad where - newtype StM RpcClientMonad b = StMRpcClientMonad - { runStMRpcClientMonad :: StM (ReaderT Client ResultG) b } + type StM RpcClientMonad b = StM (ReaderT Client ResultG) b liftBaseWith f = RpcClientMonad . liftBaseWith - $ \r -> f (liftM StMRpcClientMonad . r . runRpcClientMonad) - restoreM = RpcClientMonad . restoreM . runStMRpcClientMonad + $ \r -> f (r . runRpcClientMonad) + restoreM = RpcClientMonad . restoreM -- * The TH functions to construct RPC client functions from RPC server ones diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs index 683f268..e4904f7 100644 --- a/src/Ganeti/WConfd/Monad.hs +++ b/src/Ganeti/WConfd/Monad.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, - GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TemplateHaskell #-} + GeneralizedNewtypeDeriving, + TemplateHaskell, UndecidableInstances #-} {-| All RPC calls are run within this monad. @@ -178,11 +178,10 @@ newtype WConfdMonadInt a = WConfdMonadInt deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadLog) instance MonadBaseControl IO WConfdMonadInt where - newtype StM WConfdMonadInt b = StMWConfdMonadInt - { runStMWConfdMonadInt :: StM WConfdMonadIntType b } + type StM WConfdMonadInt b = StM WConfdMonadIntType b liftBaseWith f = WConfdMonadInt . liftBaseWith - $ \r -> f (liftM StMWConfdMonadInt . r . getWConfdMonadInt) - restoreM = WConfdMonadInt . restoreM . runStMWConfdMonadInt + $ \r -> f (r . getWConfdMonadInt) + restoreM = WConfdMonadInt . restoreM -- | Runs the internal part of the WConfdMonad monad on a given daemon -- handle. -- 1.7.10.4
