aboutsummaryrefslogtreecommitdiffstats
path: root/src/Verismith/Result.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Verismith/Result.hs')
-rw-r--r--src/Verismith/Result.hs209
1 files changed, 108 insertions, 101 deletions
diff --git a/src/Verismith/Result.hs b/src/Verismith/Result.hs
index 78c8dd6..dd32582 100644
--- a/src/Verismith/Result.hs
+++ b/src/Verismith/Result.hs
@@ -1,50 +1,55 @@
-{-|
-Module : Verismith.Result
-Description : Result monadic type.
-Copyright : (c) 2019, Yann Herklotz Grave
-License : GPL-3
-Maintainer : yann [at] yannherklotz [dot] com
-Stability : experimental
-Portability : POSIX
-
-Result monadic type. This is nearly equivalent to the transformers 'Error' type,
-but to have more control this is reimplemented with the instances that are
-needed in "Verismith".
--}
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- |
+-- Module : Verismith.Result
+-- Description : Result monadic type.
+-- Copyright : (c) 2019, Yann Herklotz Grave
+-- License : GPL-3
+-- Maintainer : yann [at] yannherklotz [dot] com
+-- Stability : experimental
+-- Portability : POSIX
+--
+-- Result monadic type. This is nearly equivalent to the transformers 'Error' type,
+-- but to have more control this is reimplemented with the instances that are
+-- needed in "Verismith".
module Verismith.Result
- ( Result(..)
- , ResultT(..)
- , justPass
- , justFail
- , (<?>)
- , annotate
- )
+ ( Result (..),
+ ResultT (..),
+ justPass,
+ justFail,
+ (<?>),
+ annotate,
+ )
where
-import Control.Monad (liftM)
-import Control.Monad.Base
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Control
-import Data.Bifunctor (Bifunctor (..))
-import Shelly (RunFailed (..), Sh, catch_sh)
-import Shelly.Lifted (MonadSh, MonadShControl, ShM,
- liftSh, liftShWith, restoreSh)
+import Control.Monad (liftM)
+import Control.Monad.Base
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Control
+import Data.Bifunctor (Bifunctor (..))
+import Shelly (RunFailed (..), Sh, catch_sh)
+import Shelly.Lifted
+ ( MonadSh,
+ MonadShControl,
+ ShM,
+ liftSh,
+ liftShWith,
+ restoreSh,
+ )
-- | Result type which is equivalent to 'Either' or 'Error'. This is
-- reimplemented so that there is full control over the 'Monad' definition and
-- definition of a 'Monad' transformer 'ResultT'.
-data Result a b = Fail a
- | Pass b
- deriving (Eq, Show)
+data Result a b
+ = Fail a
+ | Pass b
+ deriving (Eq, Show)
justPass :: Result a b -> Maybe b
justPass (Fail _) = Nothing
@@ -55,105 +60,107 @@ justFail (Pass _) = Nothing
justFail (Fail a) = Just a
instance Semigroup (Result a b) where
- Pass _ <> a = a
- a <> _ = a
+ Pass _ <> a = a
+ a <> _ = a
instance (Monoid b) => Monoid (Result a b) where
- mempty = Pass mempty
+ mempty = Pass mempty
instance Functor (Result a) where
- fmap f (Pass a) = Pass $ f a
- fmap _ (Fail b) = Fail b
+ fmap f (Pass a) = Pass $ f a
+ fmap _ (Fail b) = Fail b
instance Applicative (Result a) where
- pure = Pass
- Fail e <*> _ = Fail e
- Pass f <*> r = fmap f r
+ pure = Pass
+ Fail e <*> _ = Fail e
+ Pass f <*> r = fmap f r
instance Monad (Result a) where
- Pass a >>= f = f a
- Fail b >>= _ = Fail b
+ Pass a >>= f = f a
+ Fail b >>= _ = Fail b
instance MonadBase (Result a) (Result a) where
- liftBase = id
+ liftBase = id
instance Bifunctor Result where
- bimap a _ (Fail c) = Fail $ a c
- bimap _ b (Pass c) = Pass $ b c
+ bimap a _ (Fail c) = Fail $ a c
+ bimap _ b (Pass c) = Pass $ b c
-- | The transformer for the 'Result' type. This
-newtype ResultT a m b = ResultT { runResultT :: m (Result a b) }
+newtype ResultT a m b = ResultT {runResultT :: m (Result a b)}
instance Functor f => Functor (ResultT a f) where
- fmap f = ResultT . fmap (fmap f) . runResultT
+ fmap f = ResultT . fmap (fmap f) . runResultT
instance Monad m => Applicative (ResultT a m) where
- pure = ResultT . pure . pure
- f <*> a = ResultT $ do
- f' <- runResultT f
- case f' of
- Fail e -> return (Fail e)
- Pass k -> do
- a' <- runResultT a
- case a' of
- Fail e -> return (Fail e)
- Pass v -> return (Pass $ k v)
+ pure = ResultT . pure . pure
+ f <*> a = ResultT $ do
+ f' <- runResultT f
+ case f' of
+ Fail e -> return (Fail e)
+ Pass k -> do
+ a' <- runResultT a
+ case a' of
+ Fail e -> return (Fail e)
+ Pass v -> return (Pass $ k v)
instance Monad m => Monad (ResultT a m) where
- a >>= b = ResultT $ do
- m <- runResultT a
- case m of
- Fail e -> return (Fail e)
- Pass p -> runResultT (b p)
+ a >>= b = ResultT $ do
+ m <- runResultT a
+ case m of
+ Fail e -> return (Fail e)
+ Pass p -> runResultT (b p)
instance (MonadSh m, Monoid a) => MonadSh (ResultT a m) where
- liftSh s =
- ResultT
- . liftSh
- . catch_sh (Pass <$> s)
- $ (const (Fail <$> return mempty) :: RunFailed -> Sh (Result a b))
+ liftSh s =
+ ResultT
+ . liftSh
+ . catch_sh (Pass <$> s)
+ $ (const (Fail <$> return mempty) :: RunFailed -> Sh (Result a b))
instance MonadIO m => MonadIO (ResultT a m) where
- liftIO s = ResultT $ Pass <$> liftIO s
+ liftIO s = ResultT $ Pass <$> liftIO s
instance MonadBase b m => MonadBase b (ResultT a m) where
- liftBase = liftBaseDefault
+ liftBase = liftBaseDefault
instance MonadTrans (ResultT e) where
- lift m = ResultT $ Pass <$> m
+ lift m = ResultT $ Pass <$> m
instance MonadTransControl (ResultT a) where
- type StT (ResultT a) b = Result a b
- liftWith f = ResultT $ return <$> f runResultT
- restoreT = ResultT
- {-# INLINABLE liftWith #-}
- {-# INLINABLE restoreT #-}
+ type StT (ResultT a) b = Result a b
+ liftWith f = ResultT $ return <$> f runResultT
+ restoreT = ResultT
+ {-# INLINEABLE liftWith #-}
+ {-# INLINEABLE 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 #-}
-
-instance (MonadShControl m)
- => MonadShControl (ResultT a m) where
- newtype ShM (ResultT a m) b = ResultTShM (ShM m (Result a b))
- liftShWith f =
- ResultT $ liftM return $ liftShWith $ \runInSh -> f $ \k ->
- liftM ResultTShM $ runInSh $ runResultT k
- restoreSh (ResultTShM m) = ResultT . restoreSh $ m
- {-# INLINE liftShWith #-}
- {-# INLINE restoreSh #-}
+ type StM (ResultT a m) b = ComposeSt (ResultT a) m b
+ liftBaseWith = defaultLiftBaseWith
+ restoreM = defaultRestoreM
+ {-# INLINEABLE liftBaseWith #-}
+ {-# INLINEABLE restoreM #-}
+
+instance
+ (MonadShControl m) =>
+ MonadShControl (ResultT a m)
+ where
+ newtype ShM (ResultT a m) b = ResultTShM (ShM m (Result a b))
+ liftShWith f =
+ ResultT $ liftM return $ liftShWith $ \runInSh -> f $ \k ->
+ liftM ResultTShM $ runInSh $ runResultT k
+ restoreSh (ResultTShM m) = ResultT . restoreSh $ m
+ {-# INLINE liftShWith #-}
+ {-# INLINE restoreSh #-}
infix 0 <?>
(<?>) :: (Monad m, Monoid a) => ResultT a m b -> a -> ResultT a m b
m <?> b = ResultT $ do
- a <- runResultT m
- case a of
- Pass a' -> return $ Pass a'
- Fail a' -> return . Fail $ a' <> b
+ a <- runResultT m
+ case a of
+ Pass a' -> return $ Pass a'
+ Fail a' -> return . Fail $ a' <> b
annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b
annotate = flip (<?>)
generated by cgit (git 2.34.1) at 2024-05-09 23:04:14 +0000