Revision 95e683c6

b/src/Ganeti/BasicTypes.hs
1
{-# LANGUAGE FlexibleInstances #-}
1
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
2 2

  
3 3
{-
4 4

  
......
49 49

  
50 50
import Control.Applicative
51 51
import Control.Monad
52
import Control.Monad.Error.Class
52 53
import Control.Monad.Trans
53 54
import Data.Function
54 55
import Data.List
55 56
import Data.Maybe
57
import Data.Monoid
56 58
import Data.Set (Set)
57 59
import qualified Data.Set as Set (empty)
58 60
import Text.JSON (JSON)
......
92 94
  fmap _ (Bad msg) = Bad msg
93 95
  fmap fn (Ok val) = Ok (fn val)
94 96

  
95
instance MonadPlus (GenericResult String) where
96
  mzero = Bad "zero Result when used as MonadPlus"
97
instance (FromString a, Monoid a) => MonadPlus (GenericResult a) where
98
  mzero = Bad $ mkFromString "zero Result when used as MonadPlus"
97 99
  -- for mplus, when we 'add' two Bad values, we concatenate their
98 100
  -- error descriptions
99
  (Bad x) `mplus` (Bad y) = Bad (x ++ "; " ++ y)
101
  (Bad x) `mplus` (Bad y) = Bad (x `mappend` mkFromString "; " `mappend` y)
100 102
  (Bad _) `mplus` x = x
101 103
  x@(Ok _) `mplus` _ = x
102 104

  
105
instance (FromString a) => MonadError a (GenericResult a) where
106
  throwError = Bad
107
  catchError x h = genericResult h (const x) x
108

  
103 109
instance Applicative (GenericResult a) where
104 110
  pure = Ok
105 111
  (Bad f) <*> _       = Bad f
......
110 116
-- based on the implementations of MaybeT and ErrorT.
111 117
newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)}
112 118

  
119
-- | Eliminates a 'ResultT' value given appropriate continuations
120
elimResultT :: (Monad m)
121
            => (a -> ResultT a' m b')
122
            -> (b -> ResultT a' m b')
123
            -> ResultT a m b
124
            -> ResultT a' m b'
125
elimResultT l r = ResultT . (runResultT . result <=< runResultT)
126
  where
127
    result (Ok x)   = r x
128
    result (Bad e)  = l e
129
{-# INLINE elimResultT #-}
130

  
131
instance (Monad f) => Functor (ResultT a f) where
132
  fmap f = ResultT . liftM (fmap f) . runResultT
133

  
134
instance (Monad m, FromString a) => Applicative (ResultT a m) where
135
  pure = return
136
  (<*>) = ap
137

  
113 138
instance (Monad m, FromString a) => Monad (ResultT a m) where
114 139
  fail err = ResultT (return . Bad $ mkFromString err)
115 140
  return   = lift . return
116
  x >>= f  = ResultT $ do
117
               a <- runResultT x
118
               case a of
119
                 Ok val -> runResultT $ f val
120
                 Bad err -> return $ Bad err
141
  (>>=)    = flip (elimResultT throwError)
142

  
143
instance (Monad m, FromString a) => MonadError a (ResultT a m) where
144
  throwError = resultT . Bad
145
  catchError x h = elimResultT h return x
121 146

  
122 147
instance MonadTrans (ResultT a) where
123
  lift x = ResultT (liftM Ok x)
148
  lift = ResultT . liftM Ok
124 149

  
125 150
instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where
126 151
  liftIO = lift . liftIO
127 152

  
153
instance (Monad m, FromString a, Monoid a) => MonadPlus (ResultT a m) where
154
  mzero = ResultT $ return mzero
155
  -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit
156
  -- more complicated than 'mplus' of 'GenericResult'.
157
  mplus x y = elimResultT combine return x
158
    where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y)
159

  
128 160
-- | Lift a `Result` value to a `ResultT`.
129 161
resultT :: Monad m => GenericResult a b -> ResultT a m b
130 162
resultT = ResultT . return

Also available in: Unified diff