Currently, our error monad—Result—has a plain string error type. This is not good, as we don't have structured errors, we can't pass back proper error information to Python code, etc.
To solve this, we generalise this type as 'GenericResult a', and make Result an alias to 'GenericResult String' for compatibility with the old code. New error hierarchies will be introduced as different types. Furthermore, we generalise our helper functions too, so that they can work on any 'GeneralInstance a' type, not only Result. There are two small drawbacks to this generalisation. First, a Monad instance requires (at least for the way we use it) a 'fail :: String -> m a' instance, so we need to be able to build an 'a' value from a string; therefore, we can implement the Monad instance only for a newly-introduced typeclass, 'FromString', which requires the needed conversion function. Second, due to the fact that 'String' is a type alias (for [Char]) instead of an actual type, we need to enable the FlexibleInstances language pragma; as far as I know, this has no significant drawbacks. Signed-off-by: Iustin Pop <[email protected]> --- htest/Test/Ganeti/BasicTypes.hs | 2 +- htest/Test/Ganeti/JSON.hs | 2 +- htest/Test/Ganeti/TestCommon.hs | 4 +- htools/Ganeti/BasicTypes.hs | 71 +++++++++++++++++++++++---------------- 4 files changed, 46 insertions(+), 33 deletions(-) diff --git a/htest/Test/Ganeti/BasicTypes.hs b/htest/Test/Ganeti/BasicTypes.hs index d3ae51f..af90b0e 100644 --- a/htest/Test/Ganeti/BasicTypes.hs +++ b/htest/Test/Ganeti/BasicTypes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Unittests for ganeti-htools. diff --git a/htest/Test/Ganeti/JSON.hs b/htest/Test/Ganeti/JSON.hs index 6279520..a5477a5 100644 --- a/htest/Test/Ganeti/JSON.hs +++ b/htest/Test/Ganeti/JSON.hs @@ -49,7 +49,7 @@ prop_toArrayFail :: Int -> String -> Bool -> Property prop_toArrayFail i s b = -- poor man's instance Arbitrary JSValue forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item -> - case JSON.toArray item of + case JSON.toArray item::BasicTypes.Result [J.JSValue] of BasicTypes.Bad _ -> passTest BasicTypes.Ok result -> failTest $ "Unexpected parse, got " ++ show result diff --git a/htest/Test/Ganeti/TestCommon.hs b/htest/Test/Ganeti/TestCommon.hs index 27796fc..d61cfb8 100644 --- a/htest/Test/Ganeti/TestCommon.hs +++ b/htest/Test/Ganeti/TestCommon.hs @@ -204,6 +204,6 @@ testSerialisation a = J.Ok a' -> a ==? a' -- | Result to PropertyM IO. -resultProp :: BasicTypes.Result a -> PropertyM IO a -resultProp (BasicTypes.Bad msg) = stop $ failTest msg +resultProp :: (Show a) => BasicTypes.GenericResult a b -> PropertyM IO b +resultProp (BasicTypes.Bad err) = stop . failTest $ show err resultProp (BasicTypes.Ok val) = return val diff --git a/htools/Ganeti/BasicTypes.hs b/htools/Ganeti/BasicTypes.hs index d688a9c..8f29f33 100644 --- a/htools/Ganeti/BasicTypes.hs +++ b/htools/Ganeti/BasicTypes.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + {- Copyright (C) 2009, 2010, 2011, 2012 Google Inc. @@ -20,9 +22,11 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA -} module Ganeti.BasicTypes - ( Result(..) + ( GenericResult(..) + , Result , ResultT(..) , resultT + , FromString(..) , isOk , isBad , eitherToResult @@ -44,27 +48,36 @@ import Control.Monad.Trans import Data.Function import Data.List --- | 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. --- --- The failure value for this monad is simply a string. -data Result a - = Bad String - | Ok a +-- | Generic monad for our error handling mechanisms. +data GenericResult a b + = Bad a + | Ok b deriving (Show, Read, Eq) -instance Monad Result where +-- | Type alias for a string Result. +type Result = GenericResult String + +-- | Type class for things that can be built from strings. +class FromString a where + mkFromString :: String -> a + +-- | Trivial 'String' instance; requires FlexibleInstances extension +-- though. +instance FromString [Char] where + mkFromString = id + +-- | 'Monad' instance for 'GenericResult'. +instance (FromString a) => Monad (GenericResult a) where (>>=) (Bad x) _ = Bad x (>>=) (Ok x) fn = fn x return = Ok - fail = Bad + fail = Bad . mkFromString -instance Functor Result where +instance Functor (GenericResult a) where fmap _ (Bad msg) = Bad msg fmap fn (Ok val) = Ok (fn val) -instance MonadPlus Result where +instance MonadPlus (GenericResult String) where mzero = Bad "zero Result when used as MonadPlus" -- for mplus, when we 'add' two Bad values, we concatenate their -- error descriptions @@ -72,7 +85,7 @@ instance MonadPlus Result where (Bad _) `mplus` x = x x@(Ok _) `mplus` _ = x -instance Applicative Result where +instance Applicative (GenericResult a) where pure = Ok (Bad f) <*> _ = Bad f _ <*> (Bad x) = Bad x @@ -80,10 +93,10 @@ instance Applicative Result where -- | This is a monad transformation for Result. It's implementation is -- based on the implementations of MaybeT and ErrorT. -newtype ResultT m a = ResultT {runResultT :: m (Result a)} +newtype ResultT a m b = ResultT {runResultT :: m (GenericResult a b)} -instance (Monad m) => Monad (ResultT m) where - fail err = ResultT (return $ Bad err) +instance (Monad m, FromString a) => Monad (ResultT a m) where + fail err = ResultT (return . Bad $ mkFromString err) return = lift . return x >>= f = ResultT $ do a <- runResultT x @@ -91,29 +104,29 @@ instance (Monad m) => Monad (ResultT m) where Ok val -> runResultT $ f val Bad err -> return $ Bad err -instance MonadTrans ResultT where +instance MonadTrans (ResultT a) where lift x = ResultT (liftM Ok x) -instance (MonadIO m) => MonadIO (ResultT m) where +instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where liftIO = lift . liftIO -- | Lift a `Result` value to a `ResultT`. -resultT :: Monad m => Result a -> ResultT m a +resultT :: Monad m => GenericResult a b -> ResultT a m b resultT = ResultT . return --- | Simple checker for whether a 'Result' is OK. -isOk :: Result a -> Bool +-- | Simple checker for whether a 'GenericResult' is OK. +isOk :: GenericResult a b -> Bool isOk (Ok _) = True -isOk _ = False +isOk _ = False --- | Simple checker for whether a 'Result' is a failure. -isBad :: Result a -> Bool +-- | Simple checker for whether a 'GenericResult' is a failure. +isBad :: GenericResult a b -> Bool isBad = not . isOk --- | Converter from Either String to 'Result'. -eitherToResult :: Either String a -> Result a -eitherToResult (Left s) = Bad s -eitherToResult (Right v) = Ok v +-- | Converter from Either String to 'GeneicResult'. +eitherToResult :: Either a b -> GenericResult a b +eitherToResult (Left s) = Bad s +eitherToResult (Right v) = Ok v -- | Annotate a Result with an ownership information. annotateResult :: String -> Result a -> Result a -- 1.7.7.3
