diff options
author | Yann Herklotz <git@ymhg.org> | 2019-04-19 00:28:11 +0100 |
---|---|---|
committer | Yann Herklotz <git@ymhg.org> | 2019-04-19 00:28:11 +0100 |
commit | 72ceee9cd751cfa0dc799677325ff2bfbc0f7550 (patch) | |
tree | fbbdfdf6cd24cdcd3de73219ff17b792bb7e6a37 /src/VeriFuzz/Result.hs | |
parent | 72ca7b273a8adf421d481e0caa97caa8a565187a (diff) | |
download | verismith-72ceee9cd751cfa0dc799677325ff2bfbc0f7550.tar.gz verismith-72ceee9cd751cfa0dc799677325ff2bfbc0f7550.zip |
Extend ResultT and Result with more instances
Diffstat (limited to 'src/VeriFuzz/Result.hs')
-rw-r--r-- | src/VeriFuzz/Result.hs | 42 |
1 files changed, 38 insertions, 4 deletions
diff --git a/src/VeriFuzz/Result.hs b/src/VeriFuzz/Result.hs index 04aa899..c618c77 100644 --- a/src/VeriFuzz/Result.hs +++ b/src/VeriFuzz/Result.hs @@ -12,7 +12,12 @@ but to have more control this is reimplemented with the instances that are needed in "VeriFuzz". -} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module VeriFuzz.Result ( Result(..) @@ -22,9 +27,13 @@ module VeriFuzz.Result ) where +import Control.Monad (liftM) +import Control.Monad.Base import Control.Monad.IO.Class -import Shelly (RunFailed (..), Sh, catch_sh) -import Shelly.Lifted (MonadSh, liftSh) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Shelly (RunFailed (..), Sh, catch_sh) +import Shelly.Lifted (MonadSh, liftSh) -- | Result type which is equivalent to 'Either' or 'Error'. This is -- reimplemented so that there is full control over the 'Monad' definition and @@ -53,6 +62,9 @@ instance Monad (Result a) where Pass a >>= f = f a Fail b >>= _ = Fail b +instance MonadBase (Result a) (Result a) where + liftBase = id + -- | The transformer for the 'Result' type. This newtype ResultT a m b = ResultT { runResultT :: m (Result a b) } @@ -85,9 +97,31 @@ instance (MonadSh m, Monoid a) => MonadSh (ResultT a m) where . catch_sh (Pass <$> s) $ (const (Fail <$> return mempty) :: RunFailed -> Sh (Result a b)) -instance (MonadIO m) => MonadIO (ResultT a m) where +instance MonadIO m => MonadIO (ResultT a m) where liftIO s = ResultT $ Pass <$> liftIO s +instance MonadBase b m => MonadBase b (ResultT a m) where + liftBase = liftBaseDefault + +instance MonadTrans (ResultT e) where + lift m = ResultT $ do + a <- m + return (Pass a) + +instance MonadTransControl (ResultT a) where + type StT (ResultT a) b = Result a b + liftWith f = ResultT $ liftM return $ f $ runResultT + restoreT = ResultT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +instance MonadBaseControl IO m => MonadBaseControl IO (ResultT a m) where + type StM (ResultT a m) b = ComposeSt (ResultT a) m b + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINABLE liftBaseWith #-} + {-# INLINABLE restoreM #-} + infix 0 <?> (<?>) :: (Monad m, Monoid a) => ResultT a m b -> a -> ResultT a m b |