{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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,
  )
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,
  )

-- | 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 (Result a b -> Result a b -> Bool
(Result a b -> Result a b -> Bool)
-> (Result a b -> Result a b -> Bool) -> Eq (Result a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => Result a b -> Result a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => Result a b -> Result a b -> Bool
== :: Result a b -> Result a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => Result a b -> Result a b -> Bool
/= :: Result a b -> Result a b -> Bool
Eq, Int -> Result a b -> ShowS
[Result a b] -> ShowS
Result a b -> String
(Int -> Result a b -> ShowS)
-> (Result a b -> String)
-> ([Result a b] -> ShowS)
-> Show (Result a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> Result a b -> ShowS
forall a b. (Show a, Show b) => [Result a b] -> ShowS
forall a b. (Show a, Show b) => Result a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> Result a b -> ShowS
showsPrec :: Int -> Result a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => Result a b -> String
show :: Result a b -> String
$cshowList :: forall a b. (Show a, Show b) => [Result a b] -> ShowS
showList :: [Result a b] -> ShowS
Show)

justPass :: Result a b -> Maybe b
justPass :: forall a b. Result a b -> Maybe b
justPass (Fail a
_) = Maybe b
forall a. Maybe a
Nothing
justPass (Pass b
a) = b -> Maybe b
forall a. a -> Maybe a
Just b
a

justFail :: Result a b -> Maybe a
justFail :: forall a b. Result a b -> Maybe a
justFail (Pass b
_) = Maybe a
forall a. Maybe a
Nothing
justFail (Fail a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

instance Semigroup (Result a b) where
  Pass b
_ <> :: Result a b -> Result a b -> Result a b
<> Result a b
a = Result a b
a
  Result a b
a <> Result a b
_ = Result a b
a

instance (Monoid b) => Monoid (Result a b) where
  mempty :: Result a b
mempty = b -> Result a b
forall a b. b -> Result a b
Pass b
forall a. Monoid a => a
mempty

instance Functor (Result a) where
  fmap :: forall a b. (a -> b) -> Result a a -> Result a b
fmap a -> b
f (Pass a
a) = b -> Result a b
forall a b. b -> Result a b
Pass (b -> Result a b) -> b -> Result a b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  fmap a -> b
_ (Fail a
b) = a -> Result a b
forall a b. a -> Result a b
Fail a
b

instance Applicative (Result a) where
  pure :: forall a. a -> Result a a
pure = a -> Result a a
forall a b. b -> Result a b
Pass
  Fail a
e <*> :: forall a b. Result a (a -> b) -> Result a a -> Result a b
<*> Result a a
_ = a -> Result a b
forall a b. a -> Result a b
Fail a
e
  Pass a -> b
f <*> Result a a
r = (a -> b) -> Result a a -> Result a b
forall a b. (a -> b) -> Result a a -> Result a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Result a a
r

instance Monad (Result a) where
  Pass a
a >>= :: forall a b. Result a a -> (a -> Result a b) -> Result a b
>>= a -> Result a b
f = a -> Result a b
f a
a
  Fail a
b >>= a -> Result a b
_ = a -> Result a b
forall a b. a -> Result a b
Fail a
b

instance MonadBase (Result a) (Result a) where
  liftBase :: forall α. Result a α -> Result a α
liftBase = Result a α -> Result a α
forall a. a -> a
id

instance Bifunctor Result where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Result a c -> Result b d
bimap a -> b
a c -> d
_ (Fail a
c) = b -> Result b d
forall a b. a -> Result a b
Fail (b -> Result b d) -> b -> Result b d
forall a b. (a -> b) -> a -> b
$ a -> b
a a
c
  bimap a -> b
_ c -> d
b (Pass c
c) = d -> Result b d
forall a b. b -> Result a b
Pass (d -> Result b d) -> d -> Result b d
forall a b. (a -> b) -> a -> b
$ c -> d
b c
c

-- | The transformer for the 'Result' type. This
newtype ResultT a m b = ResultT {forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT :: m (Result a b)}

instance (Functor f) => Functor (ResultT a f) where
  fmap :: forall a b. (a -> b) -> ResultT a f a -> ResultT a f b
fmap a -> b
f = f (Result a b) -> ResultT a f b
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (f (Result a b) -> ResultT a f b)
-> (ResultT a f a -> f (Result a b))
-> ResultT a f a
-> ResultT a f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result a a -> Result a b) -> f (Result a a) -> f (Result a b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Result a a -> Result a b
forall a b. (a -> b) -> Result a a -> Result a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (f (Result a a) -> f (Result a b))
-> (ResultT a f a -> f (Result a a))
-> ResultT a f a
-> f (Result a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultT a f a -> f (Result a a)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT

instance (Monad m) => Applicative (ResultT a m) where
  pure :: forall a. a -> ResultT a m a
pure = m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a a) -> ResultT a m a)
-> (a -> m (Result a a)) -> a -> ResultT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a a -> m (Result a a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a a -> m (Result a a))
-> (a -> Result a a) -> a -> m (Result a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result a a
forall a. a -> Result a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ResultT a m (a -> b)
f <*> :: forall a b. ResultT a m (a -> b) -> ResultT a m a -> ResultT a m b
<*> ResultT a m a
a = m (Result a b) -> ResultT a m b
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a b) -> ResultT a m b)
-> m (Result a b) -> ResultT a m b
forall a b. (a -> b) -> a -> b
$ do
    Result a (a -> b)
f' <- ResultT a m (a -> b) -> m (Result a (a -> b))
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT ResultT a m (a -> b)
f
    case Result a (a -> b)
f' of
      Fail a
e -> Result a b -> m (Result a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a b
forall a b. a -> Result a b
Fail a
e)
      Pass a -> b
k -> do
        Result a a
a' <- ResultT a m a -> m (Result a a)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT ResultT a m a
a
        case Result a a
a' of
          Fail a
e -> Result a b -> m (Result a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a b
forall a b. a -> Result a b
Fail a
e)
          Pass a
v -> Result a b -> m (Result a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> Result a b
forall a b. b -> Result a b
Pass (b -> Result a b) -> b -> Result a b
forall a b. (a -> b) -> a -> b
$ a -> b
k a
v)

instance (Monad m) => Monad (ResultT a m) where
  ResultT a m a
a >>= :: forall a b. ResultT a m a -> (a -> ResultT a m b) -> ResultT a m b
>>= a -> ResultT a m b
b = m (Result a b) -> ResultT a m b
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a b) -> ResultT a m b)
-> m (Result a b) -> ResultT a m b
forall a b. (a -> b) -> a -> b
$ do
    Result a a
