Commit 890b08b7 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>
parent 0e6ffd7c
......@@ -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
......
......@@ -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 #-}
......
{-# 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 #-}
{-# 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
......
{-# 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
......
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