{-# LANGUAGE CPP #-}

-- | Provides 'QFirst' type.
--
-- @since 0.1
module Development.GitRev.Internal.QFirst
  ( -- * Combining Q actions lazily
    QFirst (..),
    mkQFirst,
    unQFirst,
    firstSuccessQ,
    Errors (..),
    mkErrors,
    unErrors,
  )
where

import Control.Exception (Exception (displayException), SomeException)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Bifunctor (Bifunctor (bimap, first, second))
#if MIN_VERSION_base(4, 18, 0)
import Data.Foldable1 (Foldable1 (foldMap1))
#endif
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder qualified as TLB
import Data.Text.Lazy.Builder.Int qualified as TLBI
import Development.GitRev.Internal.Git.Common qualified as Common
import GHC.Records (HasField (getField))
import Language.Haskell.TH (Q)
import Language.Haskell.TH.Syntax (Lift)

-- $setup
-- >>> import Development.GitRev.Typed (qToCode)
-- >>> import Development.GitRev.Internal.Git (GitError (..), gitDirtyQ, gitHashQ)
-- >>> import Development.GitRev.Internal.Environment (EnvError (..))
-- >>> import Language.Haskell.TH (Q, runIO, runQ)
-- >>> import System.Environment (setEnv)

-- | Collects multiple errors. Intended for displaying multiple
-- exceptions via 'displayException'.
--
-- @since 0.1
newtype Errors e = MkErrors (NonEmpty e)
  deriving stock
    ( -- | @since 0.1
      Errors e -> Errors e -> Bool
(Errors e -> Errors e -> Bool)
-> (Errors e -> Errors e -> Bool) -> Eq (Errors e)
forall e. Eq e => Errors e -> Errors e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall e. Eq e => Errors e -> Errors e -> Bool
== :: Errors e -> Errors e -> Bool
$c/= :: forall e. Eq e => Errors e -> Errors e -> Bool
/= :: Errors e -> Errors e -> Bool
Eq,
      -- | @since 0.1
      (forall m. Monoid m => Errors m -> m)
-> (forall m a. Monoid m => (a -> m) -> Errors a -> m)
-> (forall m a. Monoid m => (a -> m) -> Errors a -> m)
-> (forall a b. (a -> b -> b) -> b -> Errors a -> b)
-> (forall a b. (a -> b -> b) -> b -> Errors a -> b)
-> (forall b a. (b -> a -> b) -> b -> Errors a -> b)
-> (forall b a. (b -> a -> b) -> b -> Errors a -> b)
-> (forall a. (a -> a -> a) -> Errors a -> a)
-> (forall a. (a -> a -> a) -> Errors a -> a)
-> (forall a. Errors a -> [a])
-> (forall a. Errors a -> Bool)
-> (forall a. Errors a -> Int)
-> (forall a. Eq a => a -> Errors a -> Bool)
-> (forall a. Ord a => Errors a -> a)
-> (forall a. Ord a => Errors a -> a)
-> (forall a. Num a => Errors a -> a)
-> (forall a. Num a => Errors a -> a)
-> Foldable Errors
forall a. Eq a => a -> Errors a -> Bool
forall a. Num a => Errors a -> a
forall a. Ord a => Errors a -> a
forall m. Monoid m => Errors m -> m
forall a. Errors a -> Bool
forall a. Errors a -> Int
forall a. Errors a -> [a]
forall a. (a -> a -> a) -> Errors a -> a
forall m a. Monoid m => (a -> m) -> Errors a -> m
forall b a. (b -> a -> b) -> b -> Errors a -> b
forall a b. (a -> b -> b) -> b -> Errors a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Errors m -> m
fold :: forall m. Monoid m => Errors m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Errors a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Errors a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Errors a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Errors a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Errors a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Errors a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Errors a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Errors a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Errors a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Errors a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Errors a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Errors a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Errors a -> a
foldr1 :: forall a. (a -> a -> a) -> Errors a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Errors a -> a
foldl1 :: forall a. (a -> a -> a) -> Errors a -> a
$ctoList :: forall a. Errors a -> [a]
toList :: forall a. Errors a -> [a]
$cnull :: forall a. Errors a -> Bool
null :: forall a. Errors a -> Bool
$clength :: forall a. Errors a -> Int
length :: forall a. Errors a -> Int
$celem :: forall a. Eq a => a -> Errors a -> Bool
elem :: forall a. Eq a => a -> Errors a -> Bool
$cmaximum :: forall a. Ord a => Errors a -> a
maximum :: forall a. Ord a => Errors a -> a
$cminimum :: forall a. Ord a => Errors a -> a
minimum :: forall a. Ord a => Errors a -> a
$csum :: forall a. Num a => Errors a -> a
sum :: forall a. Num a => Errors a -> a
$cproduct :: forall a. Num a => Errors a -> a
product :: forall a. Num a => Errors a -> a
Foldable,
      -- | @since 0.1
      (forall a b. (a -> b) -> Errors a -> Errors b)
-> (forall a b. a -> Errors b -> Errors a) -> Functor Errors
forall a b. a -> Errors b -> Errors a
forall a b. (a -> b) -> Errors a -> Errors b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Errors a -> Errors b
fmap :: forall a b. (a -> b) -> Errors a -> Errors b
$c<$ :: forall a b. a -> Errors b -> Errors a
<$ :: forall a b. a -> Errors b -> Errors a
Functor,
      -- | @since 0.1
      (forall (m :: * -> *). Quote m => Errors e -> m Exp)
-> (forall (m :: * -> *). Quote m => Errors e -> Code m (Errors e))
-> Lift (Errors e)
forall e (m :: * -> *). (Lift e, Quote m) => Errors e -> m Exp
forall e (m :: * -> *).
(Lift e, Quote m) =>
Errors e -> Code m (Errors e)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Errors e -> m Exp
forall (m :: * -> *). Quote m => Errors e -> Code m (Errors e)
$clift :: forall e (m :: * -> *). (Lift e, Quote m) => Errors e -> m Exp
lift :: forall (m :: * -> *). Quote m => Errors e -> m Exp
$cliftTyped :: forall e (m :: * -> *).
(Lift e, Quote m) =>
Errors e -> Code m (Errors e)
liftTyped :: forall (m :: * -> *). Quote m => Errors e -> Code m (Errors e)
Lift,
      -- | @since 0.1
      Int -> Errors e -> ShowS
[Errors e] -> ShowS
Errors e -> String
(Int -> Errors e -> ShowS)
-> (Errors e -> String) -> ([Errors e] -> ShowS) -> Show (Errors e)
forall e. Show e => Int -> Errors e -> ShowS
forall e. Show e => [Errors e] -> ShowS
forall e. Show e => Errors e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall e. Show e => Int -> Errors e -> ShowS
showsPrec :: Int -> Errors e -> ShowS
$cshow :: forall e. Show e => Errors e -> String
show :: Errors e -> String
$cshowList :: forall e. Show e => [Errors e] -> ShowS
showList :: [Errors e] -> ShowS
Show,
      -- | @since 0.1
      Functor Errors
Foldable Errors
(Functor Errors, Foldable Errors) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Errors a -> f (Errors b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Errors (f a) -> f (Errors a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Errors a -> m (Errors b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Errors (m a) -> m (Errors a))
-> Traversable Errors
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Errors (m a) -> m (Errors a)
forall (f :: * -> *) a.
Applicative f =>
Errors (f a) -> f (Errors a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Errors a -> m (Errors b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Errors a -> f (Errors b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Errors a -> f (Errors b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Errors a -> f (Errors b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Errors (f a) -> f (Errors a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Errors (f a) -> f (Errors a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Errors a -> m (Errors b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Errors a -> m (Errors b)
$csequence :: forall (m :: * -> *) a. Monad m => Errors (m a) -> m (Errors a)
sequence :: forall (m :: * -> *) a. Monad m => Errors (m a) -> m (Errors a)
Traversable
    )
  deriving newtype
    ( -- | @since 0.1
      Functor Errors
Functor Errors =>
(forall a. a -> Errors a)
-> (forall a b. Errors (a -> b) -> Errors a -> Errors b)
-> (forall a b c.
    (a -> b -> c) -> Errors a -> Errors b -> Errors c)
-> (forall a b. Errors a -> Errors b -> Errors b)
-> (forall a b. Errors a -> Errors b -> Errors a)
-> Applicative Errors
forall a. a -> Errors a
forall a b. Errors a -> Errors b -> Errors a
forall a b. Errors a -> Errors b -> Errors b
forall a b. Errors (a -> b) -> Errors a -> Errors b
forall a b c. (a -> b -> c) -> Errors a -> Errors b -> Errors c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Errors a
pure :: forall a. a -> Errors a
$c<*> :: forall a b. Errors (a -> b) -> Errors a -> Errors b
<*> :: forall a b. Errors (a -> b) -> Errors a -> Errors b
$cliftA2 :: forall a b c. (a -> b -> c) -> Errors a -> Errors b -> Errors c
liftA2 :: forall a b c. (a -> b -> c) -> Errors a -> Errors b -> Errors c
$c*> :: forall a b. Errors a -> Errors b -> Errors b
*> :: forall a b. Errors a -> Errors b -> Errors b
$c<* :: forall a b. Errors a -> Errors b -> Errors a
<* :: forall a b. Errors a -> Errors b -> Errors a
Applicative,
      -- | @since 0.1
      Applicative Errors
Applicative Errors =>
(forall a b. Errors a -> (a -> Errors b) -> Errors b)
-> (forall a b. Errors a -> Errors b -> Errors b)
-> (forall a. a -> Errors a)
-> Monad Errors
forall a. a -> Errors a
forall a b. Errors a -> Errors b -> Errors b
forall a b. Errors a -> (a -> Errors b) -> Errors b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Errors a -> (a -> Errors b) -> Errors b
>>= :: forall a b. Errors a -> (a -> Errors b) -> Errors b
$c>> :: forall a b. Errors a -> Errors b -> Errors b
>> :: forall a b. Errors a -> Errors b -> Errors b
$creturn :: forall a. a -> Errors a
return :: forall a. a -> Errors a
Monad,
      -- | @since 0.1
      NonEmpty (Errors e) -> Errors e
Errors e -> Errors e -> Errors e
(Errors e -> Errors e -> Errors e)
-> (NonEmpty (Errors e) -> Errors e)
-> (forall b. Integral b => b -> Errors e -> Errors e)
-> Semigroup (Errors e)
forall b. Integral b => b -> Errors e -> Errors e
forall e. NonEmpty (Errors e) -> Errors e
forall e. Errors e -> Errors e -> Errors e
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall e b. Integral b => b -> Errors e -> Errors e
$c<> :: forall e. Errors e -> Errors e -> Errors e
<> :: Errors e -> Errors e -> Errors e
$csconcat :: forall e. NonEmpty (Errors e) -> Errors e
sconcat :: NonEmpty (Errors e) -> Errors e
$cstimes :: forall e b. Integral b => b -> Errors e -> Errors e
stimes :: forall b. Integral b => b -> Errors e -> Errors e
Semigroup
    )

-- | @since 0.1
instance HasField "unErrors" (Errors e) (NonEmpty e) where
  getField :: Errors e -> NonEmpty e
getField = Errors e -> NonEmpty e
forall e. Errors e -> NonEmpty e
unErrors

-- | @since 0.1
instance (Exception e) => Exception (Errors e) where
  displayException :: Errors e -> String
displayException (MkErrors NonEmpty e
errs) =
    [String] -> String
forall a. Monoid a => [a] -> a
mconcat
      [ String
"Exception(s):",
        NonEmpty e -> String
renderErrs NonEmpty e
errs
      ]
    where
      renderErrs :: NonEmpty e -> String
renderErrs =
        Text -> String
T.unpack
          (Text -> String) -> (NonEmpty e -> Text) -> NonEmpty e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyText -> Text
TL.toStrict
          (LazyText -> Text)
-> (NonEmpty e -> LazyText) -> NonEmpty e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyText
TLB.toLazyText
          (Builder -> LazyText)
-> (NonEmpty e -> Builder) -> NonEmpty e -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, e) -> Builder) -> NonEmpty (Int, e) -> Builder
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, e) -> Builder
forall {a} {b}. (Integral a, Exception b) => (a, b) -> Builder
renderErr
          (NonEmpty (Int, e) -> Builder)
-> (NonEmpty e -> NonEmpty (Int, e)) -> NonEmpty e -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip @Int (Int
1 Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
2 ..])

      renderErr :: (a, b) -> Builder
renderErr (a
idx, b
e) =
        (\Builder
b -> Builder
"\n" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. Integral a => a -> Builder
TLBI.decimal a
idx Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
". " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b)
          (Builder -> Builder) -> (b -> Builder) -> b -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
TLB.fromText
          (Text -> Builder) -> (b -> Text) -> b -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
          (Text -> Text) -> (b -> Text) -> b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
          (String -> Text) -> (b -> String) -> b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> String
forall e. Exception e => e -> String
displayException
          (b -> Builder) -> b -> Builder
forall a b. (a -> b) -> a -> b
$ b
e

-- | Unwraps 'Errors'.
--
-- @since 0.1
unErrors :: forall e. Errors e -> NonEmpty e
unErrors :: forall e. Errors e -> NonEmpty e
unErrors (MkErrors NonEmpty e
e) = NonEmpty e
e

-- | Wraps a type in 'Errors'.
--
-- @since 0.1
mkErrors :: forall e. NonEmpty e -> Errors e
mkErrors :: forall e. NonEmpty e -> Errors e
mkErrors = NonEmpty e -> Errors e
forall e. NonEmpty e -> Errors e
MkErrors

-- | Wrapper for 'Q' over 'Either' with a lazier 'Semigroup'. With this, we
-- can run:
--
-- @
--   mkQFirst q1 <> mkQFirst q2
-- @
--
-- This will only execute @q2@ if @q1@ returns 'Left', unlike 'Q'\'s normal
-- 'Semigroup' instance.
--
-- If both actions fail, then both errors will be returned via 'Errors'.
--
-- === Warning: exceptions
--
-- In order for 'QFirst' to work as expected, the underlying 'Q' action
-- should /not/ throw exceptions. Uncaught exceptions will not be caught
-- by 'QFirst', hence the intended "try multiple 'Q'-actions until we have a
-- success" pattern will not work.
--
-- @since 0.1
newtype QFirst e a = MkQFirst (Q (Either (Errors e) a))
  deriving stock
    ( -- | @since 0.1
      (forall a b. (a -> b) -> QFirst e a -> QFirst e b)
-> (forall a b. a -> QFirst e b -> QFirst e a)
-> Functor (QFirst e)
forall a b. a -> QFirst e b -> QFirst e a
forall a b. (a -> b) -> QFirst e a -> QFirst e b
forall e a b. a -> QFirst e b -> QFirst e a
forall e a b. (a -> b) -> QFirst e a -> QFirst e b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall e a b. (a -> b) -> QFirst e a -> QFirst e b
fmap :: forall a b. (a -> b) -> QFirst e a -> QFirst e b
$c<$ :: forall e a b. a -> QFirst e b -> QFirst e a
<$ :: forall a b. a -> QFirst e b -> QFirst e a
Functor
    )

-- | @since 0.1
instance HasField "unQFirst" (QFirst e a) (Q (Either (Errors e) a)) where
  getField :: QFirst e a -> Q (Either (Errors e) a)
getField = QFirst e a -> Q (Either (Errors e) a)
forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst

-- | @since 0.1
instance Semigroup (QFirst e a) where
  MkQFirst Q (Either (Errors e) a)
q1 <> :: QFirst e a -> QFirst e a -> QFirst e a
<> QFirst e a
q2 =
    Q (Either (Errors e) a) -> QFirst e a
forall e a. Q (Either (Errors e) a) -> QFirst e a
MkQFirst (Q (Either (Errors e) a) -> QFirst e a)
-> Q (Either (Errors e) a) -> QFirst e a
forall a b. (a -> b) -> a -> b
$
      Q (Either (Errors e) a)
q1 Q (Either (Errors e) a)
-> (Either (Errors e) a -> Q (Either (Errors e) a))
-> Q (Either (Errors e) a)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Right a
x -> Either (Errors e) a -> Q (Either (Errors e) a)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Errors e) a -> Q (Either (Errors e) a))
-> Either (Errors e) a -> Q (Either (Errors e) a)
forall a b. (a -> b) -> a -> b
$ a -> Either (Errors e) a
forall a b. b -> Either a b
Right a
x
        Left Errors e
errs -> (Errors e -> Errors e)
-> Either (Errors e) a -> Either (Errors e) a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Errors e
errs Errors e -> Errors e -> Errors e
forall a. Semigroup a => a -> a -> a
<>) (Either (Errors e) a -> Either (Errors e) a)
-> Q (Either (Errors e) a) -> Q (Either (Errors e) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QFirst e a -> Q (Either (Errors e) a)
forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst QFirst e a
q2

-- | @since 0.1
instance Applicative (QFirst e) where
  pure :: forall a. a -> QFirst e a
pure = Q (Either e a) -> QFirst e a
forall e a. Q (Either e a) -> QFirst e a
mkQFirst (Q (Either e a) -> QFirst e a)
-> (a -> Q (Either e a)) -> a -> QFirst e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> Q (Either e a)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> Q (Either e a))
-> (a -> Either e a) -> a -> Q (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right

  MkQFirst Q (Either (Errors e) (a -> b))
q1 <*> :: forall a b. QFirst e (a -> b) -> QFirst e a -> QFirst e b
<*> QFirst e a
q2 =
    Q (Either (Errors e) b) -> QFirst e b
forall e a. Q (Either (Errors e) a) -> QFirst e a
MkQFirst (Q (Either (Errors e) b) -> QFirst e b)
-> Q (Either (Errors e) b) -> QFirst e b
forall a b. (a -> b) -> a -> b
$
      Q (Either (Errors e) (a -> b))
q1 Q (Either (Errors e) (a -> b))
-> (Either (Errors e) (a -> b) -> Q (Either (Errors e) b))
-> Q (Either (Errors e) b)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Errors e
errs -> Either (Errors e) b -> Q (Either (Errors e) b)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Errors e) b -> Q (Either (Errors e) b))
-> Either (Errors e) b -> Q (Either (Errors e) b)
forall a b. (a -> b) -> a -> b
$ Errors e -> Either (Errors e) b
forall a b. a -> Either a b
Left Errors e
errs
        Right a -> b
f -> (a -> b) -> Either (Errors e) a -> Either (Errors e) b
forall b c a. (b -> c) -> Either a b -> Either a c
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second a -> b
f (Either (Errors e) a -> Either (Errors e) b)
-> Q (Either (Errors e) a) -> Q (Either (Errors e) b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QFirst e a -> Q (Either (Errors e) a)
forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst QFirst e a
q2

-- | @since 0.1
instance Monad (QFirst e) where
  MkQFirst Q (Either (Errors e) a)
q1 >>= :: forall a b. QFirst e a -> (a -> QFirst e b) -> QFirst e b
>>= a -> QFirst e b
k =
    Q (Either (Errors e) b) -> QFirst e b
forall e a. Q (Either (Errors e) a) -> QFirst e a
MkQFirst (Q (Either (Errors e) b) -> QFirst e b)
-> Q (Either (Errors e) b) -> QFirst e b
forall a b. (a -> b) -> a -> b
$
      Q (Either (Errors e) a)
q1 Q (Either (Errors e) a)
-> (Either (Errors e) a -> Q (Either (Errors e) b))
-> Q (Either (Errors e) b)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Errors e
errs -> Either (Errors e) b -> Q (Either (Errors e) b)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Errors e) b -> Q (Either (Errors e) b))
-> Either (Errors e) b -> Q (Either (Errors e) b)
forall a b. (a -> b) -> a -> b
$ Errors e -> Either (Errors e) b
forall a b. a -> Either a b
Left Errors e
errs
        Right a
x -> QFirst e b -> Q (Either (Errors e) b)
forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst (QFirst e b -> Q (Either (Errors e) b))
-> QFirst e b -> Q (Either (Errors e) b)
forall a b. (a -> b) -> a -> b
$ a -> QFirst e b
k a
x

-- | Catches synchronous exceptions.
--
-- @since 0.1
instance (e ~ SomeException) => MonadIO (QFirst e) where
  liftIO :: forall a. IO a -> QFirst e a
liftIO = Q (Either (Errors e) a) -> QFirst e a
forall e a. Q (Either (Errors e) a) -> QFirst e a
MkQFirst (Q (Either (Errors e) a) -> QFirst e a)
-> (IO a -> Q (Either (Errors e) a)) -> IO a -> QFirst e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either (Errors e) a) -> Q (Either (Errors e) a)
forall a. IO a -> Q a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Errors e) a) -> Q (Either (Errors e) a))
-> (IO a -> IO (Either (Errors e) a))
-> IO a
-> Q (Either (Errors e) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either e a -> Either (Errors e) a)
-> IO (Either e a) -> IO (Either (Errors e) a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> Errors e) -> Either e a -> Either (Errors e) a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first e -> Errors e
forall a. a -> Errors a
mapError) (IO (Either e a) -> IO (Either (Errors e) a))
-> (IO a -> IO (Either e a)) -> IO a -> IO (Either (Errors e) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either e a)
IO a -> IO (Either SomeException a)
forall a. IO a -> IO (Either SomeException a)
Common.trySync
    where
      mapError :: e -> Errors e
