{-# LANGUAGE QuantifiedConstraints #-}

-- | Common functionality for "Development.GitRev.Internal.Utils".
--
-- @since 0.1
module Development.GitRev.Internal.Utils.Common
  ( -- * Either projections
    projectConst,
    projectFalse,
    projectError,
    projectErrorMap,
    projectLeft,

    -- * Bifunctor utils
    joinFirst,
  )
where

import Control.Exception (Exception (displayException))
import Control.Monad (join)
import Data.Bifunctor (Bifunctor (bimap, first))

-- $setup
-- >>> import Data.Text (Text)
-- >>> import Development.GitRev.Typed.OsString (qToCode)
-- >>> import Development.GitRev.Internal.Environment (EnvError (..))
-- >>> import Development.GitRev.Internal.Git (gitDirtyQ)
-- >>> import Development.GitRev.Internal.Utils (GitRevError (..))
-- >>> import Language.Haskell.TH (Q)

-- | Projects 'Left' to the given value.
--
-- ==== __Examples__
--
-- >>> $$(qToCode $ projectConst "FAILURE" (pure $ Left ()))
-- "FAILURE"
--
-- @since 0.1
projectConst ::
  forall f e a.
  (Functor f) =>
  a ->
  f (Either e a) ->
  f a
projectConst :: forall (f :: * -> *) e a. Functor f => a -> f (Either e a) -> f a
projectConst = (e -> a) -> f (Either e a) -> f a
forall (f :: * -> *) e a.
Functor f =>
(e -> a) -> f (Either e a) -> f a
projectLeft ((e -> a) -> f (Either e a) -> f a)
-> (a -> e -> a) -> a -> f (Either e a) -> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> e -> a
forall a b. a -> b -> a
const

-- | Projects 'Left' to 'False'.
--
-- ==== __Examples__
--
--
-- >>> $$(qToCode $ projectFalse (pure $ Left ()))
-- False
--
-- @since 0.1
projectFalse :: forall f e. (Functor f) => f (Either e Bool) -> f Bool
projectFalse :: forall (f :: * -> *) e. Functor f => f (Either e Bool) -> f Bool
projectFalse = (e -> Bool) -> f (Either e Bool) -> f Bool
forall (f :: * -> *) e a.
Functor f =>
(e -> a) -> f (Either e a) -> f a
projectLeft (Bool -> e -> Bool
forall a b. a -> b -> a
const Bool
False)

-- | Projects 'Left' via 'error', rendering via 'displayException'. Hence
-- an error will cause a compilation failure in 'Language.Haskell.TH.Q'.
--
-- ==== __Examples__
--
-- >>> :{
--   let gitHashOrDieQ :: Q Bool
--       gitHashOrDieQ = projectError gitDirtyQ
-- :}
--
-- @since 0.1
projectError :: forall f e a. (Exception e, Functor f) => f (Either e a) -> f a
projectError :: forall (f :: * -> *) e a.
(Exception e, Functor f) =>
f (Either e a) -> f a
projectError = (e -> String) -> f (Either e a) -> f a
forall (f :: * -> *) e a.
Functor f =>
(e -> String) -> f (Either e a) -> f a
projectErrorMap e -> String
forall e. Exception e => e -> String
displayException

-- | Projects 'Left' via 'error', rendering via the given function. Hence
-- an error will cause a compilation failure.
--
-- ==== __Examples__
--
-- >>> :{
--   let gitHashOrDieQ :: Q Bool
--       gitHashOrDieQ = (projectErrorMap show) gitDirtyQ
-- :}
--
-- @since 0.1
projectErrorMap ::
  forall f e a.
  (Functor f) =>
  (e -> String) ->
  f (Either e a) ->
  f a
projectErrorMap :: forall (f :: * -> *) e a.
Functor f =>
(e -> String) -> f (Either e a) -> f a
projectErrorMap e -> String
onErr = (e -> a) -> f (Either e a) -> f a
forall (f :: * -> *) e a.
Functor f =>
(e -> a) -> f (Either e a) -> f a
projectLeft (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (e -> String) -> e -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
onErr)

-- | Projects 'Left' via the given function.
--
-- @since 0.1
projectLeft :: forall f e a. (Functor f) => (e -> a) -> f (Either e a) -> f a
projectLeft :: forall (f :: * -> *) e a.
Functor f =>
(e -> a) -> f (Either e a) -> f a
projectLeft e -> a
f = (Either e a -> a) -> f (Either e a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((e -> a) -> (a -> a) -> Either e a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> a
f a -> a
forall a. a -> a
id)

-- | Join the 'first' component in a bifunctor, useful for unifying
-- nested errors with @GitRevError@.
--
-- ==== __Examples__
--
-- >>> e = Right @EnvError (Left @Text @() "an error")
-- >>> :type e
-- e :: Either EnvError (Either Text ())
--
-- >>> let joined = joinFirst GitRevErrorEnv GitRevErrorText e
-- >>> joined
-- Left (GitRevErrorText "an error")
--
-- >>> :type joined
-- joined :: Either GitRevError ()
--
-- @since 0.1
joinFirst ::
  forall p a1 a2 b c.
  ( Bifunctor p,
    forall a. Monad (p a)
  ) =>
  -- | Map outer.
  (a1 -> b) ->
  -- | Map inner.
  (a2 -> b) ->
  -- | Nested bifunctor.
  p a1 (p a2 c) ->
  -- | Flattened bifunctor.
  p b c
joinFirst :: forall (p :: * -> * -> *) a1 a2 b c.
(Bifunctor p, forall a. Monad (p a)) =>
(a1 -> b) -> (a2 -> b) -> p a1 (p a2 c) -> p b c
joinFirst a1 -> b
embedE1 a2 -> b
embedE2 = p b (p b c) -> p b c
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (p b (p b c) -> p b c)
-> (p a1 (p a2 c) -> p b (p b c)) -> p a1 (p a2 c) -> p b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a1 -> b) -> (p a2 c -> p b c) -> p a1 (p a2 c) -> p b (p b c)
forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a1 -> b
embedE1 ((a2 -> b) -> p a2 c -> p b c
forall a b c. (a -> b) -> p a c -> p b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a2 -> b
embedE2)