Generalize some Result function into monad ones

[ganeti-local] / Ganeti / HTools / Utils.hs

diff --git a/Ganeti/HTools/Utils.hs b/Ganeti/HTools/Utils.hs
index c231a6f..f782118 100644 (file)
--- a/Ganeti/HTools/Utils.hs
+++ b/Ganeti/HTools/Utils.hs
@@ -3,19 +3,12 @@
 module Ganeti.HTools.Utils
     (
       debug
 module Ganeti.HTools.Utils
     (
       debug

-    , isLeft
-    , fromLeft
-    , fromRight

     , sepSplit
     , swapPairs
     , varianceCoeff
     , readData
     , commaJoin
     , sepSplit
     , swapPairs
     , varianceCoeff
     , readData
     , commaJoin

-    , combineEithers
-    , ensureEitherList
-    , eitherListHead

     , readEitherString
     , readEitherString

-    , parseEitherList

     , loadJSArray
     , fromObj
     , getStringElement
     , loadJSArray
     , fromObj
     , getStringElement

@@ -25,17 +18,17 @@ module Ganeti.HTools.Utils
     , getObjectElement
     , asJSObject
     , asObjectList
     , getObjectElement
     , asJSObject
     , asObjectList

-    , concatEitherElems
-    , applyEither1
-    , applyEither2
+    , Result(Ok, Bad)
+    , fromJResult
+    , (|+)

     ) where
 
 import Data.Either
 import Data.List
     ) where
 
 import Data.Either
 import Data.List

-import Monad
+import Control.Monad

 import System
 import System.IO
 import System
 import System.IO

-import Text.JSON
+import qualified Text.JSON as J

 import Text.Printf (printf)
 
 import Debug.Trace
 import Text.Printf (printf)
 
 import Debug.Trace

@@ -44,18 +37,29 @@ import Debug.Trace
 debug :: Show a => a -> a
 debug x = trace (show x) x
 
 debug :: Show a => a -> a
 debug x = trace (show x) x
 

--- | Check if the given argument is Left something
-isLeft :: Either a b -> Bool
-isLeft val =
-    case val of
-      Left _ -> True
-      _ -> False

 
 

-fromLeft :: Either a b -> a
-fromLeft = either (\x -> x) (\_ -> undefined)
+{-

 
 

-fromRight :: Either a b -> b
-fromRight = either (\_ -> undefined) id
+This is similar to the JSON library Result type - *very* similar, but
+we want to use it in multiple places, so we abstract it into a
+mini-library here
+
+-}
+
+data Result a
+    = Bad String
+    | Ok a
+    deriving (Show)
+
+instance Monad Result where
+    (>>=) (Bad x) _ = Bad x
+    (>>=) (Ok x) fn = fn x
+    return = Ok
+    fail = Bad
+
+fromJResult :: Monad m => J.Result a -> m a
+fromJResult (J.Error x) = fail x
+fromJResult (J.Ok x) = return x

 
 -- | Comma-join a string list.
 commaJoin :: [String] -> String
 
 -- | Comma-join a string list.
 commaJoin :: [String] -> String

@@ -98,110 +102,53 @@ stdDev lst =
 varianceCoeff :: Floating a => [a] -> a
 varianceCoeff lst = (stdDev lst) / (fromIntegral $ length lst)
 
 varianceCoeff :: Floating a => [a] -> a
 varianceCoeff lst = (stdDev lst) / (fromIntegral $ length lst)
 

--- | Get a Right result or print the error and exit
-readData :: (String -> IO (Either String String)) -> String -> IO String
-readData fn host = do
-  nd <- fn host
-  when (isLeft nd) $
-       do
-         putStrLn $ fromLeft nd
+-- | Get an Ok result or print the error and exit
+readData :: Result a -> IO a
+readData nd =
+    (case nd of
+       Bad x -> do
+         putStrLn x

          exitWith $ ExitFailure 1
          exitWith $ ExitFailure 1

-  return $ fromRight nd
-
-{-- Our cheap monad-like stuff.
+       Ok x -> return x)

 
 

-Thi is needed since Either e a is already a monad instance somewhere
-in the standard libraries (Control.Monad.Error) and we don't need that
-entire thing.
-
--}
-combineEithers :: (Either String a)
-               -> (a -> Either String b)
-               -> (Either String b)
-combineEithers (Left s) _ = Left s
-combineEithers (Right s) f = f s
-
-ensureEitherList :: [Either String a] -> Either String [a]
-ensureEitherList lst =
-    foldr (\elem accu ->
-               case (elem, accu) of
-                 (Left x, _) -> Left x
-                 (_, Left x) -> Left x -- should never happen
-                 (Right e, Right a) -> Right (e:a)
-          )
-    (Right []) lst
-
-eitherListHead :: Either String [a] -> Either String a
-eitherListHead lst =
-    case lst of
-      Left x -> Left x
-      Right (x:_) -> Right x
-      Right [] -> Left "List empty"
-
-readEitherString :: JSValue -> Either String String
+readEitherString :: (Monad m) => J.JSValue -> m String

 readEitherString v =
     case v of
 readEitherString v =
     case v of

