    {-# OPTIONS_HADDOCK not-home #-}

    -- | This module is intended for internal use only, and may change without warning
    -- in subsequent releases.
    module Optics.Internal.Utils
      ( Identity'(..)
      , wrapIdentity'
      , unwrapIdentity'

      , Traversed(..)
      , runTraversed

      , OrT(..)
      , wrapOrT

      , (#.)
      , (.#)
      , uncurry'
      ) where

    import qualified Data.Semigroup as SG

    import Data.Profunctor.Indexed

    -- Needed for strict application of (indexed) setters.
    --
    -- Credit for this goes to Eric Mertens, see
    -- <https://github.com/glguy/irc-core/commit/2d5fc45b05f1>.
    data Identity' a = Identity' {-# UNPACK #-} !() a
      deriving (forall a b. (a -> b) -> Identity' a -> Identity' b)
    -> (forall a b. a -> Identity' b -> Identity' a)
    -> Functor Identity'
    forall a b. a -> Identity' b -> Identity' a
    forall a b. (a -> b) -> Identity' a -> Identity' 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) -> Identity' a -> Identity' b
    fmap :: forall a b. (a -> b) -> Identity' a -> Identity' b
    $c<$ :: forall a b. a -> Identity' b -> Identity' a
    <$ :: forall a b. a -> Identity' b -> Identity' a
    Functor

    instance Applicative Identity' where
      pure :: forall a. a -> Identity' a
    pure a
    a = () -> a -> Identity' a
    forall a. () -> a -> Identity' a
    Identity' () a
    a
      Identity' () a -> b
    f <*> :: forall a b. Identity' (a -> b) -> Identity' a -> Identity' b
    <*> Identity' () a
    x = () -> b -> Identity' b
    forall a. () -> a -> Identity' a
    Identity' () (a -> b
    f a
    x)

    instance Mapping (Star Identity') where
      roam :: forall a b s t i.
    ((a -> b) -> s -> t)
    -> Star Identity' i a b -> Star Identity' i s t
    roam  (a -> b) -> s -> t
    f (Star a -> Identity' b
    k) = (s -> Identity' t) -> Star Identity' i s t
    forall (f :: * -> *) i a b. (a -> f b) -> Star f i a b
    Star ((s -> Identity' t) -> Star Identity' i s t)
    -> (s -> Identity' t) -> Star Identity' i s t
    forall a b. (a -> b) -> a -> b
    $ t -> Identity' t
    forall a. a -> Identity' a
    wrapIdentity' (t -> Identity' t) -> (s -> t) -> s -> Identity' t
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> b) -> s -> t
    f (Identity' b -> b
    forall a. Identity' a -> a
    unwrapIdentity' (Identity' b -> b) -> (a -> Identity' b) -> a -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Identity' b
    k)
      iroam :: forall i a b s t j.
    ((i -> a -> b) -> s -> t)
    -> Star Identity' j a b -> Star Identity' (i -> j) s t
    iroam (i -> a -> b) -> s -> t
    f (Star a -> Identity' b
    k) = (s -> Identity' t) -> Star Identity' (i -> j) s t
    forall (f :: * -> *) i a b. (a -> f b) -> Star f i a b
    Star ((s -> Identity' t) -> Star Identity' (i -> j) s t)
    -> (s -> Identity' t) -> Star Identity' (i -> j) s t
    forall a b. (a -> b) -> a -> b
    $ t -> Identity' t
    forall a. a -> Identity' a
    wrapIdentity' (t -> Identity' t) -> (s -> t) -> s -> Identity' t
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (i -> a -> b) -> s -> t
    f (\i
    _ -> Identity' b -> b
    forall a. Identity' a -> a
    unwrapIdentity' (Identity' b -> b) -> (a -> Identity' b) -> a -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> Identity' b
    k)

    instance Mapping (IxStar Identity') where
      roam :: forall a b s t i.
    ((a -> b) -> s -> t)
    -> IxStar Identity' i a b -> IxStar Identity' i s t
    roam  (a -> b) -> s -> t
    f (IxStar i -> a -> Identity' b
    k) =
        (i -> s -> Identity' t) -> IxStar Identity' i s t
    forall (f :: * -> *) i a b. (i -> a -> f b) -> IxStar f i a b
    IxStar ((i -> s -> Identity' t) -> IxStar Identity' i s t)
    -> (i -> s -> Identity' t) -> IxStar Identity' i s t
    forall a b. (a -> b) -> a -> b
    $ \i
    i -> t -> Identity' t
    forall a. a -> Identity' a
    wrapIdentity' (t -> Identity' t) -> (s -> t) -> s -> Identity' t
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (a -> b) -> s -> t
    f (Identity' b -> b
    forall a. Identity' a -> a
    unwrapIdentity' (Identity' b -> b) -> (a -> Identity' b) -> a -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . i -> a -> Identity' b
    k i
    i)
      iroam :: forall i a b s t j.
    ((i -> a -> b) -> s -> t)
    -> IxStar Identity' j a b -> IxStar Identity' (i -> j) s t
    iroam (i -> a -> b) -> s -> t
    f (IxStar j -> a -> Identity' b
    k) =
        ((i -> j) -> s -> Identity' t) -> IxStar Identity' (i -> j) s t
    forall (f :: * -> *) i a b. (i -> a -> f b) -> IxStar f i a b
    IxStar (((i -> j) -> s -> Identity' t) -> IxStar Identity' (i -> j) s t)
    -> ((i -> j) -> s -> Identity' t) -> IxStar Identity' (i -> j) s t
    forall a b. (a -> b) -> a -> b
    $ \i -> j
    ij -> t -> Identity' t
    forall a. a -> Identity' a
    wrapIdentity' (t -> Identity' t) -> (s -> t) -> s -> Identity' t
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (i -> a -> b) -> s -> t
    f (\i
    i -> Identity' b -> b
    forall a. Identity' a -> a
    unwrapIdentity' (Identity' b -> b) -> (a -> Identity' b) -> a -> b
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . j -> a -> Identity' b
    k (i -> j
    ij i
    i))

    -- | Mark a value for evaluation to whnf.
    --
    -- This allows us to, when applying a setter to a structure, evaluate only the
    -- parts that we modify. If an optic focuses on multiple targets, Applicative
    -- instance of Identity' makes sure that we force evaluation of all of them, but
    -- we leave anything else alone.
    --
    wrapIdentity' :: a -> Identity' a
    wrapIdentity' :: forall a. a -> Identity' a
    wrapIdentity' a
    a = () -> a -> Identity' a
    forall a. () -> a -> Identity' a
    Identity' (a
    a a -> () -> ()
    forall a b. a -> b -> b
    `seq` ()) a
    a

    unwrapIdentity' :: Identity' a -> a
    unwrapIdentity' :: forall a. Identity' a -> a
    unwrapIdentity' (Identity' () a
    a) = a
    a

    ----------------------------------------

    -- | Helper for 'Optics.Fold.traverseOf_' and the like for better
    -- efficiency than the foldr-based version.
    --
    -- Note that the argument @a@ of the result should not be used.
    newtype Traversed f a = Traversed (f a)

    runTraversed :: Functor f => Traversed f a -> f ()
    runTraversed :: forall (f :: * -> *) a. Functor f => Traversed f a -> f ()
    runTraversed (Traversed f a
    fa) = () () -> f a -> f ()
    forall a b. a -> f b -> f a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ f a
    fa

    instance Applicative f => SG.Semigroup (Traversed f a) where
      Traversed f a
    ma <> :: Traversed f a -> Traversed f a -> Traversed f a
    <> Traversed f a
    mb = f a -> Traversed f a
    forall (f :: * -> *) a. f a -> Traversed f a
    Traversed (f a
    ma f a -> f a -> f a
    forall a b. f a -> f b -> f b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> f a
    mb)

    instance Applicative f => Monoid (Traversed f a) where
      mempty :: Traversed f a
    mempty = f a -> Traversed f a
    forall (f :: * -> *) a. f a -> Traversed f a
    Traversed (a -> f a
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Char] -> a
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Traversed: value used"))
      mappend :: Traversed f a -> Traversed f a -> Traversed f a
    mappend = Traversed f a -> Traversed f a -> Traversed f a
    forall a. Semigroup a => a -> a -> a
    (SG.<>)

    ----------------------------------------

    -- | Helper for 'Optics.Fold.failing' family to visit the first fold only once.
    data OrT f a = OrT !Bool (f a)
      deriving (forall a b. (a -> b) -> OrT f a -> OrT f b)
    -> (forall a b. a -> OrT f b -> OrT f a) -> Functor (OrT f)
    forall a b. a -> OrT f b -> OrT f a
    forall a b. (a -> b) -> OrT f a -> OrT f b
    forall (f :: * -> *) a b. Functor f => a -> OrT f b -> OrT f a
    forall (f :: * -> *) a b.
    Functor f =>
    (a -> b) -> OrT f a -> OrT f b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    $cfmap :: forall (f :: * -> *) a b.
    Functor f =>
    (a -> b) -> OrT f a -> OrT f b
    fmap :: forall a b. (a -> b) -> OrT f a -> OrT f b
    $c<$ :: forall (f :: * -> *) a b. Functor f => a -> OrT f b -> OrT f a
    <$ :: forall a b. a -> OrT f b -> OrT f a
    Functor

    instance Applicative f => Applicative (OrT f) where
      pure :: forall a. a -> OrT f a
    pure = Bool -> f a -> OrT f a
    forall (f :: * -> *) a. Bool -> f a -> OrT f a
    OrT Bool
    False (f a -> OrT f a) -> (a -> f a) -> a -> OrT f a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> f a
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure
      OrT Bool
    a f (a -> b)
    f <*> :: forall a b. OrT f (a -> b) -> OrT f a -> OrT f b
    <*> OrT Bool
    b f a
    x = Bool -> f b -> OrT f b
    forall (f :: * -> *) a. Bool -> f a -> OrT f a
    OrT (Bool
    a Bool -> Bool -> Bool
    || Bool
    b) (f (a -> b)
    f f (a -> b) -> f a -> f b
    forall a b. f (a -> b) -> f a -> f b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> f a
    x)

    -- | Wrap the applicative action in 'OrT' so that we know later that it was
    -- executed.
    wrapOrT :: f a -> OrT f a
    wrapOrT :: forall (f :: * -> *) a. f a -> OrT f a
    wrapOrT = Bool -> f a -> OrT f a
    forall (f :: * -> *) a. Bool -> f a -> OrT f a
    OrT Bool
    True

    -- | 'uncurry' with no lazy pattern matching for more efficient code.
    --
    -- @since 0.3
    uncurry' :: (a -> b -> c) -> (a, b) -> c
    uncurry' :: forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry' a -> b -> c
    f (a
    a, b
    b) = a -> b -> c
    f a
    a b
    b