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