-- |
-- Module      : Control.Applicative.MultiExcept
-- Copyright   : (c) Owen Shepherd, 2021
-- License     : MIT
-- Maintainer  : owen@owen.cafe
-- Stability   : stable
-- Portability : portable
--
--
-- Usage:
--
-- Errors are accumulated through 'Applicative' sequencing.
-- The recommended way to use 'MultiExcept' is with `ApplicativeDo`:
--
-- @
-- {-# LANGUAGE ApplicativeDo #-}
--
-- import Control.Applicative.MultiExcept
--
-- errors :: MultiExcept String (Int, Int, Int)
-- errors = do
--   a <- throwError "no monad instance"
--   b <- pure 12
--   c <- throwError "i am scared"
--   pure (a, b, c)
-- @
--
--

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import Prelude (Eq(..), Ord(..), Either(..), (.), ($), id, Show(..), (++), uncurry)

import Control.Applicative  (Applicative(..))
#if MIN_VERSION_base(4,8,0)
import Data.Bifunctor
#endif
import Data.Functor         (Functor(..), (<$>))
import Data.Foldable        (Foldable(..))
import Data.Traversable     (Traversable(..))
#if MIN_VERSION_base(4,9,0)
import Data.List.NonEmpty   (NonEmpty(..))
#endif


-- NonEmptyDList

-- | This is written here because:
-- * The version in dlist is currently limited to ghc>=8.0
-- * The version in dlist-nonempty is too heavy on dependencies
-- * We only need a few trivial features anyway

data NonEmptyDList a = NonEmptyDList !a !([a] -> [a])

{-# INLINE nedlSingleton #-}
nedlSingleton :: a -> NonEmptyDList a
nedlSingleton :: forall a. a -> NonEmptyDList a
nedlSingleton a
a = a -> ([a] -> [a]) -> NonEmptyDList a
forall a. a -> ([a] -> [a]) -> NonEmptyDList a
NonEmptyDList a
a [a] -> [a]
forall a. a -> a
id

{-# INLINE runNonEmptyDList #-}
runNonEmptyDList :: NonEmptyDList a -> (a, [a])
runNonEmptyDList :: forall a. NonEmptyDList a -> (a, [a])
runNonEmptyDList (NonEmptyDList a
x [a] -> [a]
xs) = (a
x, [a] -> [a]
xs [])

instance Eq a => Eq (NonEmptyDList a) where
  NonEmptyDList a
x [a] -> [a]
xs == :: NonEmptyDList a -> NonEmptyDList a -> Bool
== NonEmptyDList a
y [a] -> [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
xs [] [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
ys []

instance Ord a => Ord (NonEmptyDList a) where
  NonEmptyDList a
x [a] -> [a]
xs compare :: NonEmptyDList a -> NonEmptyDList a -> Ordering
`compare` NonEmptyDList a
y [a] -> [a]
ys = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
xs []) [a] -> [a] -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
ys [])

instance Show a => Show (NonEmptyDList a) where
  show :: NonEmptyDList a -> String
show NonEmptyDList a
nedl = case NonEmptyDList a -> (a, [a])
forall a. NonEmptyDList a -> (a, [a])
runNonEmptyDList NonEmptyDList a
nedl of
    (a
x, [a]
xs) -> [a] -> String
forall a. Show a => a -> String
show ([a] -> String) -> [a] -> String
forall a b. (a -> b) -> a -> b
$ a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

appendNedl :: NonEmptyDList a -> NonEmptyDList a -> NonEmptyDList a
appendNedl :: forall a. NonEmptyDList a -> NonEmptyDList a -> NonEmptyDList a
appendNedl (NonEmptyDList a
x [a] -> [a]
xs) (NonEmptyDList a
y [a] -> [a]
ys) = a -> ([a] -> [a]) -> NonEmptyDList a
forall a. a -> ([a] -> [a]) -> NonEmptyDList a
NonEmptyDList a
x (([a] -> [a]) -> NonEmptyDList a)
-> ([a] -> [a]) -> NonEmptyDList a
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
xs ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
ys

-- WARNING: O(n) space
-- TODO Make this constant space
instance Functor NonEmptyDList where
  fmap :: forall a b. (a -> b) -> NonEmptyDList a -> NonEmptyDList b
fmap a -> b
f NonEmptyDList a
nedl = case NonEmptyDList a -> (a, [a])
forall a. NonEmptyDList a -> (a, [a])
runNonEmptyDList NonEmptyDList a
nedl of
    (a
x, [a]
xs) -> b -> ([b] -> [b]) -> NonEmptyDList b
forall a. a -> ([a] -> [a]) -> NonEmptyDList a
NonEmptyDList (a -> b
f a
x) ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
xs [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++)

-- | 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
$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
/= :: 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
$ccompare :: forall err a.
(Ord a, Ord err) =>
MultiExcept err a -> MultiExcept err a -> Ordering
compare :: MultiExcept err a -> MultiExcept err a -> Ordering
$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
>= :: MultiExcept err a -> MultiExcept err a -> Bool
$cmax :: 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
$cmin :: 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
Ord, 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
$cshowsPrec :: forall err a.
(Show a, Show err) =>
Int -> MultiExcept err a -> ShowS
showsPrec :: Int -> MultiExcept err a -> ShowS
$cshow :: forall err a. (Show a, Show err) => MultiExcept err a -> String
show :: MultiExcept err a -> String
$cshowList :: forall err a. (Show a, Show err) => [MultiExcept err a] -> ShowS
showList :: [MultiExcept err a] -> ShowS
Show)

#if MIN_VERSION_base(4,9,0)

-- | Run the computation.
runMultiExcept :: MultiExcept err a -> Either (NonEmpty err) a
runMultiExcept :: forall err a. MultiExcept err a -> Either (NonEmpty err) a
runMultiExcept (Errors NonEmptyDList err
errs) = NonEmpty err -> Either (NonEmpty err) a
forall a b. a -> Either a b
Left (NonEmpty err -> Either (NonEmpty err) a)
-> NonEmpty err -> Either (NonEmpty err) a
forall a b. (a -> b) -> a -> b
$ (err -> [err] -> NonEmpty err) -> (err, [err]) -> NonEmpty err
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry err -> [err] -> NonEmpty err
forall a. a -> [a] -> NonEmpty a
(:|) ((err, [err]) -> NonEmpty err) -> (err, [err]) -> NonEmpty err
forall a b. (a -> b) -> a -> b
$ NonEmptyDList err -> (err, [err])
forall a. NonEmptyDList a -> (a, [a])
runNonEmptyDList NonEmptyDList err
errs
runMultiExcept (Success a
a) = a -> Either (NonEmpty err) a
forall a b. b -> Either a b
Right a
a

#else

-- | Run the computation.
runMultiExcept :: MultiExcept err a -> Either (err, [err]) a
runMultiExcept (Errors errs) = Left $ runNonEmptyDList errs
runMultiExcept (Success a) = Right a

#endif

-- | Throw a single error.
throwError :: forall a err. err -> MultiExcept err a
throwError :: forall a err. 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 a. a -> NonEmptyDList a
nedlSingleton

#if MIN_VERSION_base(4,9,0)

-- | Throw one or more errors.
throwErrors :: forall a err. NonEmpty err -> MultiExcept err a
throwErrors :: forall a err. NonEmpty err -> MultiExcept err a
throwErrors (err
err :| [err]
errs) = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList err -> MultiExcept err a)
-> NonEmptyDList err -> MultiExcept err a
forall a b. (a -> b) -> a -> b
$ err -> ([err] -> [err]) -> NonEmptyDList err
forall a. a -> ([a] -> [a]) -> NonEmptyDList a
NonEmptyDList err
err ([err]
errs [err] -> [err] -> [err]
forall a. [a] -> [a] -> [a]
++)

#else

-- | Throw one or more errors.
throwErrors :: forall a err. (err, [err]) -> MultiExcept err a
throwErrors (err, errs) = Errors $ NonEmptyDList err (errs ++)

#endif

-- | Embeds a value into a 'MultiExcept' context.
succeed :: forall err a. a -> MultiExcept err a
succeed :: forall err a. 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 :: forall err a. Either err a -> MultiExcept err a
fromEither (Left err
err) = err -> MultiExcept err a
forall a err. err -> MultiExcept err a
throwError err
err
fromEither (Right a
a) = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a

#if MIN_VERSION_base(4,9,0)

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

#else

-- | Convert a multi-error 'Either' to a 'MultiExcept'.
fromEitherPoly :: Either (err, [err]) a -> MultiExcept err a
fromEitherPoly (Left errs) = throwErrors errs
fromEitherPoly (Right a) = Success a

#endif

-- | Join nested 'MultiExcept's with the same error type.
-- Note that this doesn't imply a __useful__ 'Control.Monad.Monad' instance.
-- The instance defined in terms of join discards errors on the RHS of 'Control.Monad.>>=',
-- when the LHS is an error value.
join :: MultiExcept err (MultiExcept err a) -> MultiExcept err a
join :: forall err a.
MultiExcept err (MultiExcept err a) -> MultiExcept err a
join (Success MultiExcept err a
a) = MultiExcept err a
a
join (Errors 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 :: forall a b. (a -> b) -> MultiExcept err a -> MultiExcept err b
fmap a -> b
f (Success 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 a -> b
_ (Errors NonEmptyDList err
errs) = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
errs

-- | A non-overloaded `bimap`
mapMultiExcept:: (err -> err') -> (a -> a') -> MultiExcept err a -> MultiExcept err' a'
mapMultiExcept :: forall err err' a a'.
(err -> err')
-> (a -> a') -> MultiExcept err a -> MultiExcept err' a'
mapMultiExcept err -> err'
_ a -> a'
fa (Success a
a)    = a' -> MultiExcept err' a'
forall err a. a -> MultiExcept err a
Success (a' -> MultiExcept err' a') -> a' -> MultiExcept err' a'
forall a b. (a -> b) -> a -> b
$ a -> a'
fa a
a
mapMultiExcept err -> err'
ferr a -> a'
_ (Errors NonEmptyDList err
err) = NonEmptyDList err' -> MultiExcept err' a'
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList err' -> MultiExcept err' a')
-> NonEmptyDList err' -> MultiExcept err' a'
forall a b. (a -> b) -> a -> b
$ (err -> err') -> NonEmptyDList err -> NonEmptyDList err'
forall a b. (a -> b) -> NonEmptyDList a -> NonEmptyDList b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap err -> err'
ferr NonEmptyDList err
err


#if MIN_VERSION_base(4,8,0)

-- | WARNING: O(n) space and time in the length of the amount of errors
-- this could be fixed by changing the difference list Functor instance.
instance Bifunctor MultiExcept where
  bimap :: forall err err' a a'.
(err -> err')
-> (a -> a') -> MultiExcept err a -> MultiExcept err' a'
bimap = (a -> b) -> (c -> d) -> MultiExcept a c -> MultiExcept b d
forall err err' a a'.
(err -> err')
-> (a -> a') -> MultiExcept err a -> MultiExcept err' a'
mapMultiExcept

#endif

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

  Errors NonEmptyDList err
l <*> :: forall a b.
MultiExcept err (a -> b) -> MultiExcept err a -> MultiExcept err b
<*> Errors 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 -> NonEmptyDList err -> NonEmptyDList err
forall a. NonEmptyDList a -> NonEmptyDList a -> NonEmptyDList a
appendNedl NonEmptyDList err
l NonEmptyDList err
l'
  Success a -> b
f <*> Success 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 NonEmptyDList err
l <*> MultiExcept err a
_ = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
l
  MultiExcept err (a -> b)
_ <*> Errors NonEmptyDList err
l = NonEmptyDList err -> MultiExcept err b
forall err a. NonEmptyDList err -> MultiExcept err a
Errors NonEmptyDList err
l

-- | Return the first success, or all of the combined errors.
--
-- ==== __Examples__
--
-- >>> pure 1 `or` throwError 3
-- Success 1
--
-- >>> throwError 2 `or` pure 1
-- Success 1
--
-- >>> throwError 2 `or` throwError 3
-- Errors [2, 3]
or :: MultiExcept err a -> MultiExcept err a -> MultiExcept err a
Success a
a or :: forall err a.
MultiExcept err a -> MultiExcept err a -> MultiExcept err a
`or` MultiExcept err a
_ = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a
MultiExcept err a
_ `or` Success a
a = a -> MultiExcept err a
forall err a. a -> MultiExcept err a
Success a
a
Errors NonEmptyDList err
l `or` Errors NonEmptyDList err
r = NonEmptyDList err -> MultiExcept err a
forall err a. NonEmptyDList err -> MultiExcept err a
Errors (NonEmptyDList err -> MultiExcept err a)
-> NonEmptyDList err -> MultiExcept err a
forall a b. (a -> b) -> a -> b
$ NonEmptyDList err -> NonEmptyDList err -> NonEmptyDList err
forall a. NonEmptyDList a -> NonEmptyDList a -> NonEmptyDList a
appendNedl NonEmptyDList err
l NonEmptyDList err
r

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

instance Traversable (MultiExcept err) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MultiExcept err a -> f (MultiExcept err b)
traverse a -> f b
f (Success 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 a -> f b
_ (Errors NonEmptyDList err
err) = MultiExcept err b -> f (MultiExcept err b)
forall a. a -> f a
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