m <- ResultT a m a -> m (Result a a)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT ResultT a m a
a
    case Result a a
m of
      Fail a
e -> Result a b -> m (Result a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a b
forall a b. a -> Result a b
Fail a
e)
      Pass a
p -> ResultT a m b -> m (Result a b)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT (a -> ResultT a m b
b a
p)

instance (MonadSh m, Monoid a) => MonadSh (ResultT a m) where
  liftSh :: forall a. Sh a -> ResultT a m a
liftSh Sh a
s =
    m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT
      (m (Result a a) -> ResultT a m a)
-> ((RunFailed -> Sh (Result a a)) -> m (Result a a))
-> (RunFailed -> Sh (Result a a))
-> ResultT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sh (Result a a) -> m (Result a a)
forall a. Sh a -> m a
forall (m :: * -> *) a. MonadSh m => Sh a -> m a
liftSh
      (Sh (Result a a) -> m (Result a a))
-> ((RunFailed -> Sh (Result a a)) -> Sh (Result a a))
-> (RunFailed -> Sh (Result a a))
-> m (Result a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sh (Result a a)
-> (RunFailed -> Sh (Result a a)) -> Sh (Result a a)
forall e a. Exception e => Sh a -> (e -> Sh a) -> Sh a
catch_sh (a -> Result a a
forall a b. b -> Result a b
Pass (a -> Result a a) -> Sh a -> Sh (Result a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sh a
s)
      ((RunFailed -> Sh (Result a a)) -> ResultT a m a)
-> (RunFailed -> Sh (Result a a)) -> ResultT a m a
forall a b. (a -> b) -> a -> b
$ (Sh (Result a b) -> RunFailed -> Sh (Result a b)
forall a b. a -> b -> a
const (a -> Result a b
forall a b. a -> Result a b
Fail (a -> Result a b) -> Sh a -> Sh (Result a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Sh a
forall a. a -> Sh a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty) :: RunFailed -> Sh (Result a b))

instance (MonadIO m) => MonadIO (ResultT a m) where
  liftIO :: forall a. IO a -> ResultT a m a
liftIO IO a
s = m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a a) -> ResultT a m a)
-> m (Result a a) -> ResultT a m a
forall a b. (a -> b) -> a -> b
$ a -> Result a a
forall a b. b -> Result a b
Pass (a -> Result a a) -> m a -> m (Result a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
s

instance (MonadBase b m) => MonadBase b (ResultT a m) where
  liftBase :: forall α. b α -> ResultT a m α
liftBase = b α -> ResultT a m α
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) α.
(MonadTrans t, MonadBase b m) =>
b α -> t m α
liftBaseDefault

instance MonadTrans (ResultT e) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ResultT e m a
lift m a
m = m (Result e a) -> ResultT e m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result e a) -> ResultT e m a)
-> m (Result e a) -> ResultT e m a
forall a b. (a -> b) -> a -> b
$ a -> Result e a
forall a b. b -> Result a b
Pass (a -> Result e a) -> m a -> m (Result e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
m

instance MonadTransControl (ResultT a) where
  type StT (ResultT a) b = Result a b
  liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run (ResultT a) -> m a) -> ResultT a m a
