{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 711
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

-----------------------------------------------------------------------------
-- |
-- 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 { 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 (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 #-}
  Folding f a
fr mappend :: Folding f a -> Folding f a -> Folding f a
`mappend` 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
fs)
  {-# INLINE mappend #-}

------------------------------------------------------------------------------
-- 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 { 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Traversed: value used"))
  {-# INLINE mempty #-}
  Traversed f a
ma mappend :: Traversed a f -> Traversed a f -> Traversed a f
`mappend` 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
mb)
  {-# INLINE mappend #-}

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

-- | Used internally by 'Control.Lens.Fold.traverse1Of_' and the like.
--
-- @since 4.16
newtype TraversedF a f = TraversedF { 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"TraversedF: value used"))
  {-# INLINE mempty #-}
  TraversedF f a
ma mappend :: TraversedF a f -> TraversedF a f -> TraversedF a f
`mappend` 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> f a
mb)
  {-# INLINE mappend #-}

------------------------------------------------------------------------------
-- 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 { 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Sequenced: value used"))
  {-# INLINE mempty #-}
  Sequenced m a
ma mappend :: Sequenced a m -> Sequenced a m -> Sequenced a m
`mappend` 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
mb)
  {-# INLINE mappend #-}

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

newtype NonEmptyDList a
  = NonEmptyDList { 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 -> Leftmost a -> Leftmost a
(<>) = Leftmost a -> Leftmost a -> Leftmost a
forall a. Monoid a => a -> a -> a
mappend
  {-# INLINE (<>) #-}

instance Monoid (Leftmost a) where
  mempty :: Leftmost a
mempty = Leftmost a
forall a. Leftmost a
LPure
  {-# INLINE mempty #-}
  mappend :: Leftmost a -> Leftmost a -> Leftmost a
mappend Leftmost a
x 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 _ -> 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 -> Leftmost a -> Leftmost a
forall a. Monoid a => a -> a -> a
mappend Leftmost a
x' Leftmost a
y'

-- | 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
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 -> Rightmost a -> Rightmost a
(<>) = Rightmost a -> Rightmost a -> Rightmost a
forall a. Monoid a => a -> a -> a
mappend
  {-# INLINE (<>) #-}

instance Monoid (Rightmost a) where
  mempty :: Rightmost a
mempty = Rightmost a
forall a. Rightmost a
RPure
  {-# INLINE mempty #-}
  mappend :: Rightmost a -> Rightmost a -> Rightmost a
mappend Rightmost a
x 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'

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