{-# LANGUAGE CPP #-}

#define HAVE_MONAD_FAIL MIN_VERSION_base(4,9,0)

module Text.XML.Light.Extractors.Internal.Result 
 ( Result(..)
 , toEither
 , escalate

 , ResultT
 , runResultT
 , throwError
 , throwFatal
 , mapResult

 , module Control.Monad.Trans.Error
 , Control.Monad.Trans.Class.lift
 )
where


import Control.Applicative
#if HAVE_MONAD_FAIL
import qualified Control.Monad.Fail as Fail
#endif
import Control.Monad
import Control.Monad.Trans.Error (Error, noMsg, strMsg)
import Control.Monad.Trans.Class


-- | 'Result' is like 'Either' but with two error states, 'Fail' and 'Fatal'.
--
-- 'Fail' is precisely analogous to 'Left' while 'Fatal' has short cut
-- semantics for 'Alternative'.
--
-- The idea is that 'Fatal' errors cannot be circumvented by '<|>' etc.
data Result e a = Fatal e
                | Fail e
                | Ok a
  deriving Int -> Result e a -> ShowS
[Result e a] -> ShowS
Result e a -> String
(Int -> Result e a -> ShowS)
-> (Result e a -> String)
-> ([Result e a] -> ShowS)
-> Show (Result e a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e a. (Show e, Show a) => Int -> Result e a -> ShowS
forall e a. (Show e, Show a) => [Result e a] -> ShowS
forall e a. (Show e, Show a) => Result e a -> String
showList :: [Result e a] -> ShowS
$cshowList :: forall e a. (Show e, Show a) => [Result e a] -> ShowS
show :: Result e a -> String
$cshow :: forall e a. (Show e, Show a) => Result e a -> String
showsPrec :: Int -> Result e a -> ShowS
$cshowsPrec :: forall e a. (Show e, Show a) => Int -> Result e a -> ShowS
Show


instance Functor (Result e) where
  fmap :: (a -> b) -> Result e a -> Result e b
fmap a -> b
f (Ok a
a)    = b -> Result e b
forall e a. a -> Result e a
Ok (a -> b
f a
a)
  fmap a -> b
_ (Fail e
e)  = e -> Result e b
forall e a. e -> Result e a
Fail e
e
  fmap a -> b
_ (Fatal e
e) = e -> Result e b
forall e a. e -> Result e a
Fatal e
e


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


instance Error e => Alternative (Result e) where
  empty :: Result e a
empty = e -> Result e a
forall e a. e -> Result e a
Fail e
forall a. Error a => a
noMsg

  Fatal e
e <|> :: Result e a -> Result e a -> Result e a
<|> Result e a
_ = e -> Result e a
forall e a. e -> Result e a
Fatal e
e
  Fail e
_  <|> Result e a
x = Result e a
x
  Result e a
m       <|> Result e a
_ = Result e a
m


instance Monad (Result e) where
  return :: a -> Result e a
return = a -> Result e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  Fatal e
e >>= :: Result e a -> (a -> Result e b) -> Result e b
>>= a -> Result e b
_ = e -> Result e b
forall e a. e -> Result e a
Fatal e
e
  Fail e
e  >>= a -> Result e b
_ = e -> Result e b
forall e a. e -> Result e a
Fail e
e
  Ok a
a    >>= a -> Result e b
k = a -> Result e b
k a
a


-- | Maps 'Fail' to 'Fatal'.
escalate :: Result e a -> Result e a
escalate :: Result e a -> Result e a
escalate (Fail e
e) = e -> Result e a
forall e a. e -> Result e a
Fatal e
e
escalate Result e a
x        = Result e a
x


-- | Maps 'Fail' and 'Fatal' to 'Left'.
toEither :: Result a b -> Either a b
toEither :: Result a b -> Either a b
toEither (Fatal a
e) = a -> Either a b
forall a b. a -> Either a b
Left a
e
toEither (Fail a
e)  = a -> Either a b
forall a b. a -> Either a b
Left a
e
toEither (Ok b
a)    = b -> Either a b
forall a b. b -> Either a b
Right b
a

--------------------------------------------------------------------------------

newtype ResultT e m a = ResultT { ResultT e m a -> m (Result e a)
runResultT :: m (Result e a) }


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


instance (Functor m, Monad m) => Applicative (ResultT e m) where
  pure :: a -> ResultT e m a
pure a
a = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> m (Result e a) -> ResultT e m a
forall a b. (a -> b) -> a -> b
$ Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result e a
forall e a. a -> Result e a
Ok a
a)

  ResultT e m (a -> b)
f <*> :: ResultT e m (a -> b) -> ResultT e m a -> ResultT e m b
<*> ResultT e m a
v = m (Result e b) -> ResultT e m b
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e b) -> ResultT e m b)
-> m (Result e b) -> ResultT e m b
forall a b. (a -> b) -> a -> b
$ do
              Result e (a -> b)
mf <- ResultT e m (a -> b) -> m (Result e (a -> b))
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT ResultT e m (a -> b)
f
              case Result e (a -> b)
mf of
                Fatal e
e -> Result e b -> m (Result e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Result e b
forall e a. e -> Result e a
Fatal e
e)
                Fail  e
e -> Result e b -> m (Result e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Result e b
forall e a. e -> Result e a
Fail e
e)
                Ok   a -> b
f' -> do
                   Result e a
