LGTM, thanks.
On Thu, Feb 6, 2014 at 10:52 AM, Klaus Aehlig <[email protected]> wrote: > From: Petr Pudlak <[email protected]> > > They have the very same functionality, and using our own FromString only > causes unnecessary code duplication. > > Signed-off-by: Petr Pudlak <[email protected]> > Reviewed-by: Klaus Aehlig <[email protected]> > > Cherry-pick of a87a017b023e2979b73f11dcf90 > > Signed-off-by: Klaus Aehlig <[email protected]> > --- > src/Ganeti/BasicTypes.hs | 39 +++++++++++++++------------------------ > src/Ganeti/Errors.hs | 6 +----- > src/Ganeti/HTools/Types.hs | 7 +++---- > 3 files changed, 19 insertions(+), 33 deletions(-) > > diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs > index 546cddb..193041b 100644 > --- a/src/Ganeti/BasicTypes.hs > +++ b/src/Ganeti/BasicTypes.hs > @@ -27,7 +27,7 @@ module Ganeti.BasicTypes > , Result > , ResultT(..) > , resultT > - , FromString(..) > + , Error(..) -- re-export from Control.Monad.Error > , isOk > , isBad > , justOk > @@ -74,35 +74,26 @@ genericResult _ g (Ok b) = g b > -- | 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 > +instance (Error a) => Monad (GenericResult a) where > (>>=) (Bad x) _ = Bad x > (>>=) (Ok x) fn = fn x > return = Ok > - fail = Bad . mkFromString > + fail = Bad . strMsg > > instance Functor (GenericResult a) where > fmap _ (Bad msg) = Bad msg > fmap fn (Ok val) = Ok (fn val) > > -instance (FromString a, Monoid a) => MonadPlus (GenericResult a) where > - mzero = Bad $ mkFromString "zero Result when used as MonadPlus" > +instance (Error a, Monoid a) => MonadPlus (GenericResult a) where > + mzero = Bad $ strMsg "zero Result when used as MonadPlus" > -- for mplus, when we 'add' two Bad values, we concatenate their > -- error descriptions > - (Bad x) `mplus` (Bad y) = Bad (x `mappend` mkFromString "; " `mappend` > y) > + (Bad x) `mplus` (Bad y) = Bad (x `mappend` strMsg "; " `mappend` y) > (Bad _) `mplus` x = x > x@(Ok _) `mplus` _ = x > > -instance (FromString a) => MonadError a (GenericResult a) where > +instance (Error a) => MonadError a (GenericResult a) where > throwError = Bad > catchError x h = genericResult h (const x) x > > @@ -112,7 +103,7 @@ instance Applicative (GenericResult a) where > _ <*> (Bad x) = Bad x > (Ok f) <*> (Ok x) = Ok $ f x > > -instance (FromString a, Monoid a) => Alternative (GenericResult a) where > +instance (Error a, Monoid a) => Alternative (GenericResult a) where > empty = mzero > (<|>) = mplus > > @@ -135,33 +126,33 @@ elimResultT l r = ResultT . (runResultT . result <=< > runResultT) > instance (Monad f) => Functor (ResultT a f) where > fmap f = ResultT . liftM (fmap f) . runResultT > > -instance (Monad m, FromString a) => Applicative (ResultT a m) where > +instance (Monad m, Error a) => Applicative (ResultT a m) where > pure = return > (<*>) = ap > > -instance (Monad m, FromString a) => Monad (ResultT a m) where > - fail err = ResultT (return . Bad $ mkFromString err) > +instance (Monad m, Error a) => Monad (ResultT a m) where > + fail err = ResultT (return . Bad $ strMsg err) > return = lift . return > (>>=) = flip (elimResultT throwError) > > -instance (Monad m, FromString a) => MonadError a (ResultT a m) where > +instance (Monad m, Error a) => MonadError a (ResultT a m) where > throwError = resultT . Bad > catchError x h = elimResultT h return x > > instance MonadTrans (ResultT a) where > lift = ResultT . liftM Ok > > -instance (MonadIO m, FromString a) => MonadIO (ResultT a m) where > +instance (MonadIO m, Error a) => MonadIO (ResultT a m) where > liftIO = lift . liftIO > > -instance (Monad m, FromString a, Monoid a) => MonadPlus (ResultT a m) > where > +instance (Monad m, Error a, Monoid a) => MonadPlus (ResultT a m) where > mzero = ResultT $ return mzero > -- Ensure that 'y' isn't run if 'x' contains a value. This makes it a > bit > -- more complicated than 'mplus' of 'GenericResult'. > mplus x y = elimResultT combine return x > where combine x' = ResultT $ liftM (mplus (Bad x')) (runResultT y) > > -instance (Monad m, FromString a, Monoid a) => Alternative (ResultT a m) > where > +instance (Monad m, Error a, Monoid a) => Alternative (ResultT a m) where > empty = mzero > (<|>) = mplus > > diff --git a/src/Ganeti/Errors.hs b/src/Ganeti/Errors.hs > index bf7c9f5..cebbbf3 100644 > --- a/src/Ganeti/Errors.hs > +++ b/src/Ganeti/Errors.hs > @@ -40,7 +40,6 @@ module Ganeti.Errors > , maybeToError > ) where > > -import Control.Monad.Error (Error(..)) > import Text.JSON hiding (Result, Ok) > import System.Exit > > @@ -113,15 +112,12 @@ $(genException "GanetiException" > ]) > > instance Error GanetiException where > - strMsg = mkFromString > + strMsg = GenericError > > instance JSON GanetiException where > showJSON = saveGanetiException > readJSON = loadGanetiException > > -instance FromString GanetiException where > - mkFromString = GenericError > - > -- | Error monad using 'GanetiException' type alias. > type ErrorResult = GenericResult GanetiException > > diff --git a/src/Ganeti/HTools/Types.hs b/src/Ganeti/HTools/Types.hs > index fd4fabc..df2d3f6 100644 > --- a/src/Ganeti/HTools/Types.hs > +++ b/src/Ganeti/HTools/Types.hs > @@ -367,11 +367,10 @@ type FailStats = [(FailMode, Int)] > -- will instead raise an exception. > type OpResult = GenericResult FailMode > > --- | 'FromString' instance for 'FailMode' designed to catch unintended > +-- | 'Error' instance for 'FailMode' designed to catch unintended > -- use as a general monad. > -instance FromString FailMode where > - mkFromString v = error $ "Programming error: OpResult used as generic > monad" > - ++ v > +instance Error FailMode where > + strMsg v = error $ "Programming error: OpResult used as generic monad" > ++ v > > -- | Conversion from 'OpResult' to 'Result'. > opToResult :: OpResult a -> Result a > -- > 1.9.0.rc1.175.g0b1dcb5 > >
