root / src / Ganeti / BasicTypes.hs @ 13d26b66
History | View | Annotate | Download (14.3 kB)
1 | d5868411 | Petr Pudlak | {-# LANGUAGE FlexibleInstances #-} |
---|---|---|---|
2 | d5868411 | Petr Pudlak | {-# LANGUAGE FlexibleContexts #-} |
3 | d5868411 | Petr Pudlak | {-# LANGUAGE MultiParamTypeClasses #-} |
4 | d5868411 | Petr Pudlak | {-# LANGUAGE TypeFamilies #-} |
5 | 93be1ced | Iustin Pop | |
6 | 0c37d1e4 | Iustin Pop | {- |
7 | 0c37d1e4 | Iustin Pop | |
8 | 1091021c | Iustin Pop | Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
9 | 0c37d1e4 | Iustin Pop | |
10 | 0c37d1e4 | Iustin Pop | This program is free software; you can redistribute it and/or modify |
11 | 0c37d1e4 | Iustin Pop | it under the terms of the GNU General Public License as published by |
12 | 0c37d1e4 | Iustin Pop | the Free Software Foundation; either version 2 of the License, or |
13 | 0c37d1e4 | Iustin Pop | (at your option) any later version. |
14 | 0c37d1e4 | Iustin Pop | |
15 | 0c37d1e4 | Iustin Pop | This program is distributed in the hope that it will be useful, but |
16 | 0c37d1e4 | Iustin Pop | WITHOUT ANY WARRANTY; without even the implied warranty of |
17 | 0c37d1e4 | Iustin Pop | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
18 | 0c37d1e4 | Iustin Pop | General Public License for more details. |
19 | 0c37d1e4 | Iustin Pop | |
20 | 0c37d1e4 | Iustin Pop | You should have received a copy of the GNU General Public License |
21 | 0c37d1e4 | Iustin Pop | along with this program; if not, write to the Free Software |
22 | 0c37d1e4 | Iustin Pop | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
23 | 0c37d1e4 | Iustin Pop | 02110-1301, USA. |
24 | 0c37d1e4 | Iustin Pop | |
25 | 0c37d1e4 | Iustin Pop | -} |
26 | 0c37d1e4 | Iustin Pop | |
27 | 0c37d1e4 | Iustin Pop | module Ganeti.BasicTypes |
28 | 93be1ced | Iustin Pop | ( GenericResult(..) |
29 | b74ebe44 | Klaus Aehlig | , genericResult |
30 | 93be1ced | Iustin Pop | , Result |
31 | d71fbcc5 | Agata Murawska | , ResultT(..) |
32 | 565821d1 | Petr Pudlak | , mkResultT |
33 | 565821d1 | Petr Pudlak | , withError |
34 | 565821d1 | Petr Pudlak | , withErrorT |
35 | f59cefcb | Petr Pudlak | , toError |
36 | 0efada2a | Petr Pudlak | , toErrorBase |
37 | 565821d1 | Petr Pudlak | , toErrorStr |
38 | a87a017b | Petr Pudlak | , Error(..) -- re-export from Control.Monad.Error |
39 | 31daf7db | Petr Pudlak | , MonadIO(..) -- re-export from Control.Monad.IO.Class |
40 | 0c37d1e4 | Iustin Pop | , isOk |
41 | 0c37d1e4 | Iustin Pop | , isBad |
42 | 9491766c | Hrvoje Ribicic | , justOk |
43 | ea128e20 | Klaus Aehlig | , justBad |
44 | 0c37d1e4 | Iustin Pop | , eitherToResult |
45 | f3f76ccc | Iustin Pop | , annotateResult |
46 | 565821d1 | Petr Pudlak | , annotateError |
47 | 565821d1 | Petr Pudlak | , failError |
48 | 565821d1 | Petr Pudlak | , catchErrorT |
49 | 565821d1 | Petr Pudlak | , handleErrorT |
50 | b1c772fd | Klaus Aehlig | , iterateOk |
51 | 2fc5653f | Iustin Pop | , select |
52 | a1da8a50 | Klaus Aehlig | , runListHead |
53 | 2fc5653f | Iustin Pop | , LookupResult(..) |
54 | 2fc5653f | Iustin Pop | , MatchPriority(..) |
55 | 2fc5653f | Iustin Pop | , lookupName |
56 | 2fc5653f | Iustin Pop | , goodLookupResult |
57 | 2fc5653f | Iustin Pop | , goodMatchPriority |
58 | 2fc5653f | Iustin Pop | , prefixMatch |
59 | 2fc5653f | Iustin Pop | , compareNameComponent |
60 | 4651c69f | Jose A. Lopes | , ListSet(..) |
61 | 4651c69f | Jose A. Lopes | , emptyListSet |
62 | 0c37d1e4 | Iustin Pop | ) where |
63 | 0c37d1e4 | Iustin Pop | |
64 | 25779212 | Iustin Pop | import Control.Applicative |
65 | fb54b24a | Petr Pudlak | import Control.Exception (try) |
66 | 0c37d1e4 | Iustin Pop | import Control.Monad |
67 | d5868411 | Petr Pudlak | import Control.Monad.Base |
68 | 95e683c6 | Petr Pudlak | import Control.Monad.Error.Class |
69 | d71fbcc5 | Agata Murawska | import Control.Monad.Trans |
70 | d5868411 | Petr Pudlak | import Control.Monad.Trans.Control |
71 | 2fc5653f | Iustin Pop | import Data.Function |
72 | 2fc5653f | Iustin Pop | import Data.List |
73 | ea128e20 | Klaus Aehlig | import Data.Maybe |
74 | 95e683c6 | Petr Pudlak | import Data.Monoid |
75 | 4651c69f | Jose A. Lopes | import Data.Set (Set) |
76 | 4651c69f | Jose A. Lopes | import qualified Data.Set as Set (empty) |
77 | 4651c69f | Jose A. Lopes | import Text.JSON (JSON) |
78 | 4651c69f | Jose A. Lopes | import qualified Text.JSON as JSON (readJSON, showJSON) |
79 | 0c37d1e4 | Iustin Pop | |
80 | 93be1ced | Iustin Pop | -- | Generic monad for our error handling mechanisms. |
81 | 93be1ced | Iustin Pop | data GenericResult a b |
82 | 93be1ced | Iustin Pop | = Bad a |
83 | 93be1ced | Iustin Pop | | Ok b |
84 | 139c0683 | Iustin Pop | deriving (Show, Eq) |
85 | 0c37d1e4 | Iustin Pop | |
86 | b74ebe44 | Klaus Aehlig | -- | Sum type structure of GenericResult. |
87 | b74ebe44 | Klaus Aehlig | genericResult :: (a -> c) -> (b -> c) -> GenericResult a b -> c |
88 | b74ebe44 | Klaus Aehlig | genericResult f _ (Bad a) = f a |
89 | b74ebe44 | Klaus Aehlig | genericResult _ g (Ok b) = g b |
90 | 565821d1 | Petr Pudlak | {-# INLINE genericResult #-} |
91 | b74ebe44 | Klaus Aehlig | |
92 | 93be1ced | Iustin Pop | -- | Type alias for a string Result. |
93 | 93be1ced | Iustin Pop | type Result = GenericResult String |
94 | 93be1ced | Iustin Pop | |
95 | 93be1ced | Iustin Pop | -- | 'Monad' instance for 'GenericResult'. |
96 | a87a017b | Petr Pudlak | instance (Error a) => Monad (GenericResult a) where |
97 | 0c37d1e4 | Iustin Pop | (>>=) (Bad x) _ = Bad x |
98 | 0c37d1e4 | Iustin Pop | (>>=) (Ok x) fn = fn x |
99 | 0c37d1e4 | Iustin Pop | return = Ok |
100 | a87a017b | Petr Pudlak | fail = Bad . strMsg |
101 | 0c37d1e4 | Iustin Pop | |
102 | 93be1ced | Iustin Pop | instance Functor (GenericResult a) where |
103 | a9ccc950 | Iustin Pop | fmap _ (Bad msg) = Bad msg |
104 | a9ccc950 | Iustin Pop | fmap fn (Ok val) = Ok (fn val) |
105 | a9ccc950 | Iustin Pop | |
106 | a87a017b | Petr Pudlak | instance (Error a, Monoid a) => MonadPlus (GenericResult a) where |
107 | a87a017b | Petr Pudlak | mzero = Bad $ strMsg "zero Result when used as MonadPlus" |
108 | 0c37d1e4 | Iustin Pop | -- for mplus, when we 'add' two Bad values, we concatenate their |
109 | 0c37d1e4 | Iustin Pop | -- error descriptions |
110 | a87a017b | Petr Pudlak | (Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y) |
111 | 0c37d1e4 | Iustin Pop | (Bad _) `mplus` x = x |
112 | 0c37d1e4 | Iustin Pop | x@(Ok _) `mplus` _ = x |
113 | 0c37d1e4 | Iustin Pop | |
114 | a87a017b | Petr Pudlak | instance (Error a) => MonadError a (GenericResult a) where |
115 | 95e683c6 | Petr Pudlak | throwError = Bad |
116 | 565821d1 | Petr Pudlak | {-# INLINE throwError #-} |
117 | 95e683c6 | Petr Pudlak | catchError x h = genericResult h (const x) x |
118 | 565821d1 | Petr Pudlak | {-# INLINE catchError #-} |
119 | 95e683c6 | Petr Pudlak | |
120 | 93be1ced | Iustin Pop | instance Applicative (GenericResult a) where |
121 | 25779212 | Iustin Pop | pure = Ok |
122 | 25779212 | Iustin Pop | (Bad f) <*> _ = Bad f |
123 | 25779212 | Iustin Pop | _ <*> (Bad x) = Bad x |
124 | 25779212 | Iustin Pop | (Ok f) <*> (Ok x) = Ok $ f x |
125 | 25779212 | Iustin Pop | |
126 | a87a017b | Petr Pudlak | instance (Error a, Monoid a) => Alternative (GenericResult a) where |
127 | 78209a84 | Petr Pudlak | empty = mzero |
128 | 78209a84 | Petr Pudlak | (<|>) = mplus |
129 | 78209a84 | Petr Pudlak | |
130 | d71fbcc5 | Agata Murawska | -- | This is a monad transformation for Result. It's implementation is |
131 | d71fbcc5 | Agata Murawska | -- based on the implementations of MaybeT and ErrorT. |
132 | 565821d1 | Petr Pudlak | -- |
133 | 565821d1 | Petr Pudlak | -- 'ResultT' is very similar to @ErrorT@, but with one subtle difference: |
134 | 565821d1 | Petr Pudlak | -- If 'mplus' combines two failing operations, errors of both of them |
135 | 565821d1 | Petr Pudlak | -- are combined. |
136 | 93be1ced | Iustin Pop | newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} |
137 | d71fbcc5 | Agata Murawska | |
138 | 95e683c6 | Petr Pudlak | -- | Eliminates a 'ResultT' value given appropriate continuations |
139 | 95e683c6 | Petr Pudlak | elimResultT :: (Monad m) |
140 | 95e683c6 | Petr Pudlak | => (a -> ResultT a' m b') |
141 | 95e683c6 | Petr Pudlak | -> (b -> ResultT a' m b') |
142 | 95e683c6 | Petr Pudlak | -> ResultT a m b |
143 | 95e683c6 | Petr Pudlak | -> ResultT a' m b' |
144 | 95e683c6 | Petr Pudlak | elimResultT l r = ResultT . (runResultT . result <=< runResultT) |
145 | 95e683c6 | Petr Pudlak | where |
146 | 95e683c6 | Petr Pudlak | result (Ok x) = r x |
147 | 95e683c6 | Petr Pudlak | result (Bad e) = l e |
148 | 95e683c6 | Petr Pudlak | {-# INLINE elimResultT #-} |
149 | 95e683c6 | Petr Pudlak | |
150 | 95e683c6 | Petr Pudlak | instance (Monad f) => Functor (ResultT a f) where |
151 | 95e683c6 | Petr Pudlak | fmap f = ResultT . liftM (fmap f) . runResultT |
152 | 95e683c6 | Petr Pudlak | |
153 | a87a017b | Petr Pudlak | instance (Monad m, Error a) => Applicative (ResultT a m) where |
154 | 95e683c6 | Petr Pudlak | pure = return |
155 | 95e683c6 | Petr Pudlak | (<*>) = ap |
156 | 95e683c6 | Petr Pudlak | |
157 | a87a017b | Petr Pudlak | instance (Monad m, Error a) => Monad (ResultT a m) where |
158 | a87a017b | Petr Pudlak | fail err = ResultT (return . Bad $ strMsg err) |
159 | 274366e5 | Agata Murawska | return = lift . return |
160 | 95e683c6 | Petr Pudlak | (>>=) = flip (elimResultT throwError) |
161 | 95e683c6 | Petr Pudlak | |
162 | a87a017b | Petr Pudlak | instance (Monad m, Error a) => MonadError a (ResultT a m) where |
163 | 87f15934 | Petr Pudlak | throwError = ResultT . return . Bad |
164 | 565821d1 | Petr Pudlak | catchError = catchErrorT |
165 | d71fbcc5 | Agata Murawska | |
166 | 93be1ced | Iustin Pop | instance MonadTrans (ResultT a) where |
167 | 95e683c6 | Petr Pudlak | lift = ResultT . liftM Ok |
168 | d71fbcc5 | Agata Murawska | |
169 | fb54b24a | Petr Pudlak | -- | The instance catches any 'IOError' using 'try' and converts it into an |
170 | fb54b24a | Petr Pudlak | -- error message using 'strMsg'. |
171 | fb54b24a | Petr Pudlak | -- |
172 | fb54b24a | Petr Pudlak | -- This way, monadic code within 'ResultT' that uses solely 'liftIO' to |
173 | fb54b24a | Petr Pudlak | -- include 'IO' actions ensures that all IO exceptions are handled. |
174 | fb54b24a | Petr Pudlak | -- |
175 | fb54b24a | Petr Pudlak | -- Other exceptions (see instances of 'Exception') are not currently handled. |
176 | fb54b24a | Petr Pudlak | -- This might be revised in the future. |
177 | a87a017b | Petr Pudlak | instance (MonadIO m, Error a) => MonadIO (ResultT a m) where |
178 | fb54b24a | Petr Pudlak | liftIO = ResultT . liftIO |
179 | fb54b24a | Petr Pudlak | . liftM (either (failError . show) return) |
180 | fb54b24a | Petr Pudlak | . (try :: IO a -> IO (Either IOError a)) |
181 | d71fbcc5 | Agata Murawska | |
182 | d5868411 | Petr Pudlak | instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where |
183 | d5868411 | Petr Pudlak | liftBase = ResultT . liftBase |
184 | d5868411 | Petr Pudlak | . liftM (either (failError . show) return) |
185 | d5868411 | Petr Pudlak | . (try :: IO a -> IO (Either IOError a)) |
186 | d5868411 | Petr Pudlak | |
187 | d5868411 | Petr Pudlak | instance (Error a) => MonadTransControl (ResultT a) where |
188 | d5868411 | Petr Pudlak | newtype StT (ResultT a) b = StResultT { runStResultT :: GenericResult a b } |
189 | d5868411 | Petr Pudlak | liftWith f = ResultT . liftM return $ f (liftM StResultT . runResultT) |
190 | d5868411 | Petr Pudlak | restoreT = ResultT . liftM runStResultT |
191 | d5868411 | Petr Pudlak | {-# INLINE liftWith #-} |
192 | d5868411 | Petr Pudlak | {-# INLINE restoreT #-} |
193 | d5868411 | Petr Pudlak | |
194 | d5868411 | Petr Pudlak | instance (Error a, MonadBaseControl IO m) |
195 | d5868411 | Petr Pudlak | => MonadBaseControl IO (ResultT a m) where |
196 | d5868411 | Petr Pudlak | newtype StM (ResultT a m) b |
197 | d5868411 | Petr Pudlak | = StMResultT { runStMResultT :: ComposeSt (ResultT a) m b } |
198 | d5868411 | Petr Pudlak | liftBaseWith = defaultLiftBaseWith StMResultT |
199 | d5868411 | Petr Pudlak | restoreM = defaultRestoreM runStMResultT |
200 | d5868411 | Petr Pudlak | {-# INLINE liftBaseWith #-} |
201 | d5868411 | Petr Pudlak | {-# INLINE restoreM #-} |
202 | d5868411 | Petr Pudlak | |
203 | a87a017b | Petr Pudlak | instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where |
204 | 95e683c6 | Petr Pudlak | mzero = ResultT $ return mzero |
205 | 95e683c6 | Petr Pudlak | -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a bit |
206 | 95e683c6 | Petr Pudlak | -- more complicated than 'mplus' of 'GenericResult'. |
207 | 95e683c6 | Petr Pudlak | mplus x y = elimResultT combine return x |
208 | 95e683c6 | Petr Pudlak | where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y) |
209 | 95e683c6 | Petr Pudlak | |
210 | a87a017b | Petr Pudlak | instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where |
211 | 78209a84 | Petr Pudlak | empty = mzero |
212 | 78209a84 | Petr Pudlak | (<|>) = mplus |
213 | 78209a84 | Petr Pudlak | |
214 | 565821d1 | Petr Pudlak | -- | Changes the error message of a result value, if present. |
215 | 565821d1 | Petr Pudlak | -- Note that since 'GenericResult' is also a 'MonadError', this function |
216 | 565821d1 | Petr Pudlak | -- is a generalization of |
217 | 565821d1 | Petr Pudlak | -- @(Error e') => (e' -> e) -> GenericResult e' a -> GenericResult e a@ |
218 | 565821d1 | Petr Pudlak | withError :: (MonadError e m) => (e' -> e) -> GenericResult e' a -> m a |
219 | 565821d1 | Petr Pudlak | withError f = genericResult (throwError . f) return |
220 | 565821d1 | Petr Pudlak | |
221 | 565821d1 | Petr Pudlak | -- | Changes the error message of a @ResultT@ value, if present. |
222 | 565821d1 | Petr Pudlak | withErrorT :: (Monad m, Error e) |
223 | 565821d1 | Petr Pudlak | => (e' -> e) -> ResultT e' m a -> ResultT e m a |
224 | 565821d1 | Petr Pudlak | withErrorT f = ResultT . liftM (withError f) . runResultT |
225 | 565821d1 | Petr Pudlak | |
226 | 87f15934 | Petr Pudlak | -- | Lift a 'Result' value to any 'MonadError'. Since 'ResultT' is itself its |
227 | 87f15934 | Petr Pudlak | -- instance, it's a generalization of |
228 | 87f15934 | Petr Pudlak | -- @Monad m => GenericResult a b -> ResultT a m b@. |
229 | f59cefcb | Petr Pudlak | toError :: (MonadError e m) => GenericResult e a -> m a |
230 | f59cefcb | Petr Pudlak | toError = genericResult throwError return |
231 | f59cefcb | Petr Pudlak | {-# INLINE toError #-} |
232 | d71fbcc5 | Agata Murawska | |
233 | 0efada2a | Petr Pudlak | -- | Lift a 'ResultT' value into any 'MonadError' with the same base monad. |
234 | 0efada2a | Petr Pudlak | toErrorBase :: (MonadBase b m, MonadError e m) => ResultT e b a -> m a |
235 | 0efada2a | Petr Pudlak | toErrorBase = (toError =<<) . liftBase . runResultT |
236 | 0efada2a | Petr Pudlak | {-# INLINE toErrorBase #-} |
237 | 0efada2a | Petr Pudlak | |
238 | 565821d1 | Petr Pudlak | -- | An alias for @withError strMsg@, which is often used to lift a pure error |
239 | 565821d1 | Petr Pudlak | -- to a monad stack. See also 'annotateResult'. |
240 | 565821d1 | Petr Pudlak | toErrorStr :: (MonadError e m, Error e) => Result a -> m a |
241 | 565821d1 | Petr Pudlak | toErrorStr = withError strMsg |
242 | 565821d1 | Petr Pudlak | |
243 | 565821d1 | Petr Pudlak | -- | Converts a monadic result with a 'String' message into |
244 | 565821d1 | Petr Pudlak | -- a 'ResultT' with an arbitrary 'Error'. |
245 | 565821d1 | Petr Pudlak | -- |
246 | 565821d1 | Petr Pudlak | -- Expects that the given action has already taken care of any possible |
247 | 565821d1 | Petr Pudlak | -- errors. In particular, if applied on @IO (Result a)@, any exceptions |
248 | 565821d1 | Petr Pudlak | -- should be handled by the given action. |
249 | 565821d1 | Petr Pudlak | -- |
250 | 565821d1 | Petr Pudlak | -- See also 'toErrorStr'. |
251 | 565821d1 | Petr Pudlak | mkResultT :: (Monad m, Error e) => m (Result a) -> ResultT e m a |
252 | 565821d1 | Petr Pudlak | mkResultT = ResultT . liftM toErrorStr |
253 | 565821d1 | Petr Pudlak | |
254 | 93be1ced | Iustin Pop | -- | Simple checker for whether a 'GenericResult' is OK. |
255 | 93be1ced | Iustin Pop | isOk :: GenericResult a b -> Bool |
256 | 0c37d1e4 | Iustin Pop | isOk (Ok _) = True |
257 | 93be1ced | Iustin Pop | isOk _ = False |
258 | 0c37d1e4 | Iustin Pop | |
259 | 93be1ced | Iustin Pop | -- | Simple checker for whether a 'GenericResult' is a failure. |
260 | 93be1ced | Iustin Pop | isBad :: GenericResult a b -> Bool |
261 | 0c37d1e4 | Iustin Pop | isBad = not . isOk |
262 | 0c37d1e4 | Iustin Pop | |
263 | 9491766c | Hrvoje Ribicic | -- | Simple filter returning only OK values of GenericResult |
264 | 9491766c | Hrvoje Ribicic | justOk :: [GenericResult a b] -> [b] |
265 | ea128e20 | Klaus Aehlig | justOk = mapMaybe (genericResult (const Nothing) Just) |
266 | ea128e20 | Klaus Aehlig | |
267 | ea128e20 | Klaus Aehlig | -- | Simple filter returning only Bad values of GenericResult |
268 | ea128e20 | Klaus Aehlig | justBad :: [GenericResult a b] -> [a] |
269 | ea128e20 | Klaus Aehlig | justBad = mapMaybe (genericResult Just (const Nothing)) |
270 | 9491766c | Hrvoje Ribicic | |
271 | 98508e7f | Dato Simó | -- | Converter from Either to 'GenericResult'. |
272 | 93be1ced | Iustin Pop | eitherToResult :: Either a b -> GenericResult a b |
273 | 93be1ced | Iustin Pop | eitherToResult (Left s) = Bad s |
274 | 93be1ced | Iustin Pop | eitherToResult (Right v) = Ok v |
275 | f3f76ccc | Iustin Pop | |
276 | 87f15934 | Petr Pudlak | -- | Annotate an error with an ownership information, lifting it to a |
277 | 87f15934 | Petr Pudlak | -- 'MonadError'. Since 'Result' is an instance of 'MonadError' itself, |
278 | 87f15934 | Petr Pudlak | -- it's a generalization of type @String -> Result a -> Result a@. |
279 | 87f15934 | Petr Pudlak | -- See also 'toErrorStr'. |
280 | 87f15934 | Petr Pudlak | annotateResult :: (MonadError e m, Error e) => String -> Result a -> m a |
281 | 87f15934 | Petr Pudlak | annotateResult owner = toErrorStr . annotateError owner |
282 | 1091021c | Iustin Pop | |
283 | 565821d1 | Petr Pudlak | -- | Annotate an error with an ownership information inside a 'MonadError'. |
284 | 565821d1 | Petr Pudlak | -- See also 'annotateResult'. |
285 | 565821d1 | Petr Pudlak | annotateError :: (MonadError e m, Error e, Monoid e) => String -> m a -> m a |
286 | 565821d1 | Petr Pudlak | annotateError owner = |
287 | 565821d1 | Petr Pudlak | flip catchError (throwError . mappend (strMsg $ owner ++ ": ")) |
288 | 565821d1 | Petr Pudlak | {-# INLINE annotateError #-} |
289 | 565821d1 | Petr Pudlak | |
290 | 565821d1 | Petr Pudlak | -- | Throws a 'String' message as an error in a 'MonadError'. |
291 | 565821d1 | Petr Pudlak | -- This is a generalization of 'Bad'. |
292 | 565821d1 | Petr Pudlak | -- It's similar to 'fail', but works within a 'MonadError', avoiding the |
293 | 565821d1 | Petr Pudlak | -- unsafe nature of 'fail'. |
294 | 565821d1 | Petr Pudlak | failError :: (MonadError e m, Error e) => String -> m a |
295 | 565821d1 | Petr Pudlak | failError = throwError . strMsg |
296 | 565821d1 | Petr Pudlak | |
297 | 565821d1 | Petr Pudlak | -- | A synonym for @flip@ 'catchErrorT'. |
298 | 565821d1 | Petr Pudlak | handleErrorT :: (Monad m, Error e) |
299 | 565821d1 | Petr Pudlak | => (e' -> ResultT e m a) -> ResultT e' m a -> ResultT e m a |
300 | 565821d1 | Petr Pudlak | handleErrorT handler = elimResultT handler return |
301 | 565821d1 | Petr Pudlak | {-# INLINE handleErrorT #-} |
302 | 565821d1 | Petr Pudlak | |
303 | 565821d1 | Petr Pudlak | -- | Catches an error in a @ResultT@ value. This is similar to 'catchError', |
304 | 565821d1 | Petr Pudlak | -- but in addition allows to change the error type. |
305 | 565821d1 | Petr Pudlak | catchErrorT :: (Monad m, Error e) |
306 | 565821d1 | Petr Pudlak | => ResultT e' m a -> (e' -> ResultT e m a) -> ResultT e m a |
307 | 565821d1 | Petr Pudlak | catchErrorT = flip handleErrorT |
308 | 565821d1 | Petr Pudlak | {-# INLINE catchErrorT #-} |
309 | 565821d1 | Petr Pudlak | |
310 | b1c772fd | Klaus Aehlig | -- | Iterate while Ok. |
311 | b1c772fd | Klaus Aehlig | iterateOk :: (a -> GenericResult b a) -> a -> [a] |
312 | b1c772fd | Klaus Aehlig | iterateOk f a = genericResult (const []) ((:) a . iterateOk f) (f a) |
313 | b1c772fd | Klaus Aehlig | |
314 | 2fc5653f | Iustin Pop | -- * Misc functionality |
315 | 2fc5653f | Iustin Pop | |
316 | 2fc5653f | Iustin Pop | -- | Return the first result with a True condition, or the default otherwise. |
317 | 2fc5653f | Iustin Pop | select :: a -- ^ default result |
318 | 2fc5653f | Iustin Pop | -> [(Bool, a)] -- ^ list of \"condition, result\" |
319 | 2fc5653f | Iustin Pop | -> a -- ^ first result which has a True condition, or default |
320 | 2fc5653f | Iustin Pop | select def = maybe def snd . find fst |
321 | 2fc5653f | Iustin Pop | |
322 | a1da8a50 | Klaus Aehlig | -- | Apply a function to the first element of a list, return the default |
323 | a1da8a50 | Klaus Aehlig | -- value, if the list is empty. This is just a convenient combination of |
324 | a1da8a50 | Klaus Aehlig | -- maybe and listToMaybe. |
325 | a1da8a50 | Klaus Aehlig | runListHead :: a -> (b -> a) -> [b] -> a |
326 | a1da8a50 | Klaus Aehlig | runListHead a f = maybe a f . listToMaybe |
327 | a1da8a50 | Klaus Aehlig | |
328 | 2fc5653f | Iustin Pop | -- * Lookup of partial names functionality |
329 | 2fc5653f | Iustin Pop | |
330 | 2fc5653f | Iustin Pop | -- | The priority of a match in a lookup result. |
331 | 2fc5653f | Iustin Pop | data MatchPriority = ExactMatch |
332 | 2fc5653f | Iustin Pop | | MultipleMatch |
333 | 2fc5653f | Iustin Pop | | PartialMatch |
334 | 2fc5653f | Iustin Pop | | FailMatch |
335 | 139c0683 | Iustin Pop | deriving (Show, Enum, Eq, Ord) |
336 | 2fc5653f | Iustin Pop | |
337 | 2fc5653f | Iustin Pop | -- | The result of a name lookup in a list. |
338 | 2fc5653f | Iustin Pop | data LookupResult = LookupResult |
339 | 2fc5653f | Iustin Pop | { lrMatchPriority :: MatchPriority -- ^ The result type |
340 | 2fc5653f | Iustin Pop | -- | Matching value (for ExactMatch, PartialMatch), Lookup string otherwise |
341 | 2fc5653f | Iustin Pop | , lrContent :: String |
342 | 139c0683 | Iustin Pop | } deriving (Show) |
343 | 2fc5653f | Iustin Pop | |
344 | 2fc5653f | Iustin Pop | -- | Lookup results have an absolute preference ordering. |
345 | 2fc5653f | Iustin Pop | instance Eq LookupResult where |
346 | 2fc5653f | Iustin Pop | (==) = (==) `on` lrMatchPriority |
347 | 2fc5653f | Iustin Pop | |
348 | 2fc5653f | Iustin Pop | instance Ord LookupResult where |
349 | 2fc5653f | Iustin Pop | compare = compare `on` lrMatchPriority |
350 | 2fc5653f | Iustin Pop | |
351 | 2fc5653f | Iustin Pop | -- | Check for prefix matches in names. |
352 | 2fc5653f | Iustin Pop | -- Implemented in Ganeti core utils.text.MatchNameComponent |
353 | 2fc5653f | Iustin Pop | -- as the regexp r"^%s(\..*)?$" % re.escape(key) |
354 | 2fc5653f | Iustin Pop | prefixMatch :: String -- ^ Lookup |
355 | 2fc5653f | Iustin Pop | -> String -- ^ Full name |
356 | 2fc5653f | Iustin Pop | -> Bool -- ^ Whether there is a prefix match |
357 | 2fc5653f | Iustin Pop | prefixMatch = isPrefixOf . (++ ".") |
358 | 2fc5653f | Iustin Pop | |
359 | 2fc5653f | Iustin Pop | -- | Is the lookup priority a "good" one? |
360 | 2fc5653f | Iustin Pop | goodMatchPriority :: MatchPriority -> Bool |
361 | 2fc5653f | Iustin Pop | goodMatchPriority ExactMatch = True |
362 | 2fc5653f | Iustin Pop | goodMatchPriority PartialMatch = True |
363 | 2fc5653f | Iustin Pop | goodMatchPriority _ = False |
364 | 2fc5653f | Iustin Pop | |
365 | 2fc5653f | Iustin Pop | -- | Is the lookup result an actual match? |
366 | 2fc5653f | Iustin Pop | goodLookupResult :: LookupResult -> Bool |
367 | 2fc5653f | Iustin Pop | goodLookupResult = goodMatchPriority . lrMatchPriority |
368 | 2fc5653f | Iustin Pop | |
369 | 2fc5653f | Iustin Pop | -- | Compares a canonical name and a lookup string. |
370 | 2fc5653f | Iustin Pop | compareNameComponent :: String -- ^ Canonical (target) name |
371 | 2fc5653f | Iustin Pop | -> String -- ^ Partial (lookup) name |
372 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ Result of the lookup |
373 | 2fc5653f | Iustin Pop | compareNameComponent cnl lkp = |
374 | 2fc5653f | Iustin Pop | select (LookupResult FailMatch lkp) |
375 | 2fc5653f | Iustin Pop | [ (cnl == lkp , LookupResult ExactMatch cnl) |
376 | 2fc5653f | Iustin Pop | , (prefixMatch lkp cnl , LookupResult PartialMatch cnl) |
377 | 2fc5653f | Iustin Pop | ] |
378 | 2fc5653f | Iustin Pop | |
379 | 2fc5653f | Iustin Pop | -- | Lookup a string and choose the best result. |
380 | 2fc5653f | Iustin Pop | chooseLookupResult :: String -- ^ Lookup key |
381 | 2fc5653f | Iustin Pop | -> String -- ^ String to compare to the lookup key |
382 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ Previous result |
383 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ New result |
384 | 2fc5653f | Iustin Pop | chooseLookupResult lkp cstr old = |
385 | 2fc5653f | Iustin Pop | -- default: use class order to pick the minimum result |
386 | 2fc5653f | Iustin Pop | select (min new old) |
387 | 2fc5653f | Iustin Pop | -- special cases: |
388 | 2fc5653f | Iustin Pop | -- short circuit if the new result is an exact match |
389 | 2fc5653f | Iustin Pop | [ (lrMatchPriority new == ExactMatch, new) |
390 | 2fc5653f | Iustin Pop | -- if both are partial matches generate a multiple match |
391 | 2fc5653f | Iustin Pop | , (partial2, LookupResult MultipleMatch lkp) |
392 | 2fc5653f | Iustin Pop | ] where new = compareNameComponent cstr lkp |
393 | 2fc5653f | Iustin Pop | partial2 = all ((PartialMatch==) . lrMatchPriority) [old, new] |
394 | 2fc5653f | Iustin Pop | |
395 | 2fc5653f | Iustin Pop | -- | Find the canonical name for a lookup string in a list of names. |
396 | 2fc5653f | Iustin Pop | lookupName :: [String] -- ^ List of keys |
397 | 2fc5653f | Iustin Pop | -> String -- ^ Lookup string |
398 | 2fc5653f | Iustin Pop | -> LookupResult -- ^ Result of the lookup |
399 | 2fc5653f | Iustin Pop | lookupName l s = foldr (chooseLookupResult s) |
400 | 2fc5653f | Iustin Pop | (LookupResult FailMatch s) l |
401 | 4651c69f | Jose A. Lopes | |
402 | 4651c69f | Jose A. Lopes | -- | Wrapper for a Haskell 'Set' |
403 | 4651c69f | Jose A. Lopes | -- |
404 | 4651c69f | Jose A. Lopes | -- This type wraps a 'Set' and it is used in the Haskell to Python |
405 | 4651c69f | Jose A. Lopes | -- opcode generation to transform a Haskell 'Set' into a Python 'list' |
406 | 4651c69f | Jose A. Lopes | -- without duplicate elements. |
407 | 4651c69f | Jose A. Lopes | newtype ListSet a = ListSet { unListSet :: Set a } |
408 | 4651c69f | Jose A. Lopes | deriving (Eq, Show) |
409 | 4651c69f | Jose A. Lopes | |
410 | 4651c69f | Jose A. Lopes | instance (Ord a, JSON a) => JSON (ListSet a) where |
411 | 4651c69f | Jose A. Lopes | showJSON = JSON.showJSON . unListSet |
412 | 4651c69f | Jose A. Lopes | readJSON = liftM ListSet . JSON.readJSON |
413 | 4651c69f | Jose A. Lopes | |
414 | 4651c69f | Jose A. Lopes | emptyListSet :: ListSet a |
415 | 4651c69f | Jose A. Lopes | emptyListSet = ListSet Set.empty |