{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
module Schemas.Attempt where
import Control.Applicative
import Data.Functor.Classes
import Control.Monad.Except
import Data.Maybe
data Attempt e a
= Success a
| Failure e
deriving (Eq, Functor, Foldable, Traversable, Show)
instance Eq e => Eq1 (Attempt e) where
liftEq _ (Failure e) (Failure e') = e == e'
liftEq eq0 (Success a) (Success a') = eq0 a a'
liftEq _ _ _ = False
instance Show e => Show1 (Attempt e) where
liftShowsPrec _ _ p (Failure e) = showsPrec p e
liftShowsPrec shows0 _ _ (Success a) = shows "Success " . shows0 0 a
instance Monoid e => Applicative (Attempt e) where
pure = Success
Success f <*> Success a = Success (f a)
Failure e <*> Failure e' = Failure (e <> e')
Failure e <*> _ = Failure e
_ <*> Failure e = Failure e
instance Monoid e => Alternative (Attempt e) where
empty = Failure mempty
Success a <|> _ = Success a
_ <|> Success b = Success b
Failure e <|> Failure e' = Failure (e <> e')
instance Monoid e => Monad (Attempt e) where
return = pure
Success a >>= k = k a
Failure e >>= _ = Failure e
instance Monoid e => MonadPlus (Attempt e)
instance Monoid e => MonadError e (Attempt e) where
throwError = Failure
catchError (Failure e) h = h e
catchError (Success a) _ = Success a
bindAttempt :: Attempt e a -> (a -> Attempt e b) -> Attempt e b
bindAttempt (Success a) k = k a
bindAttempt (Failure e) _ = Failure e
runAttempt :: Attempt e a -> Either e a
runAttempt = execAttempt
execAttempt :: MonadError e f => Attempt e a -> f a
execAttempt (Success x) = pure x
execAttempt (Failure e) = throwError e
partitionAttempts :: [Attempt e a] -> ([e], [a])
partitionAttempts xx = (mapMaybe attemptFailure xx, mapMaybe attemptSuccess xx)
attemptFailure :: Attempt a1 a2 -> Maybe a1
attemptFailure Success{} = Nothing
attemptFailure (Failure e) = Just e
attemptSuccess :: Attempt e a -> Maybe a
attemptSuccess (Success a) = Just a
attemptSuccess Failure{} = Nothing
isSuccess :: Attempt e a -> Bool
isSuccess Success{} = True
isSuccess _ = False
isFailure :: Attempt e a -> Bool
isFailure Failure{} = True
isFailure _ = False