{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}

-- | Either, but with an Applicative instance that combines errors via '<>'.
--
-- This is sometimes known as the validation Applicative.
-- There are Haskell packages providing this type, however, in the interest of minimized
-- dependency footprint we use this.
module Jordan.Types.Internal.AccumE
  ( AccumE
      ( AccumE,
        getAccumE,
        AccumEL,
        AccumER
      ),
  )
where

import Control.Applicative
import Data.Bifunctor
import GHC.Generics
import Text.Read

-- | A version of Either that accumulates errors via an instance of 'Semigroup'.
--
-- This is sometimes called the validation applicative.
newtype AccumE err val = AccumE {AccumE err val -> Either err val
getAccumE :: Either err val}
  deriving (a -> AccumE err b -> AccumE err a
(a -> b) -> AccumE err a -> AccumE err b
(forall a b. (a -> b) -> AccumE err a -> AccumE err b)
-> (forall a b. a -> AccumE err b -> AccumE err a)
-> Functor (AccumE err)
forall a b. a -> AccumE err b -> AccumE err a
forall a b. (a -> b) -> AccumE err a -> AccumE err b
forall err a b. a -> AccumE err b -> AccumE err a
forall err a b. (a -> b) -> AccumE err a -> AccumE err b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> AccumE err b -> AccumE err a
$c<$ :: forall err a b. a -> AccumE err b -> AccumE err a
fmap :: (a -> b) -> AccumE err a -> AccumE err b
$cfmap :: forall err a b. (a -> b) -> AccumE err a -> AccumE err b
Functor) via Either err
  deriving ((a -> b) -> (c -> d) -> AccumE a c -> AccumE b d
(a -> b) -> AccumE a c -> AccumE b c
(b -> c) -> AccumE a b -> AccumE a c
(forall a b c d. (a -> b) -> (c -> d) -> AccumE a c -> AccumE b d)
-> (forall a b c. (a -> b) -> AccumE a c -> AccumE b c)
-> (forall b c a. (b -> c) -> AccumE a b -> AccumE a c)
-> Bifunctor AccumE
forall a b c. (a -> b) -> AccumE a c -> AccumE b c
forall b c a. (b -> c) -> AccumE a b -> AccumE a c
forall a b c d. (a -> b) -> (c -> d) -> AccumE a c -> AccumE b d
forall (p :: * -> * -> *).
(forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d)
-> (forall a b c. (a -> b) -> p a c -> p b c)
-> (forall b c a. (b -> c) -> p a b -> p a c)
-> Bifunctor p
second :: (b -> c) -> AccumE a b -> AccumE a c
$csecond :: forall b c a. (b -> c) -> AccumE a b -> AccumE a c
first :: (a -> b) -> AccumE a c -> AccumE b c
$cfirst :: forall a b c. (a -> b) -> AccumE a c -> AccumE b c
bimap :: (a -> b) -> (c -> d) -> AccumE a c -> AccumE b d
$cbimap :: forall a b c d. (a -> b) -> (c -> d) -> AccumE a c -> AccumE b d
Bifunctor) via Either
  deriving ((forall x. AccumE err val -> Rep (AccumE err val) x)
-> (forall x. Rep (AccumE err val) x -> AccumE err val)
-> Generic (AccumE err val)
forall x. Rep (AccumE err val) x -> AccumE err val
forall x. AccumE err val -> Rep (AccumE err val) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall err val x. Rep (AccumE err val) x -> AccumE err val
forall err val x. AccumE err val -> Rep (AccumE err val) x
$cto :: forall err val x. Rep (AccumE err val) x -> AccumE err val
$cfrom :: forall err val x. AccumE err val -> Rep (AccumE err val) x
Generic)

-- | Show instance uses the 'AccumER' and 'AccumEL' pattern synonyms.
instance (Show a, Show b) => Show (AccumE a b) where
  showsPrec :: Int -> AccumE a b -> ShowS
showsPrec Int
prec = \case
    AccumEL a
l ->
      Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"AccumEL " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
l
    AccumER b
r ->
      Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
        String -> ShowS
showString String
"AccumER " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> b -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 b
r

-- | Read instance uses the 'AccumER' and 'AccumEL' pattern synonyms.
instance (Read a, Read b) => Read (AccumE a b) where
  readPrec :: ReadPrec (AccumE a b)
readPrec = ReadPrec (AccumE a b) -> ReadPrec (AccumE a b)
forall a. ReadPrec a -> ReadPrec a
parens (ReadPrec (AccumE a b) -> ReadPrec (AccumE a b))
-> ReadPrec (AccumE a b) -> ReadPrec (AccumE a b)
forall a b. (a -> b) -> a -> b
$ ReadPrec (AccumE a b)
forall val. ReadPrec (AccumE a val)
left ReadPrec (AccumE a b)
-> ReadPrec (AccumE a b) -> ReadPrec (AccumE a b)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ ReadPrec (AccumE a b)
forall err. ReadPrec (AccumE err b)
right
    where
      left :: ReadPrec (AccumE a val)
left = do
        Ident String
"AccumEL" <- ReadPrec Lexeme
lexP
        a -> AccumE a val
forall err val. err -> AccumE err val
AccumEL (a -> AccumE a val) -> ReadPrec a -> ReadPrec (AccumE a val)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
step ReadPrec a
forall a. Read a => ReadPrec a
readPrec
      right :: ReadPrec (AccumE err b)
right = do
        Ident String
"AccumER" <- ReadPrec Lexeme
lexP
        b -> AccumE err b
