{-# 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 (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 u) -> s -> f v
f = forall (p :: * -> * -> * -> *) i c a b.
(Profunctor p, Bicontravariant p) =>
p i c a -> p i c b
rphantom forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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__ :: forall (p :: * -> * -> * -> *) (f :: * -> *) i a b.
(Bicontravariant p, Traversing p, Foldable f) =>
Optic__ p i i (f a) (f b) a b
folded__ = 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 (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 (p :: * -> * -> * -> *) a u v s w i t b.
(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
fr = 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 a b. (a -> b) -> a -> b
$ \a -> f Any
f -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Applicative f =>
(a -> f u -> f u) -> f v -> s -> f w
fr (\a
a -> (a -> f Any
f a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {a}. a
v)
  where
    v :: a
v = 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 = forall a. Leftmost a -> Leftmost a
LStep 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  -> forall a. a -> Leftmost a
LLeaf forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe a
a (forall a. Leftmost a -> Maybe a
getLeftmost Leftmost a
x')
      LStep Leftmost a
y' -> Leftmost a
x' forall a. Semigroup a => a -> a -> a
SG.<> Leftmost a
y'

instance Monoid (Leftmost a) where
  mempty :: Leftmost a
mempty  = forall a. Leftmost a
LPure
  mappend :: Leftmost a -> Leftmost a -> Leftmost a
mappend = 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 :: forall a. Leftmost a -> Maybe a
getLeftmost Leftmost a
LPure     = forall a. Maybe a
Nothing
getLeftmost (LLeaf a
a) = forall a. a -> Maybe a
Just a
a
getLeftmost (LStep Leftmost a
x) = 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     = forall a. Maybe a
Nothing
    go (LLeaf a
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 = forall a. Rightmost a -> Rightmost a
RStep 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  -> forall a. a -> Rightmost a
RLeaf forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe a
a (forall a. Rightmost a -> Maybe a
getRightmost Rightmost a
y')
      RStep Rightmost a
x' -> forall a. Monoid a => a -> a -> a
mappend Rightmost a
x' Rightmost a
y'

instance Monoid (Rightmost a) where
  mempty :: Rightmost a
mempty  = forall a. Rightmost a
RPure
  mappend :: Rightmost a -> Rightmost a -> Rightmost a
mappend = 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 :: forall a. Rightmost a -> Maybe a
getRightmost Rightmost a
RPure     = forall a. Maybe a
Nothing
getRightmost (RLeaf a
a) = forall a. a -> Maybe a
Just a
a
getRightmost (RStep Rightmost a
x) = 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     = forall a. Maybe a
Nothing
    go (RLeaf a
a) = forall a. a -> Maybe a
Just a
a
    go (RStep Rightmost a
a) = Rightmost a -> Maybe a
go Rightmost a
a