{-# LANGUAGE CPP                #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE PatternSynonyms    #-}
{-# LANGUAGE ViewPatterns       #-}

{-# OPTIONS_GHC -Wno-orphans #-}

{-# OPTIONS_HADDOCK show-extensions #-}

-- | 'T.ResultT' interfaces with 'Result'.
module Control.Monad.Trans.Result
  ( -- * The Result monad
    type T.Result
  , pattern Result
  , runResult
  , pattern Error
  , pattern Success
  , result
  , fromEither
  , toEither
  , fromSuccess
  , toMonadFail
  , mapError
    -- * The ResultT monad transformer
  , type T.ResultT
  , pattern ResultT
  , runResultT
  , mapResultT
  , mapErrorT
    -- * Exception operations
  , T.throwE
  , T.catchE
    -- * Lifting other operations
  , T.liftCallCC
  , T.liftListen
  , T.liftPass
  ) where

import           Control.Monad.Trans.Except        (ExceptT (ExceptT), runExcept, runExceptT)
import qualified Control.Monad.Trans.Except.Result as T
import           Data.Functor.Identity             (Identity (runIdentity))
import qualified GHC.Show                          as S
import qualified Text.Read                         as R
import           Text.Read                         (Read (readPrec))
import qualified Text.Read.Lex                     as R

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif

instance {-# OVERLAPPING #-} Show a => Show (T.Result a) where
  showsPrec :: Int -> Result a -> ShowS
showsPrec Int
d (Error String
e)   = Bool -> ShowS -> ShowS
showParen (Int
S.appPrec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
d) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Error " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
S.appPrec1 String
e
  showsPrec Int
d (Success a
a) = Bool -> ShowS -> ShowS
showParen (Int
S.appPrec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
d) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"Success " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
S.appPrec1 a
a

instance {-# OVERLAPPING #-} Read a => Read (T.Result a) where
  readPrec :: ReadPrec (Result a)
readPrec =
    ReadPrec (Result a) -> ReadPrec (Result a)
forall a. ReadPrec a -> ReadPrec a
R.parens (ReadPrec (Result a) -> ReadPrec (Result a))
-> ReadPrec (Result a) -> ReadPrec (Result a)
forall a b. (a -> b) -> a -> b
$
      Int -> ReadPrec (Result a) -> ReadPrec (Result a)
forall a. Int -> ReadPrec a -> ReadPrec a
R.prec Int
S.appPrec (
        do
          ReadP () -> ReadPrec ()
forall a. ReadP a -> ReadPrec a
R.lift (ReadP () -> ReadPrec ()) -> ReadP () -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> ReadP ()
R.expect (Lexeme -> ReadP ()) -> Lexeme -> ReadP ()
forall a b. (a -> b) -> a -> b
$ String -> Lexeme
R.Ident String
"Error"
          String
e <- ReadPrec String -> ReadPrec String
forall a. ReadPrec a -> ReadPrec a
R.step ReadPrec String
forall a. Read a => ReadPrec a
readPrec
          Result a -> ReadPrec (Result a)
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a -> ReadPrec (Result a))
-> Result a -> ReadPrec (Result a)
forall a b. (a -> b) -> a -> b
$ String -> Result a
forall a. String -> Result a
Error String
e
      )
      ReadPrec (Result a) -> ReadPrec (Result a) -> ReadPrec (Result a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
R.+++
      Int -> ReadPrec (Result a) -> ReadPrec (Result a)
forall a. Int -> ReadPrec a -> ReadPrec a
R.prec Int
S.appPrec (
        do
          ReadP () -> ReadPrec ()
forall a. ReadP a -> ReadPrec a
R.lift (ReadP () -> ReadPrec ()) -> ReadP () -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ Lexeme -> ReadP ()
R.expect (Lexeme -> ReadP ()) -> Lexeme -> ReadP ()
forall a b. (a -> b) -> a -> b
$ String -> Lexeme
R.Ident String
"Success"
          a
a <- ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
R.step ReadPrec a
forall a. Read a => ReadPrec a
readPrec
          Result a -> ReadPrec (Result a)
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a -> ReadPrec (Result a))
-> Result a -> ReadPrec (Result a)
forall a b. (a -> b) -> a -> b
$ a -> Result a
forall a. a -> Result a
Success a
a
      )

instance Semigroup (T.Result a) where
  Error String
_ <> :: Result a -> Result a -> Result a
<> Result a
a = Result a
a
  Result a
a <> Result a
_       = Result a
a
  {-# INLINE (<>) #-}

instance Monoid (T.Result a) where
  mempty :: Result a
mempty = String -> Result a
forall a. String -> Result a
Error String
"mempty"
  {-# INLINE mempty #-}

  mappend :: Result a -> Result a -> Result a
mappend = Result a -> Result a -> Result a
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE mappend #-}

-- | Wrap @'D.Result' a@.
pattern Result :: Either String a -> T.Result a
pattern $mResult :: forall {r} {a}.
Result a -> (Either String a -> r) -> ((# #) -> r) -> r
$bResult :: forall a. Either String a -> Result a
Result r <- (runIdentity . runExceptT . T.runResultT -> r)
  where Result Either String a
r = ExceptT String Identity a -> ResultT Identity a
forall (m :: * -> *) a. ExceptT String m a -> ResultT m a
T.ResultT (ExceptT String Identity a -> ResultT Identity a)
-> ExceptT String Identity a -> ResultT Identity a
forall a b. (a -> b) -> a -> b
$ Identity (Either String a) -> ExceptT String Identity a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (Identity (Either String a) -> ExceptT String Identity a)
-> Identity (Either String a) -> ExceptT String Identity a
forall a b. (a -> b) -> a -> b
$ Either String a -> Identity (Either String a)
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String a
r

{-# COMPLETE Result #-}

-- | Unwrap @'T.Result' a@.
runResult :: T.Result a -> Either String a
runResult :: forall a. Result a -> Either String a
runResult = Except String a -> Either String a
forall e a. Except e a -> Either e a
runExcept (Except String a -> Either String a)
-> (Result a -> Except String a) -> Result a -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result a -> Except String a
forall a. Result a -> Except String a
T.runResult
{-# INLINE runResult #-}

-- | 'Error' means errors and failures etc.
pattern Error :: String -> T.Result a
pattern $mError :: forall {r} {a}. Result a -> (String -> r) -> ((# #) -> r) -> r
$bError :: forall a. String -> Result a
Error e = Result (Left e)

-- | 'Success' means successes and OKs etc.
pattern Success :: a -> T.Result a
pattern $mSuccess :: forall {r} {a}. Result a -> (a -> r) -> ((# #) -> r) -> r
$bSuccess :: forall a. a -> Result a
Success a = Result (Right a)

{-# COMPLETE Error, Success #-}

-- | Case analysis for the 'Result' type.
--
-- ==== __Examples__
--
-- >>> let s = Success 0
-- >>> let e = Error "critical"
-- >>> result ("Bad: " ++) (("OK: " ++) . show) s
-- "OK: 0"
-- >>> result ("Bad: " ++) (("OK: " ++) . show) e
-- "Bad: critical"
result :: (String -> b) -> (a -> b) -> T.Result a -> b
result :: forall b a. (String -> b) -> (a -> b) -> Result a -> b
result String -> b
f a -> b
_ (Error String
e)   = String -> b
f String
e
result String -> b
_ a -> b
g (Success a
a) = a -> b
g a
a
{-# INLINE result #-}

-- | Convert @'Either' 'String' a@ to @'Result' a@.
fromEither :: Either String a -> T.Result a
fromEither :: forall a. Either String a -> Result a
fromEither = Either String a -> Result a
forall a. Either String a -> Result a
Result
{-# INLINE fromEither #-}

-- | Convert @'Result' a@ to @'Either' 'String' a@.
toEither :: T.Result a -> Either String a
toEither :: forall a. Result a -> Either String a
toEither = Result a -> Either String a
forall a. Result a -> Either String a
runResult
{-# INLINE toEither #-}

-- | Convert @'Result' a@ to @a@ with a default value.
fromSuccess :: a -> T.Result a -> a
fromSuccess :: forall a. a -> Result a -> a
fromSuccess a
_ (Success a
a) = a
a
fromSuccess a
a Result a
_           = a
a
{-# INLINE fromSuccess #-}

-- | Convert @'Result' a@ to @'MonadFail' m => m a@.
toMonadFail :: MonadFail m => T.Result a -> m a
toMonadFail :: forall (m :: * -> *) a. MonadFail m => Result a -> m a
toMonadFail (Success a
a) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
toMonadFail (Error String
e)   = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
e
{-# INLINE toMonadFail #-}

-- | Map the error in 'T.Result'.
mapError :: (String -> String) -> T.Result a -> T.Result a
mapError :: forall a. ShowS -> Result a -> Result a
mapError = ShowS -> ResultT Identity a -> ResultT Identity a
forall (m :: * -> *) a.
Functor m =>
ShowS -> ResultT m a -> ResultT m a
mapErrorT
{-# INLINE mapError #-}

-- | Construct and destruct 'T.Result'.
pattern ResultT :: Functor m => m (T.Result a) -> T.ResultT m a
pattern $mResultT :: forall {r} {m :: * -> *} {a}.
Functor m =>
ResultT m a -> (m (Result a) -> r) -> ((# #) -> r) -> r
$bResultT :: forall (m :: * -> *) a. Functor m => m (Result a) -> ResultT m a
ResultT m <- ((Result <$>) . runExceptT . T.runResultT -> m)
  where ResultT m (Result a)
m = ExceptT String m a -> ResultT m a
forall (m :: * -> *) a. ExceptT String m a -> ResultT m a
T.ResultT (ExceptT String m a -> ResultT m a)
-> ExceptT String m a -> ResultT m a
forall a b. (a -> b) -> a -> b
$ m (Either String a) -> ExceptT String m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String a) -> ExceptT String m a)
-> m (Either String a) -> ExceptT String m a
forall a b. (a -> b) -> a -> b
$ Result a -> Either String a
forall a. Result a -> Either String a
runResult (Result a -> Either String a)
-> m (Result a) -> m (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Result a)
m

{-# COMPLETE ResultT #-}

-- | Unwrap 'ResultT'.
runResultT :: Functor m => T.ResultT m a -> m (T.Result a)
runResultT :: forall (m :: * -> *) a. Functor m => ResultT m a -> m (Result a)
runResultT (ResultT m (Result a)
m) = m (Result a)
m
{-# INLINE runResultT #-}

-- | Map the unwrapped computation using the given function.
mapResultT :: (Functor m, Functor n) => (m (T.Result a) -> n (T.Result b)) -> T.ResultT m a -> T.ResultT n b
mapResultT :: forall (m :: * -> *) (n :: * -> *) a b.
(Functor m, Functor n) =>
(m (Result a) -> n (Result b)) -> ResultT m a -> ResultT n b
mapResultT m (Result a) -> n (Result b)
f = (ExceptT String m a -> ExceptT String n b)
-> ResultT m a -> ResultT n b
forall (m :: * -> *) a (n :: * -> *) b.
(ExceptT String m a -> ExceptT String n b)
-> ResultT m a -> ResultT n b
T.mapResultT ((ExceptT String m a -> ExceptT String n b)
 -> ResultT m a -> ResultT n b)
-> (ExceptT String m a -> ExceptT String n b)
-> ResultT m a
-> ResultT n b
forall a b. (a -> b) -> a -> b
$ ResultT n b -> ExceptT String n b
forall (m :: * -> *) a. ResultT m a -> ExceptT String m a
T.runResultT (ResultT n b -> ExceptT String n b)
-> (ExceptT String m a -> ResultT n b)
-> ExceptT String m a
-> ExceptT String n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n (Result b) -> ResultT n b
forall (m :: * -> *) a. Functor m => m (Result a) -> ResultT m a
ResultT (n (Result b) -> ResultT n b)
-> (ExceptT String m a -> n (Result b))
-> ExceptT String m a
-> ResultT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Result a) -> n (Result b)
f (m (Result a) -> n (Result b))
-> (ExceptT String m a -> m (Result a))
-> ExceptT String m a
-> n (Result b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultT m a -> m (Result a)
forall (m :: * -> *) a. Functor m => ResultT m a -> m (Result a)
runResultT (ResultT m a -> m (Result a))
-> (ExceptT String m a -> ResultT m a)
-> ExceptT String m a
-> m (Result a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String m a -> ResultT m a
forall (m :: * -> *) a. ExceptT String m a -> ResultT m a
T.ResultT
{-# INLINE mapResultT #-}

-- | Map the error in 'T.ResultT'.
mapErrorT :: Functor m => (String -> String) -> T.ResultT m a -> T.ResultT m a
mapErrorT :: forall (m :: * -> *) a.
Functor m =>
ShowS -> ResultT m a -> ResultT m a
mapErrorT ShowS
f =
  (m (Result a) -> m (Result a)) -> ResultT m a -> ResultT m a
forall (m :: * -> *) (n :: * -> *) a b.
(Functor m, Functor n) =>
(m (Result a) -> n (Result b)) -> ResultT m a -> ResultT n b
mapResultT ((m (Result a) -> m (Result a)) -> ResultT m a -> ResultT m a)
-> (m (Result a) -> m (Result a)) -> ResultT m a -> ResultT m a
forall a b. (a -> b) -> a -> b
$ (Result a -> Result a) -> m (Result a) -> m (Result a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result a -> Result a
forall {a}. Result a -> Result a
go
  where
    go :: Result a -> Result a
go (Error String
e) = String -> Result a
forall a. String -> Result a
Error (String -> Result a) -> String -> Result a
forall a b. (a -> b) -> a -> b
$ ShowS
f String
e
    go Result a
a         = Result a
a
{-# INLINE mapErrorT #-}