{-# 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(..)
  , Max(..), getMax
  , Min(..), getMin
  , Leftmost(..), getLeftmost
  , Rightmost(..), getRightmost
  , ReifiedMonoid(..)
  -- * Semigroups for folding
  , NonEmptyDList(..)
  ) where

import Control.Applicative
import Control.Lens.Internal.Getter
import Data.Functor.Bind
import Data.Functor.Contravariant
import Data.Maybe
import Data.Semigroup hiding (Min, getMin, Max, getMax)
import Data.Reflection
import Prelude

import qualified Data.List.NonEmpty as NonEmpty

#ifdef HLINT
{-# ANN module "HLint: ignore Avoid lambda" #-}
#endif

------------------------------------------------------------------------------
-- 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 fr :: f a
fr <> :: Folding f a -> Folding f a -> Folding f a
<> Folding fs :: 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 fr :: f a
fr mappend :: Folding f a -> Folding f a -> Folding f a
`mappend` Folding fs :: 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 ma :: f a
ma <> :: Traversed a f -> Traversed a f -> Traversed a f
<> Traversed mb :: 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 "Traversed: value used"))
  {-# INLINE mempty #-}
  Traversed ma :: f a
ma mappend :: Traversed a f -> Traversed a f -> Traversed a f
`mappend` Traversed mb :: 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 ma :: f a
ma <> :: TraversedF a f -> TraversedF a f -> TraversedF a f
<> TraversedF mb :: 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 "TraversedF: value used"))
  {-# INLINE mempty #-}
  TraversedF ma :: f a
ma mappend :: TraversedF a f -> TraversedF a f -> TraversedF a f
`mappend` TraversedF mb :: 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 ma :: m a
ma <> :: Sequenced a m -> Sequenced a m -> Sequenced a m
<> Sequenced mb :: 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 "Sequenced: value used"))
  {-# INLINE mempty #-}
  Sequenced ma :: m a
ma mappend :: Sequenced a m -> Sequenced a m -> Sequenced a m
`mappend` Sequenced mb :: 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 #-}

------------------------------------------------------------------------------
-- Min
------------------------------------------------------------------------------

-- | Used for 'Control.Lens.Fold.minimumOf'.
data Min a = NoMin | Min a

instance Ord a => Semigroup (Min a) where
  NoMin <> :: Min a -> Min a -> Min a
<> m :: Min a
m     = Min a
m
  m :: Min a
m <> NoMin     = Min a
m
  Min a :: a
a <> Min b :: a
b = a -> Min a
forall a. a -> Min a
Min (a -> a -> a
forall a. Ord a => a -> a -> a
min a
a a
b)
  {-# INLINE (<>) #-}

instance Ord a => Monoid (Min a) where
  mempty :: Min a
mempty = Min a
forall a. Min a
NoMin
  {-# INLINE mempty #-}
  mappend :: Min a -> Min a -> Min a
mappend NoMin m :: Min a
m = Min a
m
  mappend m :: Min a
m NoMin = Min a
m
  mappend (Min a :: a
a) (Min b :: a
b) = a -> Min a
forall a. a -> Min a
Min (a -> a -> a
forall a. Ord a => a -> a -> a
min a
a a
b)
  {-# INLINE mappend #-}

-- | Obtain the minimum.
getMin :: Min a -> Maybe a
getMin :: Min a -> Maybe a
getMin NoMin   = Maybe a
forall a. Maybe a
Nothing
getMin (Min a :: a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
{-# INLINE getMin #-}

------------------------------------------------------------------------------
-- Max
------------------------------------------------------------------------------

-- | Used for 'Control.Lens.Fold.maximumOf'.
data Max a = NoMax | Max a

instance Ord a => Semigroup (Max a) where
  NoMax <> :: Max a -> Max a -> Max a
<> m :: Max a
m = Max a
m
  m :: Max a
m <> NoMax = Max a
m
  Max a :: a
a <> Max b :: a
b = a -> Max a
forall a. a -> Max a
Max (a -> a -> a
forall a. Ord a => a -> a -> a
max a
a a
b)
  {-# INLINE (<>) #-}

instance Ord a => Monoid (Max a) where
  mempty :: Max a
mempty = Max a
forall a. Max a
NoMax
  {-# INLINE mempty #-}
  mappend :: Max a -> Max a -> Max a
mappend NoMax m :: Max a
m = Max a
m
  mappend m :: Max a
m NoMax = Max a
m
  mappend (Max a :: a
a) (Max b :: a
b) = a -> Max a
forall a. a -> Max a
Max (a -> a -> a
forall a. Ord a => a -> a -> a
max a
a a
b)
  {-# INLINE mappend #-}

-- | Obtain the maximum.
getMax :: Max a -> Maybe a
getMax :: Max a -> Maybe a
getMax NoMax   = Maybe a
forall a. Maybe a
Nothing
getMax (Max a :: a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
{-# INLINE getMax #-}

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

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

instance Semigroup (NonEmptyDList a) where
  NonEmptyDList f :: [a] -> NonEmpty a
f <> :: NonEmptyDList a -> NonEmptyDList a -> NonEmptyDList a
<> NonEmptyDList g :: [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 x :: Leftmost a
x y :: 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
    LPure    -> Leftmost a
y
    LLeaf _  -> Leftmost a
x
    LStep x' :: 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 _|_.
      LPure    -> Leftmost a
x'
      LLeaf a :: 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 y' :: 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 LPure = Maybe a
forall a. Maybe a
Nothing
getLeftmost (LLeaf a :: a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
getLeftmost (LStep x :: 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 x :: Rightmost a
x y :: 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
    RPure    -> Rightmost a
x
    RLeaf _  -> Rightmost a
y
    RStep y' :: 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 _|_.
      RPure    -> Rightmost a
y'
      RLeaf a :: 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 x' :: 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 RPure = Maybe a
forall a. Maybe a
Nothing
getRightmost (RLeaf a :: a
a) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
getRightmost (RStep x :: Rightmost a
x) = Rightmost a -> Maybe a
forall a. Rightmost a -> Maybe a
getRightmost Rightmost a
x