aboutsummaryrefslogtreecommitdiffstats
path: root/src/VeriSmith/Result.hs
diff options
context:
space:
mode:
authorYann Herklotz <git@yannherklotz.com>2019-09-18 19:06:32 +0200
committerYann Herklotz <git@yannherklotz.com>2019-09-18 19:06:32 +0200
commit8d96fd2a541a2602544ced741552ebd17714c67d (patch)
tree2f53addec05793cf5b3e0274a3e8e9e5f76a7abe /src/VeriSmith/Result.hs
parentd14196cce14d1b4a4a9fba768b9f5238c8626624 (diff)
downloadverismith-8d96fd2a541a2602544ced741552ebd17714c67d.tar.gz
verismith-8d96fd2a541a2602544ced741552ebd17714c67d.zip
Rename main modules
Diffstat (limited to 'src/VeriSmith/Result.hs')
-rw-r--r--src/VeriSmith/Result.hs137
1 files changed, 0 insertions, 137 deletions
diff --git a/src/VeriSmith/Result.hs b/src/VeriSmith/Result.hs
deleted file mode 100644
index 7bfbf9b..0000000
--- a/src/VeriSmith/Result.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-|
-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 MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module VeriSmith.Result
- ( Result(..)
- , ResultT(..)
- , (<?>)
- , annotate
- )
-where
-
-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, liftSh)
-
--- | 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)
-
-instance Semigroup (Result a b) where
- Pass _ <> a = a
- a <> _ = a
-
-instance (Monoid b) => Monoid (Result a b) where
- mempty = Pass mempty
-
-instance Functor (Result a) where
- 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
-
-instance Monad (Result a) where
- Pass a >>= f = f a
- Fail b >>= _ = Fail b
-
-instance MonadBase (Result a) (Result a) where
- liftBase = id
-
-instance Bifunctor Result where
- 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) }
-
-instance Functor f => Functor (ResultT a f) where
- 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)
-
-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)
-
-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))
-
-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 $ 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 #-}
-
-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
-m <?> b = ResultT $ do
- 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 (<?>)