mapError = NonEmpty e -> Errors e
forall e. NonEmpty e -> Errors e
MkErrors (NonEmpty e -> Errors e) -> (e -> NonEmpty e) -> e -> Errors e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e -> [e] -> NonEmpty e
forall a. a -> [a] -> NonEmpty a
:| [])

-- | @since 0.1
instance Bifunctor QFirst where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> QFirst a c -> QFirst b d
bimap a -> b
f c -> d
g (MkQFirst Q (Either (Errors a) c)
q) = Q (Either (Errors b) d) -> QFirst b d
forall e a. Q (Either (Errors e) a) -> QFirst e a
MkQFirst (Q (Either (Errors b) d) -> QFirst b d)
-> Q (Either (Errors b) d) -> QFirst b d
forall a b. (a -> b) -> a -> b
$ (Either (Errors a) c -> Either (Errors b) d)
-> Q (Either (Errors a) c) -> Q (Either (Errors b) d)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Errors a -> Errors b)
-> (c -> d) -> Either (Errors a) c -> Either (Errors b) d
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((a -> b) -> Errors a -> Errors b
forall a b. (a -> b) -> Errors a -> Errors b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) c -> d
g) Q (Either (Errors a) c)
q

-- | Unwraps 'QFirst'.
--
-- @since 0.1
unQFirst :: forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst :: forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst (MkQFirst Q (Either (Errors e) a)
q) = Q (Either (Errors e) a)
q

