{-# 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

  , (#.)
  , (.#)
  ) 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 a -> Identity' b -> Identity' a
(a -> b) -> Identity' a -> Identity' b
(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
<$ :: a -> Identity' b -> Identity' a
$c<$ :: forall a b. a -> Identity' b -> Identity' a
fmap :: (a -> b) -> Identity' a -> Identity' b
$cfmap :: forall a b. (a -> b) -> Identity' a -> Identity' b
Functor

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

instance Mapping (Star Identity') where
  roam :: ((a -> b) -> s -> t)
-> Star Identity' i a b -> Star Identity' i s t
roam  f :: (a -> b) -> s -> t
f (Star k :: 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 :: ((i -> a -> b) -> s -> t)
-> Star Identity' j a b -> Star Identity' (i -> j) s t
iroam f :: (i -> a -> b) -> s -> t
f (Star k :: 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 (\_ -> 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)
  {-# INLINE roam #-}
  {-# INLINE iroam #-}

instance Mapping (IxStar Identity') where
  roam :: ((a -> b) -> s -> t)
-> IxStar Identity' i a b -> IxStar Identity' i s t
roam  f :: (a -> b) -> s -> t
f (IxStar k :: 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
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 :: ((i -> a -> b) -> s -> t)
-> IxStar Identity' j a b -> IxStar Identity' (i -> j) s t
iroam f :: (i -> a -> b) -> s -> t
f (IxStar k :: 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
$ \ij :: 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
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))
  {-# INLINE roam #-}
  {-# INLINE iroam #-}


-- | 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' :: a -> Identity' a
wrapIdentity' a :: a
a = () -> a -> Identity' a
forall a. () -> a -> Identity' a
Identity' (a
a a -> () -> ()
forall a b. a -> b -> b
`seq` ()) a
a
{-# INLINE wrapIdentity' #-}

unwrapIdentity' :: Identity' a -> a
unwrapIdentity' :: Identity' a -> a
unwrapIdentity' (Identity' () a :: a
a) = a
a
{-# INLINE unwrapIdentity' #-}

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

-- | 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 :: Traversed f a -> f ()
runTraversed (Traversed fa :: f a
fa) = () () -> f a -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
fa
{-# INLINE runTraversed #-}

instance Applicative f => SG.Semigroup (Traversed f a) where
  Traversed ma :: f a
ma <> :: Traversed f a -> Traversed f a -> Traversed f a
<> Traversed mb :: 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
mb)
  {-# INLINE (<>) #-}

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 (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> a
forall a. HasCallStack => [Char] -> a
error "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.<>)
  {-# INLINE mempty #-}
  {-# INLINE mappend #-}

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

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

instance Applicative f => Applicative (OrT f) where
  pure :: 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 (f :: * -> *) a. Applicative f => a -> f a
pure
  OrT a :: Bool
a f :: f (a -> b)
f <*> :: OrT f (a -> b) -> OrT f a -> OrT f b
<*> OrT b :: Bool
b x :: 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
x)
  {-# INLINE pure #-}
  {-# INLINE (<*>) #-}

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