content: {-# 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__ f = rphantom . wander f . 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__ = foldVL__ 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__ fr = foldVL__ $ \f -> void . fr (\a -> (f a *>)) (pure v)
    where
      v = error "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
    x <> y = LStep $ case x of
      LPure    -> y
      LLeaf _  -> x
      LStep x' -> case 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 _|_.
        LPure    -> x'
        LLeaf a  -> LLeaf $ fromMaybe a (getLeftmost x')
        LStep y' -> x' SG.<> y'
  
  instance Monoid (Leftmost a) where
    mempty  = LPure
    mappend = (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 LPure     = Nothing
  getLeftmost (LLeaf a) = Just a
  getLeftmost (LStep x) = go x
    where
      -- Make getLeftmost non-recursive so it might be inlined for LPure/LLeaf.
      go LPure     = Nothing
      go (LLeaf a) = Just a
      go (LStep a) = go 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
    x <> y = RStep $ case y of
      RPure    -> x
      RLeaf _  -> y
      RStep y' -> case 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 _|_.
        RPure    -> y'
        RLeaf a  -> RLeaf $ fromMaybe a (getRightmost y')
        RStep x' -> mappend x' y'
  
  instance Monoid (Rightmost a) where
    mempty  = RPure
    mappend = (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 RPure     = Nothing
  getRightmost (RLeaf a) = Just a
  getRightmost (RStep x) = go x
    where
      -- Make getRightmost non-recursive so it might be inlined for RPure/RLeaf.
      go RPure     = Nothing
      go (RLeaf a) = Just a
      go (RStep a) = go a
  