Commit 7f038218 authored by Aditya Bhimanavajjula's avatar Aditya Bhimanavajjula Committed by Petr Pudlak

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: default avatarBSRK Aditya <bsrk@google.com>
Signed-off-by: default avatarPetr Pudlak <pudlak@google.com>
Reviewed-by: default avatarPetr Pudlak <pudlak@google.com>

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: 890b08b7Signed-off-by: default avatarPetr Pudlak <pudlak@google.com>
Reviewed-by: default avatarKlaus Aehlig <aehlig@google.com>
parent ac59cad0
......@@ -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 #-}
......
{-# 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 #-}
{-# 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.
......
{-# 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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment