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

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

instance Mapping (Star Identity') where
  roam  f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k)
  iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k)
  {-# INLINE roam #-}
  {-# INLINE iroam #-}

instance Mapping (IxStar Identity') where
  roam  f (IxStar k) =
    IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i)
  iroam f (IxStar k) =
    IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij 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 `seq` ()) a
{-# INLINE wrapIdentity' #-}

unwrapIdentity' :: Identity' a -> a
unwrapIdentity' (Identity' () 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 fa) = () <$ fa
{-# INLINE runTraversed #-}

instance Applicative f => SG.Semigroup (Traversed f a) where
  Traversed ma <> Traversed mb = Traversed (ma *> mb)
  {-# INLINE (<>) #-}

instance Applicative f => Monoid (Traversed f a) where
  mempty = Traversed (pure (error "Traversed: value used"))
  mappend = (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 Functor

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