From: Aditya Bhimanavajjula <[email protected]> The interfaces for MonadTransControl, and MonadBaseControl has changed since 1.0.0.0 in monad-control. The associated types StT and StM are defined now using type instead of newtype which simplifies definitions and method signatures. With this patch monad-control 0.3.1.3 and later up til 1.1 are supported.
Signed-off-by: BSRK Aditya <[email protected]> Signed-off-by: Petr Pudlak <[email protected]> Reviewed-by: Petr Pudlak <[email protected]> Conflicts: cabal/ganeti.template.cabal src/Ganeti/BasicTypes.hs src/Ganeti/Logging/WriterLog.hs src/Ganeti/THH/HsRPC.hs src/Ganeti/WConfd/Monad.hs Resolution: - Remove the cabal template (present only in 2.14) - Remove Haskell language extensions needed only in later versions Signed-off-by: Petr Pudlak <[email protected]> --- src/Ganeti/BasicTypes.hs | 16 ++++++++++++++++ src/Ganeti/Logging/WriterLog.hs | 18 +++++++++++++++++- src/Ganeti/THH/HsRPC.hs | 19 ++++++++++++++++++- src/Ganeti/WConfd/Monad.hs | 10 +++++++++- 4 files changed, 60 insertions(+), 3 deletions(-) diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs index b07e11c..3ebd788 100644 --- a/src/Ganeti/BasicTypes.hs +++ b/src/Ganeti/BasicTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE CPP #-} {- @@ -206,18 +207,33 @@ 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 +#if MIN_VERSION_monad_control(1,0,0) +-- Needs Undecidable instances + type StT (ResultT a) b = GenericResult a b + liftWith f = ResultT . liftM return $ f runResultT + restoreT = ResultT +#else newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b } liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT) restoreT = ResultT . liftM runStResultT +#endif {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance (Error a, MonadBaseControl IO m) => MonadBaseControl IO (ResultT a m) where +#if MIN_VERSION_monad_control(1,0,0) +-- Needs Undecidable instances + type StM (ResultT a m) b + = ComposeSt (ResultT a) m b + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM +#else newtype StM (ResultT a m) b = StMResultT { runStMResultT :: ComposeSt (ResultT a) m b } liftBaseWith = defaultLiftBaseWith StMResultT restoreM = defaultRestoreM runStMResultT +#endif {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} diff --git a/src/Ganeti/Logging/WriterLog.hs b/src/Ganeti/Logging/WriterLog.hs index f4bf412..90b0339 100644 --- a/src/Ganeti/Logging/WriterLog.hs +++ b/src/Ganeti/Logging/WriterLog.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies, - MultiParamTypeClasses, CPP #-} + MultiParamTypeClasses, UndecidableInstances, CPP #-} {-| A pure implementation of MonadLog using MonadWriter @@ -140,19 +140,35 @@ instance MonadTrans WriterLogT where lift = WriterLogT . lift instance MonadTransControl WriterLogT where +#if MIN_VERSION_monad_control(1,0,0) +-- Needs Undecidable instances + type StT WriterLogT a = (a, LogSeq) + liftWith f = WriterLogT . WriterT $ liftM (\x -> (x, mempty)) + (f runWriterLogT) + restoreT = WriterLogT . WriterT +#else newtype StT WriterLogT a = StWriterLog { unStWriterLog :: (a, LogSeq) } liftWith f = WriterLogT . WriterT $ liftM (\x -> (x, mempty)) (f $ liftM StWriterLog . runWriterLogT) restoreT = WriterLogT . WriterT . liftM unStWriterLog +#endif {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance (MonadBaseControl IO m) => MonadBaseControl IO (WriterLogT m) where +#if MIN_VERSION_monad_control(1,0,0) +-- Needs Undecidable instances + type StM (WriterLogT m) a + = ComposeSt WriterLogT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM +#else newtype StM (WriterLogT m) a = StMWriterLog { runStMWriterLog :: ComposeSt WriterLogT m a } liftBaseWith = defaultLiftBaseWith StMWriterLog restoreM = defaultRestoreM runStMWriterLog +#endif {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} diff --git a/src/Ganeti/THH/HsRPC.hs b/src/Ganeti/THH/HsRPC.hs index db3576b..5660472 100644 --- a/src/Ganeti/THH/HsRPC.hs +++ b/src/Ganeti/THH/HsRPC.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts, CPP #-} +{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts, CPP, + TypeFamilies, UndecidableInstances #-} -- {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-| Creates a client out of list of RPC server components. @@ -55,6 +56,7 @@ import Control.Monad import Control.Monad.Base import Control.Monad.Error import Control.Monad.Reader +import Control.Monad.Trans.Control import Language.Haskell.TH import qualified Text.JSON as J @@ -95,6 +97,21 @@ instance MonadError GanetiException RpcClientMonad where catchError (RpcClientMonad k) h = RpcClientMonad (catchError k (runRpcClientMonad . h)) +instance MonadBaseControl IO RpcClientMonad where +#if MIN_VERSION_monad_control(1,0,0) +-- Needs Undecidable instances + type StM RpcClientMonad b = StM (ReaderT Client ResultG) b + liftBaseWith f = RpcClientMonad . liftBaseWith + $ \r -> f (r . runRpcClientMonad) + restoreM = RpcClientMonad . restoreM +#else + newtype StM RpcClientMonad b = StMRpcClientMonad + { runStMRpcClientMonad :: StM (ReaderT Client ResultG) b } + liftBaseWith f = RpcClientMonad . liftBaseWith + $ \r -> f (liftM StMRpcClientMonad . r . runRpcClientMonad) + restoreM = RpcClientMonad . restoreM . runStMRpcClientMonad +#endif + -- * The TH functions to construct RPC client functions from RPC server ones -- | Given a client run a given client RPC action. diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs index 85c25dd..3148937 100644 --- a/src/Ganeti/WConfd/Monad.hs +++ b/src/Ganeti/WConfd/Monad.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, - TemplateHaskell, CPP #-} + TemplateHaskell, CPP, UndecidableInstances #-} {-| All RPC calls are run within this monad. @@ -198,11 +198,19 @@ instance MonadBase IO WConfdMonadInt where liftBase = WConfdMonadInt . liftBase instance MonadBaseControl IO WConfdMonadInt where +#if MIN_VERSION_monad_control(1,0,0) +-- Needs Undecidable instances + type StM WConfdMonadInt b = StM WConfdMonadIntType b + liftBaseWith f = WConfdMonadInt . liftBaseWith + $ \r -> f (r . getWConfdMonadInt) + restoreM = WConfdMonadInt . restoreM +#else newtype StM WConfdMonadInt b = StMWConfdMonadInt { runStMWConfdMonadInt :: StM WConfdMonadIntType b } liftBaseWith f = WConfdMonadInt . liftBaseWith $ \r -> f (liftM StMWConfdMonadInt . r . getWConfdMonadInt) restoreM = WConfdMonadInt . restoreM . runStMWConfdMonadInt +#endif instance MonadLog WConfdMonadInt where logAt p = WConfdMonadInt . logAt p -- 2.2.0.rc0.207.ga3a616c