liftWith Run (ResultT a) -> m a
f = m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a a) -> ResultT a m a)
-> m (Result a a) -> ResultT a m a
forall a b. (a -> b) -> a -> b
$ a -> Result a a
forall a. a -> Result a a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result a a) -> m a -> m (Result a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Run (ResultT a) -> m a
f ResultT a n b -> n (StT (ResultT a) b)
ResultT a n b -> n (Result a b)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
Run (ResultT a)
runResultT
  restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT (ResultT a) a) -> ResultT a m a
restoreT = m (StT (ResultT a) a) -> ResultT a m a
m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
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 :: forall a. (RunInBase (ResultT a m) IO -> IO a) -> ResultT a m a
liftBaseWith = (RunInBaseDefault (ResultT a) m IO -> IO a) -> ResultT a m a
(RunInBase (ResultT a m) IO -> IO a) -> ResultT a m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. StM (ResultT a m) a -> ResultT a m a
restoreM = ComposeSt (ResultT a) m a -> ResultT a m a
StM (ResultT a m) a -> ResultT a m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
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 :: forall a.
((forall x. ResultT a m x -> Sh (ShM (ResultT a m) x)) -> Sh a)
-> ResultT a m a
liftShWith (forall x. ResultT a m x -> Sh (ShM (ResultT a m) x)) -> Sh a
f =
    m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a a) -> ResultT a m a)
