216 lines
7.3 KiB
Diff
216 lines
7.3 KiB
Diff
commit 3aaf10bfa95efec2f2a667cae34caf76b0a0370b
|
|
Author: Bhimanavajjula Aditya <bsrk@google.com>
|
|
Date: Wed Sep 9 12:10:22 2015 +0200
|
|
|
|
Define MonadPlus instance definitions using Alternative
|
|
|
|
This is a compatibility fix for base-4.8. All MonadPlus definitions
|
|
have Alternative as a prerequisite. Hence, instead of defining
|
|
Alternative in terms of MonadPlus, we define MonadPlus in terms of
|
|
Alternative.
|
|
|
|
Signed-off-by: Bhimanavajjula Aditya <bsrk@google.com>
|
|
Signed-off-by: Petr Pudlak <pudlak@google.com>
|
|
Reviewed-by: Petr Pudlak <pudlak@google.com>
|
|
|
|
--- a/src/Ganeti/BasicTypes.hs
|
|
+++ b/src/Ganeti/BasicTypes.hs
|
|
@@ -123,13 +123,17 @@
|
|
fmap _ (Bad msg) = Bad msg
|
|
fmap fn (Ok val) = Ok (fn val)
|
|
|
|
-instance (Error a, Monoid a) => MonadPlus (GenericResult a) where
|
|
- mzero = Bad $ strMsg "zero Result when used as MonadPlus"
|
|
+instance (Error a, Monoid a) => Alternative (GenericResult a) where
|
|
+ empty = Bad $ strMsg "zero Result when used as empty"
|
|
-- for mplus, when we 'add' two Bad values, we concatenate their
|
|
-- error descriptions
|
|
- (Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y)
|
|
- (Bad _) `mplus` x = x
|
|
- x@(Ok _) `mplus` _ = x
|
|
+ (Bad x) <|> (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y)
|
|
+ (Bad _) <|> x = x
|
|
+ x@(Ok _) <|> _ = x
|
|
+
|
|
+instance (Error a, Monoid a) => MonadPlus (GenericResult a) where
|
|
+ mzero = empty
|
|
+ mplus = (<|>)
|
|
|
|
instance (Error a) => MonadError a (GenericResult a) where
|
|
throwError = Bad
|
|
@@ -143,10 +147,6 @@
|
|
_ <*> (Bad x) = Bad x
|
|
(Ok f) <*> (Ok x) = Ok $ f x
|
|
|
|
-instance (Error a, Monoid a) => Alternative (GenericResult a) where
|
|
- empty = mzero
|
|
- (<|>) = mplus
|
|
-
|
|
-- | This is a monad transformation for Result. It's implementation is
|
|
-- based on the implementations of MaybeT and ErrorT.
|
|
--
|
|
@@ -233,17 +233,18 @@
|
|
{-# INLINE liftBaseWith #-}
|
|
{-# INLINE restoreM #-}
|
|
|
|
-instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where
|
|
- mzero = ResultT $ return mzero
|
|
+instance (Monad m, Error a, Monoid a)
|
|
+ => Alternative (ResultT a m) where
|
|
+ empty = ResultT $ return mzero
|
|
-- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit
|
|
-- more complicated than 'mplus' of 'GenericResult'.
|
|
- mplus x y = elimResultT combine return x
|
|
+ x <|> y = elimResultT combine return x
|
|
where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y)
|
|
|
|
-instance (Alternative m, Monad m, Error a, Monoid a)
|
|
- => Alternative (ResultT a m) where
|
|
- empty = mzero
|
|
- (<|>) = mplus
|
|
+instance (Monad m, Error a, Monoid a)
|
|
+ => MonadPlus (ResultT a m) where
|
|
+ mzero = empty
|
|
+ mplus = (<|>)
|
|
|
|
-- | Changes the error message of a result value, if present.
|
|
-- Note that since 'GenericResult' is also a 'MonadError', this function
|
|
--- a/src/Ganeti/Utils.hs
|
|
+++ b/src/Ganeti/Utils.hs
|
|
@@ -1,4 +1,4 @@
|
|
-{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
|
|
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, CPP #-}
|
|
|
|
{-| Utility functions. -}
|
|
|
|
@@ -109,7 +109,11 @@
|
|
import qualified Data.Either as E
|
|
import Data.Function (on)
|
|
import Data.IORef
|
|
+#if MIN_VERSION_base(4,8,0)
|
|
+import Data.List hiding (isSubsequenceOf)
|
|
+#else
|
|
import Data.List
|
|
+#endif
|
|
import qualified Data.Map as M
|
|
import Data.Maybe (fromMaybe)
|
|
import qualified Data.Set as S
|
|
--- a/test/hs/Test/Ganeti/Utils.hs
|
|
+++ b/test/hs/Test/Ganeti/Utils.hs
|
|
@@ -43,7 +43,11 @@
|
|
import Control.Applicative ((<$>), (<*>))
|
|
import Data.Char (isSpace)
|
|
import qualified Data.Either as Either
|
|
+#if MIN_VERSION_base(4,8,0)
|
|
+import Data.List hiding (isSubsequenceOf)
|
|
+#else
|
|
import Data.List
|
|
+#endif
|
|
import Data.Maybe (listToMaybe)
|
|
import qualified Data.Set as S
|
|
import System.Time
|
|
--- a/src/Ganeti/Hypervisor/Xen/XmParser.hs
|
|
+++ b/src/Ganeti/Hypervisor/Xen/XmParser.hs
|
|
@@ -71,7 +71,7 @@
|
|
doubleP = LCDouble <$> A.rational <* A.skipSpace <* A.endOfInput
|
|
innerDoubleP = LCDouble <$> A.rational
|
|
stringP = LCString . unpack <$> A.takeWhile1 (not . (\c -> isSpace c
|
|
- || c `elem` "()"))
|
|
+ || c `elem` ("()" :: String)))
|
|
wspace = AC.many1 A.space
|
|
rparen = A.skipSpace *> A.char ')'
|
|
finalP = listConfigP <* rparen
|
|
@@ -163,5 +163,5 @@
|
|
uptimeLineParser = do
|
|
name <- A.takeTill isSpace <* A.skipSpace
|
|
idNum <- A.decimal <* A.skipSpace
|
|
- uptime <- A.takeTill (`elem` "\n\r") <* A.skipSpace
|
|
+ uptime <- A.takeTill (`elem` ("\n\r" :: String)) <* A.skipSpace
|
|
return . UptimeInfo (unpack name) idNum $ unpack uptime
|
|
--- a/src/Ganeti/Query/Filter.hs
|
|
+++ b/src/Ganeti/Query/Filter.hs
|
|
@@ -183,10 +183,10 @@
|
|
-- note: the next two implementations are the same, but we have to
|
|
-- repeat them due to the encapsulation done by FilterValue
|
|
containsFilter (QuotedString val) lst = do
|
|
- lst' <- fromJVal lst
|
|
+ lst' <- fromJVal lst :: ErrorResult [String]
|
|
return $! val `elem` lst'
|
|
containsFilter (NumericValue val) lst = do
|
|
- lst' <- fromJVal lst
|
|
+ lst' <- fromJVal lst :: ErrorResult [Integer]
|
|
return $! val `elem` lst'
|
|
|
|
|
|
--- a/src/Ganeti/THH.hs
|
|
+++ b/src/Ganeti/THH.hs
|
|
@@ -1164,8 +1164,13 @@
|
|
-> Q [Dec]
|
|
genDictObject save_fn load_fn sname fields = do
|
|
let name = mkName sname
|
|
+ -- newName fails in ghc 7.10 when used on keywords
|
|
+ newName' "data" = newName "data_ghcBug10599"
|
|
+ newName' "instance" = newName "instance_ghcBug10599"
|
|
+ newName' "type" = newName "type_ghcBug10599"
|
|
+ newName' s = newName s
|
|
-- toDict
|
|
- fnames <- mapM (newName . fieldVariable) fields
|
|
+ fnames <- mapM (newName' . fieldVariable) fields
|
|
let pat = conP name (map varP fnames)
|
|
tdexp = [| concat $(listE $ zipWith save_fn fnames fields) |]
|
|
tdclause <- clause [pat] (normalB tdexp) []
|
|
--- a/src/Ganeti/Query/Language.hs
|
|
+++ b/src/Ganeti/Query/Language.hs
|
|
@@ -94,7 +94,8 @@
|
|
|
|
-- | No-op 'NFData' instance for 'ResultStatus', since it's a single
|
|
-- constructor data-type.
|
|
-instance NFData ResultStatus
|
|
+instance NFData ResultStatus where
|
|
+ rnf x = seq x ()
|
|
|
|
-- | Check that ResultStatus is success or fail with descriptive
|
|
-- message.
|
|
--- a/src/Ganeti/OpParams.hs
|
|
+++ b/src/Ganeti/OpParams.hs
|
|
@@ -903,12 +903,12 @@
|
|
pRequiredNodes :: Field
|
|
pRequiredNodes =
|
|
withDoc "Required list of node names" .
|
|
- renameField "ReqNodes " $ simpleField "nodes" [t| [NonEmptyString] |]
|
|
+ renameField "ReqNodes" $ simpleField "nodes" [t| [NonEmptyString] |]
|
|
|
|
pRequiredNodeUuids :: Field
|
|
pRequiredNodeUuids =
|
|
withDoc "Required list of node UUIDs" .
|
|
- renameField "ReqNodeUuids " . optionalField $
|
|
+ renameField "ReqNodeUuids" . optionalField $
|
|
simpleField "node_uuids" [t| [NonEmptyString] |]
|
|
|
|
pRestrictedCommand :: Field
|
|
@@ -1519,7 +1519,7 @@
|
|
pDiskIndex :: Field
|
|
pDiskIndex =
|
|
withDoc "Disk index for e.g. grow disk" .
|
|
- renameField "DiskIndex " $ simpleField "disk" [t| DiskIndex |]
|
|
+ renameField "DiskIndex" $ simpleField "disk" [t| DiskIndex |]
|
|
|
|
pDiskChgAmount :: Field
|
|
pDiskChgAmount =
|
|
@@ -1740,7 +1740,7 @@
|
|
pIAllocatorInstances :: Field
|
|
pIAllocatorInstances =
|
|
withDoc "IAllocator instances field" .
|
|
- renameField "IAllocatorInstances " .
|
|
+ renameField "IAllocatorInstances" .
|
|
optionalField $
|
|
simpleField "instances" [t| [NonEmptyString] |]
|
|
|
|
--- a/src/Ganeti/WConfd/ConfigModifications.hs
|
|
+++ b/src/Ganeti/WConfd/ConfigModifications.hs
|
|
@@ -1,4 +1,4 @@
|
|
-{-# LANGUAGE TemplateHaskell #-}
|
|
+{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}
|
|
|
|
{-| The WConfd functions for direct configuration manipulation
|
|
|