{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 711
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Control.Lens.Internal.Fold
(
Folding(..)
, Traversed(..)
, TraversedF(..)
, Sequenced(..)
, Max(..), getMax
, Min(..), getMin
, Leftmost(..), getLeftmost
, Rightmost(..), getRightmost
, ReifiedMonoid(..)
, 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
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 #-}
newtype Traversed a f = Traversed { Traversed a f -> f a
getTraversed :: f a }
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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 #-}
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)
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
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'
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
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
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'
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