I forgot the Cherry-picked-from line. The full description will be:
Upgrade codebase to support monad-control >=0.3.1.3 && <1.1
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
Cherry-picked-from: 890b08b7fadce821e89c4c2c7aabe3c1ff47046e
Signed-off-by: Petr Pudlak <[email protected]>
On Tue, Mar 24, 2015 at 04:10:04PM +0100, Petr Pudlak wrote:
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
