{-# OPTIONS_HADDOCK not-home #-}

-- | Internal implementation details of folds.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Optics.Internal.Fold where

import Data.Functor
import Data.Foldable
import Data.Maybe
import qualified Data.Semigroup as SG

import Data.Profunctor.Indexed

import Optics.Internal.Bi
import Optics.Internal.Optic

-- | Internal implementation of 'Optics.Fold.foldVL'.
foldVL__
  :: (Bicontravariant p, Traversing p)
  => (forall f. Applicative f => (a -> f u) -> s -> f v)
  -> Optic__ p i i s t a b
foldVL__ :: (forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v)
-> Optic__ p i i s t a b
foldVL__ forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v
f = p i s v -> p i s t
forall (p :: * -> * -> * -> *) i c a b.
(Profunctor p, Bicontravariant p) =>
p i c a -> p i c b
rphantom (p i s v -> p i s t)
-> (p i a b -> p i s v) -> Optic__ p i i s t a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v)
-> p i a u -> p i s v
forall (p :: * -> * -> * -> *) a b s t i.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p i a b -> p i s t
wander forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v
f (p i a u -> p i s v) -> (p i a b -> p i a u) -> p i a b -> p i s v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p i a b -> p i a u
forall (p :: * -> * -> * -> *) i c a b.
(Profunctor p, Bicontravariant p) =>
p i c a -> p i c b
rphantom
{-# INLINE foldVL__ #-}

-- | Internal implementation of 'Optics.Fold.folded'.
folded__
  :: (Bicontravariant p, Traversing p, Foldable f)
  => Optic__ p i i (f a) (f b) a b
folded__ :: Optic__ p i i (f a) (f b) a b
folded__ = (forall (f :: * -> *).
 Applicative f =>
 (a -> f Any) -> f a -> f ())
-> Optic__ p i i (f a) (f b) a b
forall (p :: * -> * -> * -> *) a u s v i t b.
(Bicontravariant p, Traversing p) =>
(forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v)
-> Optic__ p i i s t a b
foldVL__ forall (f :: * -> *). Applicative f => (a -> f Any) -> f a -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
{-# INLINE folded__ #-}

-- | Internal implementation of 'Optics.Fold.foldring'.
foldring__
  :: (Bicontravariant p, Traversing p)
  => (forall f. Applicative f => (a -> f u -> f u) -> f v -> s -> f w)
  -> Optic__ p i i s t a b
foldring__ :: (forall (f :: * -> *).
 Applicative f =>
 (a -> f u -> f u) -> f v -> s -> f w)
-> Optic__ p i i s t a b
foldring__ forall (f :: * -> *).
Applicative f =>
(a -> f u -> f u) -> f v -> s -> f w
fr = (forall (f :: * -> *). Applicative f => (a -> f Any) -> s -> f ())
-> Optic__ p i i s t a b
forall (p :: * -> * -> * -> *) a u s v i t b.
(Bicontravariant p, Traversing p) =>
(forall (f :: * -> *). Applicative f => (a -> f u) -> s -> f v)
-> Optic__ p i i s t a b
foldVL__ ((forall (f :: * -> *). Applicative f => (a -> f Any) -> s -> f ())
 -> Optic__ p i i s t a b)
-> (forall (f :: * -> *).
    Applicative f =>
    (a -> f Any) -> s -> f ())
-> Optic__ p i i s t a b
forall a b. (a -> b) -> a -> b
$ \a -> f Any
f -> f w -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f w -> f ()) -> (s -> f w) -> s -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f u -> f u) -> f v -> s -> f w
forall (f :: * -> *).
Applicative f =>
(a -> f u -> f u) -> f v -> s -> f w
fr (\a
a -> (a -> f Any
f a
a f Any -> f u -> f u
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)) (v -> f v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
forall a. a
v)
  where
    v :: a
v = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"foldring__: value used"
{-# INLINE foldring__ #-}

------------------------------------------------------------------------------
-- Leftmost and Rightmost
------------------------------------------------------------------------------

-- | Used for 'Optics.Fold.headOf' and 'Optics.IxFold.iheadOf'.
data Leftmost a = LPure | LLeaf a | LStep (Leftmost a)

instance SG.Semigroup (Leftmost a) where
  Leftmost a
x <> :: Leftmost a -> Leftmost a -> Leftmost a
<> Leftmost a
y = Leftmost a -> Leftmost a
forall a. Leftmost a -> Leftmost a
LStep (Leftmost a -> Leftmost a) -> Leftmost a -> Leftmost a
forall a b. (a -> b) -> a -> b
$ case Leftmost a
x of
    Leftmost a
LPure    -> Leftmost a
y
    LLeaf a
_  -> Leftmost a
x
    LStep Leftmost a
x' -> case Leftmost a
y of
      -- The last two cases make headOf produce a Just as soon as any element is
      -- encountered, and possibly serve as a micro-optimisation; this behaviour
      -- can be disabled by replacing them with _ -> mappend x y'.  Note that
      -- this means that firstOf (backwards folded) [1..] is Just _|_.
      Leftmost a
LPure    -> Leftmost a
x'
      LLeaf a
a  -> a -> Leftmost a
forall a. a -> Leftmost a
LLeaf (a -> Leftmost a) -> a -> Leftmost a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a (Leftmost a -> Maybe a
forall a. Leftmost a -> Maybe a
getLeftmost Leftmost a
x')
      LStep Leftmost a
y' -> Leftmost a
x' Leftmost a -> Leftmost a -> Leftmost a
forall a. Semigroup a => a -> a -> a
SG.<> Leftmost a
y'

instance Monoid (Leftmost a) where
  mempty :: Leftmost a
mempty  = Leftmost a
forall a. Leftmost a
LPure
  mappend :: Leftmost a -> Leftmost a -> Leftmost a
mappend = Leftmost a -> Leftmost a -> Leftmost a
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | Extract the 'Leftmost' element. This will fairly eagerly determine that it
-- can return 'Just' the moment it sees any element at all.
getLeftmost :: Leftmost a -> Maybe a
getLeftmost :: Leftmost a -> Maybe a
getLeftmost Leftmost a
LPure     = Maybe a
forall a. Maybe a
Nothing
getLeftmost (LLeaf a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
getLeftmost (LStep Leftmost a
x) = Leftmost a -> Maybe a
forall a. Leftmost a -> Maybe a
go Leftmost a
x
  where
    -- Make getLeftmost non-recursive so it might be inlined for LPure/LLeaf.
    go :: Leftmost a -> Maybe a
go Leftmost a
LPure     = Maybe a
forall a. Maybe a
Nothing
    go (LLeaf a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
    go (LStep Leftmost a
a) = Leftmost a -> Maybe a
go Leftmost a
a

-- | Used for 'Optics.Fold.lastOf' and 'Optics.IxFold.ilastOf'.
data Rightmost a = RPure | RLeaf a | RStep (Rightmost a)

instance SG.Semigroup (Rightmost a) where
  Rightmost a
x <> :: Rightmost a -> Rightmost a -> Rightmost a
<> Rightmost a
y = Rightmost a -> Rightmost a
forall a. Rightmost a -> Rightmost a
RStep (Rightmost a -> Rightmost a) -> Rightmost a -> Rightmost a
forall a b. (a -> b) -> a -> b
$ case Rightmost a
y of
    Rightmost a
RPure    -> Rightmost a
x
    RLeaf a
_  -> Rightmost a
y
    RStep Rightmost a
y' -> case Rightmost a
x of
      -- The last two cases make lastOf produce a Just as soon as any element is
      -- encountered, and possibly serve as a micro-optimisation; this behaviour
      -- can be disabled by replacing them with _ -> mappend x y'.  Note that
      -- this means that lastOf folded [1..] is Just _|_.
      Rightmost a
RPure    -> Rightmost a
y'
      RLeaf a
a  -> a -> Rightmost a
forall a. a -> Rightmost a
RLeaf (a -> Rightmost a) -> a -> Rightmost a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a (Rightmost a -> Maybe a
forall a. Rightmost a -> Maybe a
getRightmost Rightmost a
y')
      RStep Rightmost a
x' -> Rightmost a -> Rightmost a -> Rightmost a
forall a. Monoid a => a -> a -> a
mappend Rightmost a
x' Rightmost a
y'

instance Monoid (Rightmost a) where
  mempty :: Rightmost a
mempty  = Rightmost a
forall a. Rightmost a
RPure
  mappend :: Rightmost a -> Rightmost a -> Rightmost a
mappend = Rightmost a -> Rightmost a -> Rightmost a
forall a. Semigroup a => a -> a -> a
(SG.<>)

-- | Extract the 'Rightmost' element. This will fairly eagerly determine that it
-- can return 'Just' the moment it sees any element at all.
getRightmost :: Rightmost a -> Maybe a
getRightmost :: Rightmost a -> Maybe a
getRightmost Rightmost a
RPure     = Maybe a
forall a. Maybe a
Nothing
getRightmost (RLeaf a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
getRightmost (RStep Rightmost a
x) = Rightmost a -> Maybe a
forall a. Rightmost a -> Maybe a
go Rightmost a
x
  where
    -- Make getRightmost non-recursive so it might be inlined for RPure/RLeaf.
    go :: Rightmost a -> Maybe a
go Rightmost a
RPure     = Maybe a
forall a. Maybe a
Nothing
    go (RLeaf a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
    go (RStep Rightmost a
a) = Rightmost a -> Maybe a
go Rightmost a
a