[Pkg-ganeti-devel] [ganeti] 42/165: Upgrade codebase to support monad-control >=0.3.1.3 && <1.1
Apollon Oikonomopoulos
apoikos at moszumanska.debian.org
Tue Aug 11 13:53:11 UTC 2015
This is an automated email from the git hooks/post-receive script.
apoikos pushed a commit to branch master
in repository ganeti.
commit 890b08b7fadce821e89c4c2c7aabe3c1ff47046e
Author: Aditya Bhimanavajjula <bsrk at google.com>
Date: Mon Feb 16 15:23:59 2015 +0100
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 <bsrk at google.com>
Signed-off-by: Petr Pudlak <pudlak at google.com>
Reviewed-by: Petr Pudlak <pudlak at google.com>
---
cabal/ganeti.template.cabal | 2 +-
src/Ganeti/BasicTypes.hs | 17 +++++++++++++++++
src/Ganeti/Logging/WriterLog.hs | 18 +++++++++++++++++-
src/Ganeti/THH/HsRPC.hs | 12 ++++++++++--
src/Ganeti/WConfd/Monad.hs | 20 ++++++++++++++------
5 files changed, 59 insertions(+), 10 deletions(-)
diff --git a/cabal/ganeti.template.cabal b/cabal/ganeti.template.cabal
index 00a8ad4..25c03aa 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.8
, lifted-base >= 0.2.0.3 && < 0.3
- , monad-control >= 0.3.1.3 && < 0.4
+ , monad-control >= 0.3.1.3 && < 1.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..d299cc5 100644
--- a/src/Ganeti/BasicTypes.hs
+++ b/src/Ganeti/BasicTypes.hs
@@ -3,6 +3,8 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
{-
@@ -200,18 +202,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 5e3d3bb..8af45ce 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, CPP #-}
{-| A pure implementation of MonadLog using MonadWriter
@@ -109,19 +109,35 @@ instance (Monad m) => MonadLog (WriterLogT m) where
logAt = curry (WriterLogT . tell . singleton)
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 791b81d..7822912 100644
--- a/src/Ganeti/THH/HsRPC.hs
+++ b/src/Ganeti/THH/HsRPC.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts,
- GeneralizedNewtypeDeriving, TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts, CPP,
+ GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}
-- {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-| Creates a client out of list of RPC server components.
@@ -70,11 +70,19 @@ newtype RpcClientMonad a =
MonadError GanetiException)
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
diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs
index 683f268..8edf86e 100644
--- a/src/Ganeti/WConfd/Monad.hs
+++ b/src/Ganeti/WConfd/Monad.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies,
- GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TemplateHaskell #-}
+ GeneralizedNewtypeDeriving, CPP,
+ TemplateHaskell, UndecidableInstances #-}
{-| All RPC calls are run within this monad.
@@ -178,11 +178,19 @@ newtype WConfdMonadInt a = WConfdMonadInt
deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadLog)
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
-- | Runs the internal part of the WConfdMonad monad on a given daemon
-- handle.
@@ -237,16 +245,16 @@ modifyConfigStateErrWithImmediate f immediateFollowup = do
if modified
then if distSync
then do
- logDebug "Triggering config write\
- \ together with full synchronous distribution"
+ logDebug $ "Triggering config write" ++
+ " together with full synchronous distribution"
res <- liftBase . triggerWithResult (Any True) $ dhSaveConfigWorker dh
immediateFollowup
wait res
logDebug "Config write and distribution finished"
else do
-- trigger the config. saving worker and wait for it
- logDebug "Triggering config write\
- \ and asynchronous distribution"
+ logDebug $ "Triggering config write" ++
+ " and asynchronous distribution"
res <- liftBase . triggerWithResult (Any False) $ dhSaveConfigWorker dh
immediateFollowup
wait res
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ganeti/ganeti.git
More information about the Pkg-ganeti-devel
mailing list