-> m (Result a a) -> ResultT a m a
forall a b. (a -> b) -> a -> b
$
      (a -> Result a a) -> m a -> m (Result a a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Result a a
forall a. a -> Result a a
forall (m :: * -> *) a. Monad m => a -> m a
return (m a -> m (Result a a)) -> m a -> m (Result a a)
forall a b. (a -> b) -> a -> b
$
        ((forall x. m x -> Sh (ShM m x)) -> Sh a) -> m a
forall a. ((forall x. m x -> Sh (ShM m x)) -> Sh a) -> m a
forall (m :: * -> *) a.
MonadShControl m =>
((forall x. m x -> Sh (ShM m x)) -> Sh a) -> m a
liftShWith (((forall x. m x -> Sh (ShM m x)) -> Sh a) -> m a)
-> ((forall x. m x -> Sh (ShM m x)) -> Sh a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall x. m x -> Sh (ShM m x)
runInSh -> (forall x. ResultT a m x -> Sh (ShM (ResultT a m) x)) -> Sh a
f ((forall x. ResultT a m x -> Sh (ShM (ResultT a m) x)) -> Sh a)
-> (forall x. ResultT a m x -> Sh (ShM (ResultT a m) x)) -> Sh a
forall a b. (a -> b) -> a -> b
$ \ResultT a m x
k ->
          (ShM m (Result a x) -> ShM (ResultT a m) x)
-> Sh (ShM m (Result a x)) -> Sh (ShM (ResultT a m) x)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ShM m (Result a x) -> ShM (ResultT a m) x
forall a (m :: * -> *) b. ShM m (Result a b) -> ShM (ResultT a m) b
ResultTShM (Sh (ShM m (Result a x)) -> Sh (ShM (ResultT a m) x))
-> Sh (ShM m (Result a x)) -> Sh (ShM (ResultT a m) x)
forall a b. (a -> b) -> a -> b
$ m (Result a x) -> Sh (ShM m (Result a x))
forall x. m x -> Sh (ShM m x)
runInSh (m (Result a x) -> Sh (ShM m (Result a x)))
-> m (Result a x) -> Sh (ShM m (Result a x))
forall a b. (a -> b) -> a -> b
$ ResultT a m x -> m (Result a x)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT ResultT a m x
k
  restoreSh :: forall a. ShM (ResultT a m) a -> ResultT a m a
restoreSh (ResultTShM ShM m (Result a a)
m) = m (Result a a) -> ResultT a m a
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a a) -> ResultT a m a)
-> (ShM m (Result a a) -> m (Result a a))
-> ShM m (Result a a)
-> ResultT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShM m (Result a a) -> m (Result a a)
forall a. ShM m a -> m a
forall (m :: * -> *) a. MonadShControl m => ShM m a -> m a
restoreSh (ShM m (Result a a) -> ResultT a m a)
-> ShM m (Result a a) -> ResultT a m a
forall a b. (a -> b) -> a -> b
$ ShM m (Result a a)
m
  {-# INLINE liftShWith #-}
  {-# INLINE restoreSh #-}

infix 0 <?>

(<?>) :: (Monad m, Monoid a) => ResultT a m b -> a -> ResultT a m b
ResultT a m b
m <?> :: forall (m :: * -> *) a b.
(Monad m, Monoid a) =>
ResultT a m b -> a -> ResultT a m b
<?> a
b = m (Result a b) -> ResultT a m b
forall a (m :: * -> *) b. m (Result a b) -> ResultT a m b
ResultT (m (Result a b) -> ResultT a m b)
-> m (Result a b) -> ResultT a m b
forall a b. (a -> b) -> a -> b
$ do
  Result a b
a <- ResultT a m b -> m (Result a b)
forall a (m :: * -> *) b. ResultT a m b -> m (Result a b)
runResultT ResultT a m b
m
  case Result a b
a of
    Pass b
a' -> Result a b -> m (Result a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a b -> m (Result a b)) -> Result a b -> m (Result a b)
forall a b. (a -> b) -> a -> b
$ b -> Result a b
forall a b. b -> Result a b
Pass b
a'
    Fail a
a' -> Result a b -> m (Result a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a b -> m (Result a b))
-> (a -> Result a b) -> a -> m (Result a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result a b
forall a b. a -> Result a b
Fail (a -> m (Result a b)) -> a -> m (Result a b)
forall a b. (a -> b) -> a -> b
$ a
a' a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b

annotate :: (Monad m, Monoid a) => a -> ResultT a m b -> ResultT a m b
annotate :: forall (m :: * -> *) a b.
(Monad m, Monoid a) =>
a -> ResultT a m b -> ResultT a m b
annotate = (ResultT a m b -> a -> ResultT a m b)
-> a -> ResultT a m b -> ResultT a m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResultT a m b -> a -> ResultT a m b
forall (m :: * -> *) a b.
(Monad m, Monoid a) =>
ResultT a m b -> a -> ResultT a m b
(<?>)