forall val err. val -> AccumE err val
AccumER (b -> AccumE err b) -> ReadPrec b -> ReadPrec (AccumE err b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadPrec b -> ReadPrec b
forall a. ReadPrec a -> ReadPrec a
step ReadPrec b
forall a. Read a => ReadPrec a
readPrec

-- | Construct an error value.
pattern AccumEL :: err -> AccumE err val
pattern $bAccumEL :: err -> AccumE err val
$mAccumEL :: forall r err val. AccumE err val -> (err -> r) -> (Void# -> r) -> r
AccumEL l = AccumE (Left l)

-- | Construct a good value.
-- Equivalent to 'pure'.
pattern AccumER :: val -> AccumE err val
pattern $bAccumER :: val -> AccumE err val
$mAccumER :: forall r val err. AccumE err val -> (val -> r) -> (Void# -> r) -> r
AccumER r = AccumE (Right r)

{-# COMPLETE AccumEL, AccumER #-}

-- | Applicative accumulates errors.
--
-- Note that this is *strict* in the error, because this
-- can sometimes reduce the number of allocations in the places
-- where we use this.
instance (Semigroup e) => Applicative (AccumE e) where
  pure :: a -> AccumE e a
pure !a
a = Either e a -> AccumE e a
forall err val. Either err val -> AccumE err val
AccumE (a -> Either e a
forall a b. b -> Either a b
Right a
a)
  {-# INLINE pure #-}
  (AccumE !Either e (a -> b)
f) <*> :: AccumE e (a -> b) -> AccumE e a -> AccumE e b
<*> (AccumE !Either e a
a) = Either e b -> AccumE e b
forall err val. Either err val -> AccumE err val
AccumE (Either e b -> AccumE e b) -> Either e b -> AccumE e b
forall a b. (a -> b) -> a -> b
$ case Either e (a -> b)
f of
    Left !e
e -> case Either e a
a of
      Left !e
e' -> e -> Either e b
forall a b. a -> Either a b
Left (e -> Either e b) -> e -> Either e b
forall a b. (a -> b) -> a -> b
$ e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e'
      Right !a
a' -> e -> Either e b
forall a b. a -> Either a b
Left e
e
    Right !a -> b
fab -> case Either e a
a of
      Left !e
e -> e -> Either e b
forall a b. a -> Either a b
Left e
e
      Right !a
arg -> b -> Either e b
forall a b. b -> Either a b
Right (b -> Either e b) -> b -> Either e b
forall a b. (a -> b) -> a -> b
$ a -> b
fab a
arg
  {-# INLINE (<*>) #-}
  liftA2 :: (a -> b -> c) -> AccumE e a -> AccumE e b -> AccumE e c
liftA2 a -> b -> c
f (AccumE Either e a
arg) (AccumE Either e b
arg') =
    Either e c -> AccumE e c
forall err val. Either err val -> AccumE err val
AccumE
      ( case Either e a
arg of
          Left e
e -> case Either e b
arg' of
            Left e
e' -> e -> Either e c
forall a b. a -> Either a b
Left (e -> Either e c) -> e -> Either e c
forall a b. (a -> b) -> a -> b
$ e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e'
            Right b
b -> e -> Either e c
forall a b. a -> Either a b
Left e
e
          Right a
a -> case Either e b
arg' of
            Left e
e -> e -> Either e c
forall a b. a -> Either a b
Left e
e
            Right b
b -> c -> Either e c
forall a b. b -> Either a b
Right (a -> b -> c
f a
a b
b)
      )
  {-# INLINE liftA2 #-}

-- | Alternative takes the first result if there is a result.
-- If there is not, will *not* accumulate errors.
instance (Monoid m) => Alternative (AccumE m) where
  empty :: AccumE m a
empty = m -> AccumE m a
forall err val. err -> AccumE err val
AccumEL m
forall a. Monoid a => a
mempty
  (AccumER a
a) <|> :: AccumE m a -> AccumE m a -> AccumE m a
<|> AccumE m a
_ = a -> AccumE m a
forall val err. val -> AccumE err val
AccumER a
a
  (AccumEL m
_) <|> (AccumER a
a) = a -> AccumE m a
forall val err. val -> AccumE err val
AccumER a
a
  (AccumEL m
a) <|> (AccumEL m
_) = m -> AccumE m a
forall err val. err -> AccumE err val
AccumEL m
a
  {-# INLINE (<|>) #-}

-- | Semigroup accumulates errors if both are errors, otherwise
-- it returns the first good value.
instance (Semigroup e) => Semigroup (AccumE e a) where
  (AccumE Either e a
lhs) <> :: AccumE e a -> AccumE e a -> AccumE e a
<> (AccumE Either e a
rhs) = Either e a -> AccumE e a
forall err val. Either err val -> AccumE err val
AccumE (Either e a -> AccumE e a) -> Either e a -> AccumE e a
forall a b. (a -> b) -> a -> b
$ case Either e a
lhs of
    Left e
e -> case Either e a
rhs of
      Left e
e' -> e -> Either e a
forall a b. a -> Either a b
Left (e -> Either e a) -> e -> Either e a
forall a b. (a -> b) -> a -> b
$ e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e'
      Right a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
a
    Right a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
a

-- mempty is an error with 'mempty'
instance (Monoid err) => Monoid (AccumE err a) where
  mempty :: AccumE err a
mempty = err -> AccumE err a
forall err val. err -> AccumE err val
AccumEL err
forall a. Monoid a => a
mempty