-      JSString s -> Right $ fromJSString s
-      _ -> Left "Wrong JSON type"
-
-parseEitherList :: (JSObject JSValue -> Either String String)
-          -> [JSObject JSValue]
-          -> Either String String
-parseEitherList fn idata =
-    let ml = ensureEitherList $ map fn idata
-    in ml `combineEithers` (Right . unlines)
+      J.JSString s -> return $ J.fromJSString s
+      _ -> fail "Wrong JSON type"

 
 

-loadJSArray :: String -> Either String [JSObject JSValue]
-loadJSArray s = resultToEither $ decodeStrict s
+loadJSArray :: (Monad m) => String -> m [J.JSObject J.JSValue]
+loadJSArray s = fromJResult $ J.decodeStrict s

 
 

-fromObj :: JSON a => String -> JSObject JSValue -> Either String a
+fromObj :: (J.JSON a, Monad m) => String -> J.JSObject J.JSValue -> m a

 fromObj k o =
 fromObj k o =

-    case lookup k (fromJSObject o) of
-      Nothing -> Left $ printf "key '%s' not found" k
-      Just val -> resultToEither $ readJSON val
+    case lookup k (J.fromJSObject o) of
+      Nothing -> fail $ printf "key '%s' not found" k
+      Just val -> fromJResult $ J.readJSON val

 
 

-getStringElement :: String -> JSObject JSValue -> Either String String
+getStringElement :: (Monad m) => String -> J.JSObject J.JSValue -> m String

 getStringElement = fromObj
 
 getStringElement = fromObj
 

-getIntElement :: String -> JSObject JSValue -> Either String Int
+getIntElement :: (Monad m) => String -> J.JSObject J.JSValue -> m Int

 getIntElement = fromObj
 
 getIntElement = fromObj
 

-getBoolElement :: String -> JSObject JSValue -> Either String Bool
+getBoolElement :: (Monad m) => String -> J.JSObject J.JSValue -> m Bool

 getBoolElement = fromObj
 
 getBoolElement = fromObj
 

-getListElement :: String -> JSObject JSValue
-               -> Either String [JSValue]
+getListElement :: (Monad m) => String -> J.JSObject J.JSValue -> m [J.JSValue]

 getListElement = fromObj
 
 getListElement = fromObj
 

-getObjectElement :: String -> JSObject JSValue
-                 -> Either String (JSObject JSValue)
+getObjectElement :: (Monad m) => String -> J.JSObject J.JSValue
+                 -> m (J.JSObject J.JSValue)

 getObjectElement = fromObj
 
 getObjectElement = fromObj
 

-asJSObject :: JSValue -> Either String (JSObject JSValue)
-asJSObject (JSObject a) = Right a
-asJSObject _ = Left "not an object"
-
-asObjectList :: [JSValue] -> Either String [JSObject JSValue]
-asObjectList =
-    ensureEitherList . map asJSObject
-
-concatEitherElems :: Either String String
-            -> Either String String
-            -> Either String String
-concatEitherElems = applyEither2 (\x y -> x ++ "|" ++ y)
-
-applyEither1 :: (a -> b) -> Either String a -> Either String b
-applyEither1 fn a =
-    case a of
-      Left x -> Left x
-      Right y -> Right $ fn y
-
-applyEither2 :: (a -> b -> c)
-       -> Either String a
-       -> Either String b
-       -> Either String c
-applyEither2 fn a b =
-    case (a, b) of
-      (Right x, Right y) -> Right $ fn x y
-      (Left x, _) -> Left x
-      (_, Left y) -> Left y
+asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
+asJSObject (J.JSObject a) = return a
+asJSObject _ = fail "not an object"
+
+asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
+asObjectList = sequence . map asJSObject
+
+-- | Function to concat two strings with a separator under a monad
+(|+) :: (Monad m) => m String -> m String -> m String
+(|+) = liftM2 (\x y -> x ++ "|" ++ y)