Removes a lot of unnecessary code.
Signed-off-by: Niklas Hambuechen <nikl...@google.com>
---
src/Ganeti/BasicTypes.hs | 14 +++++++++-----
src/Ganeti/JSON.hs | 18 +++++++-----------
src/Ganeti/Logging.hs | 6 +++---
src/Ganeti/Logging/WriterLog.hs | 35 ++++++-----------------------------
src/Ganeti/Query/Language.hs | 31 ++++---------------------------
src/Ganeti/THH/HsRPC.hs | 26 ++++----------------------
src/Ganeti/THH/Types.hs | 6 ++----
src/Ganeti/Types.hs | 7 ++-----
src/Ganeti/Utils/Validate.hs | 15 ++-------------
src/Ganeti/WConfd/Monad.hs | 24 +++---------------------
10 files changed, 42 insertions(+), 140 deletions(-)
diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs
index e8bc553..87177a0 100644
--- a/src/Ganeti/BasicTypes.hs
+++ b/src/Ganeti/BasicTypes.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveFunctor #-}
{-
@@ -88,6 +89,10 @@ import qualified Data.Set as Set (empty)
import Text.JSON (JSON)
import qualified Text.JSON as JSON (readJSON, showJSON)
+-- Remove after we require >= 1.8.58
+-- See: https://github.com/ndmitchell/hlint/issues/24
+{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
+
-- | Generic monad for our error handling mechanisms.
data GenericResult a b
= Bad a
@@ -145,6 +150,7 @@ instance (Error a, Monoid a) => Alternative (GenericResult
a) where
-- If 'mplus' combines two failing operations, errors of both of them
-- are combined.
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
+ deriving (Functor)
-- | Eliminates a 'ResultT' value given appropriate continuations
elimResultT :: (Monad m)
@@ -158,10 +164,7 @@ elimResultT l r = ResultT . (runResultT . result <=<
runResultT)
result (Bad e) = l e
{-# INLINE elimResultT #-}
-instance (Monad f) => Functor (ResultT a f) where
- fmap f = ResultT . liftM (fmap f) . runResultT
-
-instance (Monad m, Error a) => Applicative (ResultT a m) where
+instance (Applicative m, Monad m, Error a) => Applicative (ResultT a m) where
pure = return
(<*>) = ap
@@ -218,7 +221,8 @@ instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT
a m) where
mplus x y = elimResultT combine return x
where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y)
-instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where
+instance (Alternative m, Monad m, Error a, Monoid a)
+ => Alternative (ResultT a m) where
empty = mzero
(<|>) = mplus
diff --git a/src/Ganeti/JSON.hs b/src/Ganeti/JSON.hs
index 46716cb..5fb8350 100644
--- a/src/Ganeti/JSON.hs
+++ b/src/Ganeti/JSON.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances,
+ GeneralizedNewtypeDeriving, DeriveTraversable #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-| JSON utility functions. -}
@@ -96,6 +97,10 @@ import Text.JSON.Pretty (pp_value)
import Ganeti.BasicTypes
+-- Remove after we require >= 1.8.58
+-- See: https://github.com/ndmitchell/hlint/issues/24
+{-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
+
-- * JSON-related functions
instance NFData J.JSValue where
@@ -314,20 +319,11 @@ instance HasStringRepr String where
-- | The container type, a wrapper over Data.Map
newtype GenericContainer a b =
GenericContainer { fromContainer :: Map.Map a b }
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Functor, F.Foldable, F.Traversable)
instance (NFData a, NFData b) => NFData (GenericContainer a b) where
rnf = rnf . Map.toList . fromContainer
-instance Functor (GenericContainer a) where
- fmap f = GenericContainer . fmap f . fromContainer
-
-instance F.Foldable (GenericContainer a) where
- foldMap f = F.foldMap f . fromContainer
-
-instance F.Traversable (GenericContainer a) where
- traverse f = fmap GenericContainer . F.traverse f . fromContainer
-
-- | Type alias for string keys.
type Container = GenericContainer String
diff --git a/src/Ganeti/Logging.hs b/src/Ganeti/Logging.hs
index 07844d1..cf5a3fd 100644
--- a/src/Ganeti/Logging.hs
+++ b/src/Ganeti/Logging.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, StandaloneDeriving,
+ GeneralizedNewtypeDeriving #-}
{-| Implementation of the Ganeti logging functionality.
@@ -153,8 +154,7 @@ class Monad m => MonadLog m where
instance MonadLog IO where
logAt = logM rootLoggerName
-instance (MonadLog m) => MonadLog (IdentityT m) where
- logAt p = lift . logAt p
+deriving instance (MonadLog m) => MonadLog (IdentityT m)
instance (MonadLog m) => MonadLog (MaybeT m) where
logAt p = lift . logAt p
diff --git a/src/Ganeti/Logging/WriterLog.hs b/src/Ganeti/Logging/WriterLog.hs
index 6869d6b..5e3d3bb 100644
--- a/src/Ganeti/Logging/WriterLog.hs
+++ b/src/Ganeti/Logging/WriterLog.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies,
- MultiParamTypeClasses #-}
+ MultiParamTypeClasses, GeneralizedNewtypeDeriving,
+ StandaloneDeriving #-}
{-| A pure implementation of MonadLog using MonadWriter
@@ -66,6 +67,10 @@ type WriterSeq = WriterT LogSeq
-- | A monad transformer that adds pure logging capability.
newtype WriterLogT m a =
WriterLogT { unwrapWriterLogT :: WriterSeq m a }
+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO,
+ MonadTrans)
+
+deriving instance (MonadBase IO m) => MonadBase IO (WriterLogT m)
type WriterLog = WriterLogT Identity
@@ -100,37 +105,9 @@ execWriterLog k = do
dumpLogSeq msgs
return r
-instance (Monad m) => Functor (WriterLogT m) where
- fmap = liftM
-
-instance (Monad m) => Applicative (WriterLogT m) where
- pure = return
- (<*>) = ap
-
-instance (MonadPlus m) => Alternative (WriterLogT m) where
- empty = mzero
- (<|>) = mplus
-
-instance (Monad m) => Monad (WriterLogT m) where
- return = WriterLogT . return
- (WriterLogT k) >>= f = WriterLogT $ k >>= (unwrapWriterLogT . f)
-
instance (Monad m) => MonadLog (WriterLogT m) where
logAt = curry (WriterLogT . tell . singleton)
-instance (MonadIO m) => MonadIO (WriterLogT m) where
- liftIO = WriterLogT . liftIO
-
-instance (MonadPlus m) => MonadPlus (WriterLogT m) where
- mzero = lift mzero
- mplus (WriterLogT x) (WriterLogT y) = WriterLogT $ mplus x y
-
-instance (MonadBase IO m) => MonadBase IO (WriterLogT m) where
- liftBase = WriterLogT . liftBase
-
-instance MonadTrans WriterLogT where
- lift = WriterLogT . lift
-
instance MonadTransControl WriterLogT where
newtype StT WriterLogT a =
StWriterLog { unStWriterLog :: (a, LogSeq) }
diff --git a/src/Ganeti/Query/Language.hs b/src/Ganeti/Query/Language.hs
index 2d23ff4..3aa4bd9 100644
--- a/src/Ganeti/Query/Language.hs
+++ b/src/Ganeti/Query/Language.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell, CPP #-}
+{-# LANGUAGE TemplateHaskell, CPP, DeriveFunctor, DeriveFoldable,
+ DeriveTraversable #-}
{-| Implementation of the Ganeti Query2 language.
@@ -65,7 +66,7 @@ module Ganeti.Query.Language
import Control.Applicative
import Control.DeepSeq
import Data.Foldable
-import Data.Traversable (Traversable, traverse, fmapDefault, foldMapDefault)
+import Data.Traversable (Traversable)
import Data.Ratio (numerator, denominator)
import Text.JSON.Pretty (pp_value)
import Text.JSON.Types
@@ -189,7 +190,7 @@ data Filter a
| GEFilter a FilterValue -- ^ @>=@ /field/ /value/
| RegexpFilter a FilterRegex -- ^ @=~@ /field/ /regexp/
| ContainsFilter a FilterValue -- ^ @=[]@ /list-field/ /value/
- deriving (Show, Eq)
+ deriving (Show, Eq, Functor, Foldable, Traversable)
-- | Serialiser for the 'Filter' data type.
showFilter :: (JSON a) => Filter a -> JSValue
@@ -280,30 +281,6 @@ instance (JSON a) => JSON (Filter a) where
showJSON = showFilter
readJSON = readFilter
--- Traversable implementation for 'Filter'.
-traverseFlt :: (Applicative f) => (a -> f b) -> Filter a -> f (Filter b)
-traverseFlt _ EmptyFilter = pure EmptyFilter
-traverseFlt f (AndFilter flts) = AndFilter <$> traverse (traverseFlt f) flts
-traverseFlt f (OrFilter flts) = OrFilter <$> traverse (traverseFlt f) flts
-traverseFlt f (NotFilter flt) = NotFilter <$> traverseFlt f flt
-traverseFlt f (TrueFilter a) = TrueFilter <$> f a
-traverseFlt f (EQFilter a fval) = EQFilter <$> f a <*> pure fval
-traverseFlt f (LTFilter a fval) = LTFilter <$> f a <*> pure fval
-traverseFlt f (GTFilter a fval) = GTFilter <$> f a <*> pure fval
-traverseFlt f (LEFilter a fval) = LEFilter <$> f a <*> pure fval
-traverseFlt f (GEFilter a fval) = GEFilter <$> f a <*> pure fval
-traverseFlt f (RegexpFilter a re) = RegexpFilter <$> f a <*> pure re
-traverseFlt f (ContainsFilter a fval) = ContainsFilter <$> f a <*> pure fval
-
-instance Traversable Filter where
- traverse = traverseFlt
-
-instance Functor Filter where
- fmap = fmapDefault
-
-instance Foldable Filter where
- foldMap = foldMapDefault
-
-- | Field name to filter on.
type FilterField = String
diff --git a/src/Ganeti/THH/HsRPC.hs b/src/Ganeti/THH/HsRPC.hs
index 53891eb..06d9593 100644
--- a/src/Ganeti/THH/HsRPC.hs
+++ b/src/Ganeti/THH/HsRPC.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell, FunctionalDependencies, FlexibleContexts,
+ GeneralizedNewtypeDeriving #-}
-- {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-| Creates a client out of list of RPC server components.
@@ -64,28 +65,9 @@ import Ganeti.UDSServer
-- result or the error.
newtype RpcClientMonad a =
RpcClientMonad { runRpcClientMonad :: ReaderT Client ResultG a }
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO,
+ MonadError GanetiException)
-instance Functor RpcClientMonad where
- fmap f = RpcClientMonad . fmap f . runRpcClientMonad
-
-instance Applicative RpcClientMonad where
- pure = RpcClientMonad . pure
- (RpcClientMonad f) <*> (RpcClientMonad k) = RpcClientMonad (f <*> k)
-
-instance Monad RpcClientMonad where
- return = RpcClientMonad . return
- (RpcClientMonad k) >>= f = RpcClientMonad (k >>= runRpcClientMonad . f)
-
-instance MonadBase IO RpcClientMonad where
- liftBase = RpcClientMonad . liftBase
-
-instance MonadIO RpcClientMonad where
- liftIO = RpcClientMonad . liftIO
-
-instance MonadError GanetiException RpcClientMonad where
- throwError = RpcClientMonad . throwError
- catchError (RpcClientMonad k) h =
- RpcClientMonad (catchError k (runRpcClientMonad . h))
-- * The TH functions to construct RPC client functions from RPC server ones
diff --git a/src/Ganeti/THH/Types.hs b/src/Ganeti/THH/Types.hs
index 4d264ea..796705f 100644
--- a/src/Ganeti/THH/Types.hs
+++ b/src/Ganeti/THH/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, DeriveFunctor #-}
{-| Utility Template Haskell functions for working with types.
@@ -55,9 +55,7 @@ import qualified Text.JSON as J
-- sent as a list of values, and therefore for 1-argument functions we need
-- this wrapper, which packs/unpacks 1-element lists.
newtype OneTuple a = OneTuple { getOneTuple :: a }
- deriving (Eq, Ord, Show)
-instance Functor OneTuple where
- fmap f (OneTuple x) = OneTuple (f x)
+ deriving (Eq, Ord, Show, Functor)
-- The value is stored in @JSON@ as a 1-element list.
instance J.JSON a => J.JSON (OneTuple a) where
showJSON (OneTuple a) = J.JSArray [J.showJSON a]
diff --git a/src/Ganeti/Types.hs b/src/Ganeti/Types.hs
index 9770dd6..6c99cb0 100644
--- a/src/Ganeti/Types.hs
+++ b/src/Ganeti/Types.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, DeriveFunctor #-}
{-| Some common Ganeti types.
@@ -920,7 +920,7 @@ $(THH.makeJSONInstance ''HotplugTarget)
-- | A container for values that should be happy to be manipulated yet
-- refuses to be shown unless explicitly requested.
newtype Private a = Private { getPrivate :: a }
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Functor)
instance (Show a, JSON.JSON a) => JSON.JSON (Private a) where
readJSON = liftM Private . JSON.readJSON
@@ -936,9 +936,6 @@ instance Show a => Show (Private a) where
instance THH.PyValue a => THH.PyValue (Private a) where
showValue (Private x) = "Private(" ++ THH.showValue x ++ ")"
-instance Functor Private where
- fmap f (Private x) = Private $ f x
-
instance Applicative Private where
pure = Private
Private f <*> Private x = Private (f x)
diff --git a/src/Ganeti/Utils/Validate.hs b/src/Ganeti/Utils/Validate.hs
index 5a3d05c..421f0c1 100644
--- a/src/Ganeti/Utils/Validate.hs
+++ b/src/Ganeti/Utils/Validate.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-}
{-| A validation monad and corresponding utilities
@@ -64,18 +64,7 @@ import Data.Sequence
-- | Monad for running validation checks.
newtype ValidationMonadT m a =
ValidationMonad { runValidationMonad :: WriterT (Seq String) m a }
-
-instance (Monad m) => Functor (ValidationMonadT m) where
- fmap = liftM
-
-instance (Monad m) => Applicative (ValidationMonadT m) where
- pure = return
- (<*>) = ap
-
-instance (Monad m) => Monad (ValidationMonadT m) where
- return = ValidationMonad . return
- (ValidationMonad k) >>= f = ValidationMonad $ k >>= (runValidationMonad . f)
- fail = ValidationMonad . fail
+ deriving (Functor, Applicative, Monad)
type ValidationMonad = ValidationMonadT Identity
diff --git a/src/Ganeti/WConfd/Monad.hs b/src/Ganeti/WConfd/Monad.hs
index 444cf18..5f2526c 100644
--- a/src/Ganeti/WConfd/Monad.hs
+++ b/src/Ganeti/WConfd/Monad.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies,
+ GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-| All RPC calls are run within this monad.
@@ -165,23 +166,7 @@ type WConfdMonadIntType = ReaderT DaemonHandle IO
-- | The internal part of the monad without error handling.
newtype WConfdMonadInt a = WConfdMonadInt
{ getWConfdMonadInt :: WConfdMonadIntType a }
-
-instance Functor WConfdMonadInt where
- fmap f = WConfdMonadInt . fmap f . getWConfdMonadInt
-
-instance Applicative WConfdMonadInt where
- pure = WConfdMonadInt . pure
- WConfdMonadInt f <*> WConfdMonadInt k = WConfdMonadInt $ f <*> k
-
-instance Monad WConfdMonadInt where
- return = WConfdMonadInt . return
- (WConfdMonadInt k) >>= f = WConfdMonadInt $ k >>= getWConfdMonadInt . f
-
-instance MonadIO WConfdMonadInt where
- liftIO = WConfdMonadInt . liftIO
-
-instance MonadBase IO WConfdMonadInt where
- liftBase = WConfdMonadInt . liftBase
+ deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadLog)
instance MonadBaseControl IO WConfdMonadInt where
newtype StM WConfdMonadInt b = StMWConfdMonadInt
@@ -190,9 +175,6 @@ instance MonadBaseControl IO WConfdMonadInt where
$ \r -> f (liftM StMWConfdMonadInt . r . getWConfdMonadInt)
restoreM = WConfdMonadInt . restoreM . runStMWConfdMonadInt
-instance MonadLog WConfdMonadInt where
- logAt p = WConfdMonadInt . logAt p
-
-- | Runs the internal part of the WConfdMonad monad on a given daemon
-- handle.
runWConfdMonadInt :: WConfdMonadInt a -> DaemonHandle -> IO a
--
2.1.0.rc2.206.gedb03e5
