    {-# LANGUAGE CPP #-}
    {-# LANGUAGE Rank2Types #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE UndecidableInstances #-}
    {-# OPTIONS_GHC -Wno-redundant-constraints #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Lens.Internal.Fold
    -- Copyright   :  (C) 2012-2016 Edward Kmett
    -- License     :  BSD-style (see the file LICENSE)
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    ----------------------------------------------------------------------------
    module Control.Lens.Internal.Fold
      (
      -- * Monoids for folding
        Folding(..)
      , Traversed(..)
      , TraversedF(..)
      , Sequenced(..)
      , Leftmost(..), getLeftmost
      , Rightmost(..), getRightmost
      , ReifiedMonoid(..)
      -- * Semigroups for folding
      , NonEmptyDList(..)
      ) where

    import Prelude ()

    import Control.Lens.Internal.Getter
    import Control.Lens.Internal.Prelude
    import Data.Functor.Bind
    import Data.Maybe (fromMaybe)
    import Data.Reflection

    import qualified Data.List.NonEmpty as NonEmpty

    ------------------------------------------------------------------------------
    -- Folding
    ------------------------------------------------------------------------------

    -- | A 'Monoid' for a 'Contravariant' 'Applicative'.
    newtype Folding f a = Folding { forall (f :: * -> *) a. Folding f a -> f a
    getFolding :: f a }

    instance (Contravariant f, Applicative f) => Semigroup (Folding f a) where
      Folding f a
    fr <> :: Folding f a -> Folding f a -> Folding f a
    <> Folding f a
    fs = f a -> Folding f a
    forall (f :: * -> *) a. f a -> Folding f a
    Folding (f a
    fr f a -> f a -> f a
    forall a b. f a -> f b -> f b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> f a
    fs)
      {-# INLINE (<>) #-}

    instance (Contravariant f, Applicative f) => Monoid (Folding f a) where
      mempty :: Folding f a
    mempty = f a -> Folding f a
    forall (f :: * -> *) a. f a -> Folding f a
    Folding f a
    forall (f :: * -> *) a. (Contravariant f, Applicative f) => f a
    noEffect
      {-# INLINE mempty #-}
    #if !(MIN_VERSION_base(4,11,0))
      Folding fr `mappend` Folding fs = Folding (fr *> fs)
      {-# INLINE mappend #-}
    #endif

    ------------------------------------------------------------------------------
    -- Traversed
    ------------------------------------------------------------------------------

    -- | Used internally by 'Control.Lens.Traversal.traverseOf_' and the like.
    --
    -- The argument 'a' of the result should not be used!
    newtype Traversed a f = Traversed { forall a (f :: * -> *). Traversed a f -> f a
    getTraversed :: f a }

    -- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
    instance Applicative f => Semigroup (Traversed a f) where
      Traversed f a
    ma <> :: Traversed a f -> Traversed a f -> Traversed a f
    <> Traversed f a
    mb = f a -> Traversed a f
    forall a (f :: * -> *). f a -> Traversed a f
    Traversed (f a
    ma f a -> f a -> f a
    forall a b. f a -> f b -> f b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> f a
    mb)
      {-# INLINE (<>) #-}

    instance Applicative f => Monoid (Traversed a f) where
      mempty :: Traversed a f
    mempty = f a -> Traversed a f
    forall a (f :: * -> *). f a -> Traversed a f
    Traversed (a -> f a
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Char] -> a
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Traversed: value used"))
      {-# INLINE mempty #-}
    #if !(MIN_VERSION_base(4,11,0))
      Traversed ma `mappend` Traversed mb = Traversed (ma *> mb)
      {-# INLINE mappend #-}
    #endif

    ------------------------------------------------------------------------------
    -- TraversedF
    ------------------------------------------------------------------------------

    -- | Used internally by 'Control.Lens.Fold.traverse1Of_' and the like.
    --
    -- @since 4.16
    newtype TraversedF a f = TraversedF { forall a (f :: * -> *). TraversedF a f -> f a
    getTraversedF :: f a }

    instance Apply f => Semigroup (TraversedF a f) where
      TraversedF f a
    ma <> :: TraversedF a f -> TraversedF a f -> TraversedF a f
    <> TraversedF f a
    mb = f a -> TraversedF a f
    forall a (f :: * -> *). f a -> TraversedF a f
    TraversedF (f a
    ma f a -> f a -> f a
    forall a b. f a -> f b -> f b
    forall (f :: * -> *) a b. Apply f => f a -> f b -> f b
    .> f a
    mb)
      {-# INLINE (<>) #-}

    instance (Apply f, Applicative f) => Monoid (TraversedF a f) where
      mempty :: TraversedF a f
    mempty = f a -> TraversedF a f
    forall a (f :: * -> *). f a -> TraversedF a f
    TraversedF (a -> f a
    forall a. a -> f a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ([Char] -> a
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "TraversedF: value used"))
      {-# INLINE mempty #-}
    #if !(MIN_VERSION_base(4,11,0))
      TraversedF ma `mappend` TraversedF mb = TraversedF (ma *> mb)
      {-# INLINE mappend #-}
    #endif

    ------------------------------------------------------------------------------
    -- Sequenced
    ------------------------------------------------------------------------------

    -- | Used internally by 'Control.Lens.Traversal.mapM_' and the like.
    --
    -- The argument 'a' of the result should not be used!
    --
    -- See 4.16 Changelog entry for the explanation of "why not Apply f =>"?
    newtype Sequenced a m = Sequenced { forall a (m :: * -> *). Sequenced a m -> m a
    getSequenced :: m a }

    instance Monad m => Semigroup (Sequenced a m) where
      Sequenced m a
    ma <> :: Sequenced a m -> Sequenced a m -> Sequenced a m
    <> Sequenced m a
    mb = m a -> Sequenced a m
    forall a (m :: * -> *). m a -> Sequenced a m
    Sequenced (m a
    ma m a -> m a -> m a
    forall a b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> m a
    mb)
      {-# INLINE (<>) #-}

    instance Monad m => Monoid (Sequenced a m) where
      mempty :: Sequenced a m
    mempty = m a -> Sequenced a m
    forall a (m :: * -> *). m a -> Sequenced a m
    Sequenced (a -> m a
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Char] -> a
    forall a. HasCallStack => [Char] -> a
    error [Char]
    "Sequenced: value used"))
      {-# INLINE mempty #-}
    #if !(MIN_VERSION_base(4,11,0))
      Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb)
      {-# INLINE mappend #-}
    #endif

    ------------------------------------------------------------------------------
    -- NonEmptyDList
    ------------------------------------------------------------------------------

    newtype NonEmptyDList a
      = NonEmptyDList { forall a. NonEmptyDList a -> [a] -> NonEmpty a
    getNonEmptyDList :: [a] -> NonEmpty.NonEmpty a }

    instance Semigroup (NonEmptyDList a) where
      NonEmptyDList [a] -> NonEmpty a
    f <> :: NonEmptyDList a -> NonEmptyDList a -> NonEmptyDList a
    <> NonEmptyDList [a] -> NonEmpty a
    g = ([a] -> NonEmpty a) -> NonEmptyDList a
    forall a. ([a] -> NonEmpty a) -> NonEmptyDList a
    NonEmptyDList ([a] -> NonEmpty a
    f ([a] -> NonEmpty a) -> ([a] -> [a]) -> [a] -> NonEmpty a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . NonEmpty a -> [a]
    forall a. NonEmpty a -> [a]
    NonEmpty.toList (NonEmpty a -> [a]) -> ([a] -> NonEmpty a) -> [a] -> [a]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [a] -> NonEmpty a
    g)

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

    -- | Used for 'Control.Lens.Fold.firstOf'.
    data Leftmost a = LPure | LLeaf a | LStep (Leftmost a)

    instance 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 firstOf 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 _ -> 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 -> Leftmost a -> Leftmost a
    forall a. Monoid a => a -> a -> a
    mappend Leftmost a
    x' Leftmost a
    y'

    instance Monoid (Leftmost a) where
      mempty :: Leftmost a
    mempty = Leftmost a
    forall a. Leftmost a
    LPure
      {-# INLINE mempty #-}
    #if !(MIN_VERSION_base(4,11,0))
      mappend = (<>)
      {-# INLINE mappend #-}
    #endif

    -- | 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 = 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
    getLeftmost Leftmost a
    x

    -- | Used for 'Control.Lens.Fold.lastOf'.
    data Rightmost a = RPure | RLeaf a | RStep (Rightmost a)

    instance 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 _ -> 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
      {-# INLINE mempty #-}
    #if !(MIN_VERSION_base(4,11,0))
      mappend = (<>)
      {-# INLINE mappend #-}
    #endif

    -- | 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 = 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
    getRightmost Rightmost a
    x