mv <- ResultT e m a -> m (Result e a)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT ResultT e m a
v
                   Result e b -> m (Result e b)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a -> b) -> Result e a -> Result e b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f' Result e a
mv)


instance (Error e, Monad m) => MonadPlus (ResultT e m) where
  mzero :: ResultT e m a
mzero = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> (Result e a -> m (Result e a)) -> Result e a -> ResultT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result e a -> ResultT e m a) -> Result e a -> ResultT e m a
forall a b. (a -> b) -> a -> b
$ e -> Result e a
forall e a. e -> Result e a
Fail e
forall a. Error a => a
noMsg
  
  mplus :: ResultT e m a -> ResultT e m a -> ResultT e m a
mplus ResultT e m a
x ResultT e m a
y = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> m (Result e a) -> ResultT e m a
forall a b. (a -> b) -> a -> b
$ do
                Result e a
l <- ResultT e m a -> m (Result e a)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT ResultT e m a
x
                case Result e a
l of
                  Fatal e
e -> Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Result e a
forall e a. e -> Result e a
Fatal e
e)
                  Fail  e
_ -> ResultT e m a -> m (Result e a)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT ResultT e m a
y
                  Ok    a
a -> Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Result e a
forall e a. a -> Result e a
Ok a
a)


instance (Monad m, Error e) => Monad (ResultT e m) where
  return :: a -> ResultT e m a
return = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> (a -> m (Result e a)) -> a -> ResultT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result e a -> m (Result e a))
-> (a -> Result e a) -> a -> m (Result e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Result e a
forall e a. a -> Result e a
Ok

  ResultT e m a
m >>= :: ResultT e m a -> (a -> ResultT e m b) -> ResultT e m b
>>= a -> ResultT e m b
k = m (Result e b) -> ResultT e m b
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e b) -> ResultT e m b)
-> m (Result e b) -> ResultT e m b
forall a b. (a -> b) -> a -> b
$ do
              Result e a
r <- ResultT e m a -> m (Result e a)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT ResultT e m a
m
              case Result e a
r of
                Fatal e
e -> Result e b -> m (Result e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Result e b
forall e a. e -> Result e a
Fatal e
e)
                Fail  e
e -> Result e b -> m (Result e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Result e b
forall e a. e -> Result e a
Fail e
e)
                Ok    a
a -> ResultT e m b -> m (Result e b)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT (a -> ResultT e m b
k a
a)

#if HAVE_MONAD_FAIL
instance (Monad m, Error e) => Fail.MonadFail (ResultT e m) where
  fail :: String -> ResultT e m a
fail = e -> ResultT e m a
forall e (m :: * -> *) a. (Error e, Monad m) => e -> ResultT e m a
throwError (e -> ResultT e m a) -> (String -> e) -> String -> ResultT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> e
forall a. Error a => String -> a
strMsg
#else
  fail = throwError . strMsg
#endif

instance (Functor m, Monad m, Error e) => Alternative (ResultT e m) where
  empty :: ResultT e m a
empty = ResultT e m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: ResultT e m a -> ResultT e m a -> ResultT e m a
(<|>) = ResultT e m a -> ResultT e m a -> ResultT e m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus


instance (Error e) => MonadTrans (ResultT e) where
  lift :: m a -> ResultT e m a
lift m a
m = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
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 e a. a -> Result e a
Ok (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


throwError :: (Error e, Monad m) => e -> ResultT e m a
throwError :: e -> ResultT e m a
throwError = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> (e -> m (Result e a)) -> e -> ResultT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result e a -> m (Result e a))
-> (e -> Result e a) -> e -> m (Result e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Result e a
forall e a. e -> Result e a
Fail


throwFatal :: (Error e, Monad m) => e -> ResultT e m a
throwFatal :: e -> ResultT e m a
throwFatal = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> (e -> m (Result e a)) -> e -> ResultT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result e a -> m (Result e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Result e a -> m (Result e a))
-> (e -> Result e a) -> e -> m (Result e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Result e a
forall e a. e -> Result e a
Fatal


mapResult
  :: (Functor m, Monad m) =>
     (Result e1 a1 -> Result e a) -> ResultT e1 m a1 -> ResultT e m a
mapResult :: (Result e1 a1 -> Result e a) -> ResultT e1 m a1 -> ResultT e m a
mapResult Result e1 a1 -> Result e a
f = m (Result e a) -> ResultT e m a
forall e (m :: * -> *) a. m (Result e a) -> ResultT e m a
ResultT (m (Result e a) -> ResultT e m a)
-> (ResultT e1 m a1 -> m (Result e a))
-> ResultT e1 m a1
-> ResultT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result e1 a1 -> Result e a) -> m (Result e1 a1) -> m (Result e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result e1 a1 -> Result e a
f (m (Result e1 a1) -> m (Result e a))
-> (ResultT e1 m a1 -> m (Result e1 a1))
-> ResultT e1 m a1
-> m (Result e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultT e1 m a1 -> m (Result e1 a1)
forall e (m :: * -> *) a. ResultT e m a -> m (Result e a)
runResultT

--------------------------------------------------------------------------------

-- testX :: ResultT String IO Int
-- testX = lift (print "x") >> return 1

-- testY :: ResultT String IO Int
-- testY = lift (print "error") >> throwError "error"

-- testZ :: ResultT String IO Int
-- testZ = lift (print "fatal") >> throwFatal "fatal"

--------------------------------------------------------------------------------