module Success.Impure
(
Success(..),
run,
nothing, failure, success,
)
where
import Prelude
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Error.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Base
import qualified Success.Pure
newtype Success a m b =
Success (m (Success.Pure.Success a b))
deriving (Functor, Foldable, Traversable)
instance Applicative m => Applicative (Success e m) where
pure a =
Success (pure (Success.Pure.success a))
(<*>) (Success m1) (Success m2) =
Success ((liftA2 . liftA2) ($) m1 m2)
instance Applicative m => Alternative (Success e m) where
empty =
Success (pure Success.Pure.nothing)
(<|>) (Success m1) (Success m2) =
Success (liftA2 (<|>) m1 m2)
instance (Applicative m, Monad m) => Monad (Success e m) where
return =
pure
(>>=) m1 m2' =
Success (run m1 >>= m2 . Success.Pure.asEither)
where
m2 =
\case
Left Nothing -> pure Success.Pure.nothing
Left (Just e) -> pure (Success.Pure.failure e)
Right x -> run (m2' x)
instance (Applicative m, Monad m) => MonadPlus (Success e m) where
mzero =
empty
mplus =
(<|>)
instance (Applicative m, Monad m) => MonadError (Maybe a) (Success a m) where
throwError =
Success . return . throwError
catchError (Success m) handler =
Success $ m >>= either (unwrap . handler) (return . Success.Pure.success) . Success.Pure.asEither
where
unwrap (Success m) =
m
instance MonadTrans (Success a) where
lift =
Success . liftM pure
instance (Applicative m, MonadIO m) => MonadIO (Success a m) where
liftIO =
lift . liftIO
instance (Applicative m, MonadBase n m) => MonadBase n (Success a m) where
liftBase =
lift . liftBase
instance MonadTransControl (Success a) where
type StT (Success a) b =
Success.Pure.Success a b
liftWith onUnlift =
lift $ onUnlift $ \(Success impl) -> impl
restoreT =
Success
instance (Applicative m, MonadBaseControl n m) => MonadBaseControl n (Success a m) where
type StM (Success a m) b =
ComposeSt (Success a) m b
liftBaseWith =
defaultLiftBaseWith
restoreM =
defaultRestoreM
run :: Success e m a -> m (Success.Pure.Success e a)
run (Success m) =
m
nothing :: Applicative m => Success e m a
nothing =
Success (pure Success.Pure.nothing)
failure :: Applicative m => e -> Success e m a
failure details =
Success (pure (Success.Pure.failure details))
success :: Applicative m => a -> Success e m a
success value =
Success (pure (Success.Pure.success value))