{-|
Module      : Control.Applicative.MultiExcept
Copyright   : (c) Owen Shepherd, 2021
License     : MIT
Maintainer  : owen@owen.cafe
Stability   : stable
Portability : portable
-}

{-# LANGUAGE ScopedTypeVariables #-}

module Control.Applicative.MultiExcept
  ( MultiExcept
  , fromEither
  , fromEitherPoly
  , join
  , runMultiExcept
  , succeed
  , throwError
  , throwErrors
  ) where

import Data.Bifunctor
import Data.Functor.Alt
import Data.DList.NonEmpty (NonEmptyDList)

-- | A 'MultiExcept' is a success value, or one or more errors.
data MultiExcept err a
  = Success a
  | Errors (NonEmptyDList err)
  deriving (MultiExcept err a -> MultiExcept err a -> Bool
(MultiExcept err a -> MultiExcept err a -> Bool)
-> (MultiExcept err a -> MultiExcept err a -> Bool)
-> Eq (MultiExcept err a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall err a.
(Eq a, Eq err) =>
MultiExcept err a -> MultiExcept err a -> Bool
/= :: MultiExcept err a -> MultiExcept err a -> Bool
$c/= :: forall err a.
(Eq a, Eq err) =>
MultiExcept err a -> MultiExcept err a -> Bool
== :: MultiExcept err a -> MultiExcept err a -> Bool
$c== :: forall err a.
(Eq a, Eq err) =>
MultiExcept err a -> MultiExcept err a -> Bool
Eq, Eq (MultiExcept err a)
Eq (MultiExcept err a) =>
(MultiExcept err a -> MultiExcept err a -> Ordering)
-> (MultiExcept err a -> MultiExcept err a -> Bool)
-> (MultiExcept err a -> MultiExcept err a -> Bool)
-> (MultiExcept err a -> MultiExcept err a -> Bool)
-> (MultiExcept err a -> MultiExcept err a -> Bool)
-> (MultiExcept err a -> MultiExcept err a -> MultiExcept err a)
-> (MultiExcept err a -> MultiExcept err a -> MultiExcept err a)
-> Ord (MultiExcept err a)
MultiExcept err a -> MultiExcept err a -> Bool
MultiExcept err a -> MultiExcept err a -> Ordering
MultiExcept err a -> MultiExcept err a -> MultiExcept err a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall err a. (Ord a, Ord err) => Eq (MultiExcept err a)
forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Bool
forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Ordering
forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> MultiExcept err a
min :: MultiExcept err a -> MultiExcept err a -> MultiExcept err a
$cmin :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> MultiExcept err a
max :: MultiExcept err a -> MultiExcept err a -> MultiExcept err a
$cmax :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> MultiExcept err a
>= :: MultiExcept err a -> MultiExcept err a -> Bool
$c>= :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Bool
> :: MultiExcept err a -> MultiExcept err a -> Bool
$c> :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Bool
<= :: MultiExcept err a -> MultiExcept err a -> Bool
$c<= :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Bool
< :: MultiExcept err a -> MultiExcept err a -> Bool
$c< :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Bool
compare :: MultiExcept err a -> MultiExcept err a -> Ordering
$ccompare :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Ordering
$cp1Ord :: forall err a. (Ord a, Ord err) => Eq (MultiExcept err a)
Ord, ReadPrec [MultiExcept err a]
ReadPrec (MultiExcept err a)
Int -> ReadS (MultiExcept err a)
ReadS [MultiExcept err a]
(Int -> ReadS (MultiExcept err a))
-> ReadS [MultiExcept err a]
-> ReadPrec (MultiExcept err a)
-> ReadPrec [MultiExcept err a]
-> Read (MultiExcept err a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall err a. (Read a, Read err) => ReadPrec [MultiExcept err a]
forall err a. (Read a, Read err) => ReadPrec (MultiExcept err a)
forall err a.
(Read a, Read err) =>
Int -> ReadS (MultiExcept err a)
forall err a. (Read a, Read err) => ReadS [MultiExcept err a]
readListPrec :: ReadPrec [MultiExcept err a]
$creadListPrec :: forall err a. (Read a, Read err) => ReadPrec [MultiExcept err a]
readPrec :: ReadPrec (MultiExcept err a)
$creadPrec :: forall err a. (Read a, Read err) => ReadPrec (MultiExcept err a)
readList :: ReadS [MultiExcept err a]
$creadList :: forall err a. (Read a, Read err) => ReadS [MultiExcept err a]
readsPrec :: Int -> ReadS (MultiExcept err a)
$creadsPrec :: forall err a.
(Read a, Read err) =>
Int -> ReadS (MultiExcept err a)
Read, Int -> MultiExcept err a -> ShowS
[MultiExcept err a] -> ShowS
MultiExcept err a -> String
(Int -> MultiExcept err a -> ShowS)
-> (MultiExcept err a -> String)
-> ([MultiExcept err a] -> ShowS)
-> Show (MultiExcept err a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall err a.
(Show a, Show err) =>
Int -> MultiExcept err a -> ShowS
forall err a. (Show a, Show err) => [MultiExcept err a] -> ShowS
forall err a. (Show a, Show err) => MultiExcept err a -> String
showList :: [MultiExcept err a] -> ShowS
$cshowList :: forall err a. (Show a, Show err) => [MultiExcept err a] -> ShowS
show :: MultiExcept err a -> String
$cshow :: forall err a. (Show a, Show err) => MultiExcept err a -> String
showsPrec :: Int -> MultiExcept err a -> ShowS
$cshowsPrec :: forall err a.
(Show a, Show err) =>
Int -> MultiExcept err a -> ShowS
Show)

-- | Run the computation.
runMultiExcept :: MultiExcept err a -> Either (NonEmptyDList err) a
runMultiExcept :: MultiExcept err a -> Either (NonEmptyDList err) a
runMultiExcept (Errors errs :: NonEmptyDList err
errs) = NonEmptyDList err -> Either (NonEmptyDList err) a
forall a b. a -> Either a b
Left NonEmptyDList err
errs
runMultiExcept (Success a :: a
a) = a -> Either (NonEmptyDList err) a
forall a b. b -> Either a b
Right a
a

-- | Throw a single error.
throwError :: forall a err. err -> MultiExcept err a
throwError :: err -> MultiExcept err a
throwError = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList err -> MultiExcept err a)
-> (err -> NonEmptyDList err) -> err -> MultiExcept err a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> NonEmptyDList err
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Throw one or more errors.
throwErrors :: forall a err. NonEmptyDList err -> MultiExcept err a
throwErrors :: NonEmptyDList err -> MultiExcept err a
throwErrors = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors

-- | Embeds a value into a 'MultiExcept' context.
succeed :: forall err a. a -> MultiExcept err a
succeed :: a -> MultiExcept err a
succeed = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success

-- | Convert an 'Either' to a 'MultiExcept'.
fromEither :: Either err a -> MultiExcept err a
fromEither :: Either err a -> MultiExcept err a
fromEither (Left err :: err
err) = err -> MultiExcept err a
forall a err. err -> MultiExcept err a
throwError err
err
fromEither (Right a :: a
a) = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a

-- | Convert a multi-error 'Either' to a 'MultiExcept'.
fromEitherPoly :: Either (NonEmptyDList err) a -> MultiExcept err a
fromEitherPoly :: Either (NonEmptyDList err) a -> MultiExcept err a
fromEitherPoly (Left errs :: NonEmptyDList err
errs) = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
errs
fromEitherPoly (Right a :: a
a) = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a

-- | Join nested 'MultiExcept's with the same error type.
--   Note that this doesn't imply a __useful__ 'Monad' instance.
--   The instance defined in terms of join discards errors on the RHS of '>>='.
join :: MultiExcept err (MultiExcept err a) -> MultiExcept err a
join :: MultiExcept err (MultiExcept err a) -> MultiExcept err a
join (Success a :: MultiExcept err a
a) = MultiExcept err a
a
join (Errors a :: NonEmptyDList err
a) = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
a

instance Functor (MultiExcept err) where
  fmap :: (a -> b) -> MultiExcept err a -> MultiExcept err b
fmap f :: a -> b
f (Success a :: a
a) = b -> MultiExcept err b
forall err a. a -> MultiExcept err a
Success (b -> MultiExcept err b) -> b -> MultiExcept err b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  fmap _ (Errors errs :: NonEmptyDList err
errs) = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
errs

instance Bifunctor MultiExcept where
 bimap :: (a -> b) -> (c -> d) -> MultiExcept a c -> MultiExcept b d
bimap _ fa :: c -> d
fa (Success a :: c
a)    = d -> MultiExcept b d
forall err a. a -> MultiExcept err a
Success (d -> MultiExcept b d) -> d -> MultiExcept b d
forall a b. (a -> b) -> a -> b
$ c -> d
fa c
a
 bimap ferr :: a -> b
ferr _ (Errors err :: NonEmptyDList a
err) = NonEmptyDList b -> MultiExcept b d
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList b -> MultiExcept b d)
-> NonEmptyDList b -> MultiExcept b d
forall a b. (a -> b) -> a -> b
$ (a -> b) -> NonEmptyDList a -> NonEmptyDList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ferr NonEmptyDList a
err

instance Applicative (MultiExcept err) where
  pure :: a -> MultiExcept err a
pure = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success

  Errors l :: NonEmptyDList err
l <*> :: MultiExcept err (a -> b) -> MultiExcept err a -> MultiExcept err b
<*> Errors l' :: NonEmptyDList err
l' = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList err -> MultiExcept err b)
-> NonEmptyDList err -> MultiExcept err b
forall a b. (a -> b) -> a -> b
$ NonEmptyDList err
l NonEmptyDList err -> NonEmptyDList err -> NonEmptyDList err
forall a. Semigroup a => a -> a -> a
<> NonEmptyDList err
l'
  Success f :: a -> b
f <*> Success a :: a
a = b -> MultiExcept err b
forall err a. a -> MultiExcept err a
Success (b -> MultiExcept err b) -> b -> MultiExcept err b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
  Errors l :: NonEmptyDList err
l <*> _ = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
l
  _ <*> Errors l :: NonEmptyDList err
l = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
l

instance Alt (MultiExcept err) where
  Success a :: a
a <!> :: MultiExcept err a -> MultiExcept err a -> MultiExcept err a
<!> _ = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a
  _ <!> Success a :: a
a = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a
  Errors l :: NonEmptyDList err
l <!> Errors r :: NonEmptyDList err
r = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList err
l NonEmptyDList err -> NonEmptyDList err -> NonEmptyDList err
forall a. Semigroup a => a -> a -> a
<> NonEmptyDList err
r)

instance Foldable (MultiExcept err) where
  foldr :: (a -> b -> b) -> b -> MultiExcept err a -> b
foldr f :: a -> b -> b
f acc :: b
acc (Success a :: a
a) = a -> b -> b
f a
a b
acc
  foldr _ acc :: b
acc _           = b
acc

instance Traversable (MultiExcept err) where
  traverse :: (a -> f b) -> MultiExcept err a -> f (MultiExcept err b)
traverse f :: a -> f b
f (Success a :: a
a)   = b -> MultiExcept err b
forall err a. a -> MultiExcept err a
Success (b -> MultiExcept err b) -> f b -> f (MultiExcept err b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
  traverse _ (Errors err :: NonEmptyDList err
err) = MultiExcept err b -> f (MultiExcept err b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MultiExcept err b -> f (MultiExcept err b))
-> MultiExcept err b -> f (MultiExcept err b)
forall a b. (a -> b) -> a -> b
$ NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
err