-- | Wraps a 'Q' computation in 'QFirst'.
--
-- @since 0.1
mkQFirst :: forall e a. Q (Either e a) -> QFirst e a
mkQFirst :: forall e a. Q (Either e a) -> QFirst e a
mkQFirst = Q (Either (Errors e) a) -> QFirst e a
forall e a. Q (Either (Errors e) a) -> QFirst e a
MkQFirst (Q (Either (Errors e) a) -> QFirst e a)
-> (Q (Either e a) -> Q (Either (Errors e) a))
-> Q (Either e a)
-> QFirst e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either e a -> Either (Errors e) a)
-> Q (Either e a) -> Q (Either (Errors e) a)
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> Errors e) -> Either e a -> Either (Errors e) a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (NonEmpty e -> Errors e
forall e. NonEmpty e -> Errors e
mkErrors (NonEmpty e -> Errors e) -> (e -> NonEmpty e) -> e -> Errors e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> NonEmpty e
forall a. a -> NonEmpty a
NE.singleton))

-- | @firstSuccessQ qs@ takes the first @qi@ in @qs@ that returns
-- 'Right', without executing any @qj@ for @j > i@. If there are no
-- 'Right's, returns all errors.
--
-- ==== __Examples__
--
-- >>> :{
--    $$( qToCode $
--          firstSuccessQ $
--            (pure $ Left $ MkGitError "not found")
--              :| [ gitHashQ,
--                   error "oh no"
--                 ]
--      )
-- :}
-- Right ...
--
-- @since 0.1
firstSuccessQ ::
  forall e a.
  NonEmpty (Q (Either e a)) -> Q (Either (Errors e) a)
firstSuccessQ :: forall e a. NonEmpty (Q (Either e a)) -> Q (Either (Errors e) a)
firstSuccessQ = QFirst e a -> Q (Either (Errors e) a)
forall e a. QFirst e a -> Q (Either (Errors e) a)
unQFirst (QFirst e a -> Q (Either (Errors e) a))
-> (NonEmpty (Q (Either e a)) -> QFirst e a)
-> NonEmpty (Q (Either e a))
-> Q (Either (Errors e) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q (Either e a) -> QFirst e a)
-> NonEmpty (Q (Either e a)) -> QFirst e a
forall m a. Semigroup m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 Q (Either e a) -> QFirst e a
forall e a. Q (Either e a) -> QFirst e a
mkQFirst

#if !MIN_VERSION_base(4, 18, 0)
-- Copied from base. Technically not the same as the import above since
-- that one works for all Foldable1, not just NonEmpty, but we only use it
-- here for NonEmpty, so whatever.
foldMap1 :: forall a m. (Semigroup m) => (a -> m) -> NonEmpty a -> m
foldMap1 f (x :| xs) = go (f x) xs
  where
    go y [] = y
    go y (z : zs) = y <> go (f z) zs
#endif