{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Lens.Internal.Fold
(
Folding(..)
, Traversed(..)
, Sequenced(..)
, Max(..), getMax
, Min(..), getMin
, Leftmost(..), getLeftmost
, Rightmost(..), getRightmost
, ReifiedMonoid(..), M(..)
, reifyFold
) 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
{-# ANN module "HLint: ignore Avoid lambda" #-}
newtype Folding f a = Folding { getFolding :: f a }
instance (Contravariant f, Apply f) => Semigroup (Folding f a) where
Folding fr <> Folding fs = Folding (fr .> fs)
{-# INLINE (<>) #-}
instance (Contravariant f, Applicative f) => Monoid (Folding f a) where
mempty = Folding noEffect
{-# INLINE mempty #-}
Folding fr `mappend` Folding fs = Folding (fr *> fs)
{-# INLINE mappend #-}
newtype Traversed a f = Traversed { getTraversed :: f a }
instance Apply f => Semigroup (Traversed a f) where
Traversed ma <> Traversed mb = Traversed (ma .> mb)
{-# INLINE (<>) #-}
instance Applicative f => Monoid (Traversed a f) where
mempty = Traversed (pure (error "Traversed: value used"))
{-# INLINE mempty #-}
Traversed ma `mappend` Traversed mb = Traversed (ma *> mb)
{-# INLINE mappend #-}
newtype Sequenced a m = Sequenced { getSequenced :: m a }
instance Apply m => Semigroup (Sequenced a m) where
Sequenced ma <> Sequenced mb = Sequenced (ma .> mb)
{-# INLINE (<>) #-}
instance Monad m => Monoid (Sequenced a m) where
mempty = Sequenced (return (error "Sequenced: value used"))
{-# INLINE mempty #-}
Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb)
{-# INLINE mappend #-}
data Min a = NoMin | Min a
instance Ord a => Semigroup (Min a) where
NoMin <> m = m
m <> NoMin = m
Min a <> Min b = Min (min a b)
{-# INLINE (<>) #-}
instance Ord a => Monoid (Min a) where
mempty = NoMin
{-# INLINE mempty #-}
mappend NoMin m = m
mappend m NoMin = m
mappend (Min a) (Min b) = Min (min a b)
{-# INLINE mappend #-}
getMin :: Min a -> Maybe a
getMin NoMin = Nothing
getMin (Min a) = Just a
{-# INLINE getMin #-}
data Max a = NoMax | Max a
instance Ord a => Semigroup (Max a) where
NoMax <> m = m
m <> NoMax = m
Max a <> Max b = Max (max a b)
{-# INLINE (<>) #-}
instance Ord a => Monoid (Max a) where
mempty = NoMax
{-# INLINE mempty #-}
mappend NoMax m = m
mappend m NoMax = m
mappend (Max a) (Max b) = Max (max a b)
{-# INLINE mappend #-}
getMax :: Max a -> Maybe a
getMax NoMax = Nothing
getMax (Max a) = Just a
{-# INLINE getMax #-}
data Leftmost a = LPure | LLeaf a | LStep (Leftmost a)
instance Semigroup (Leftmost a) where
(<>) = mappend
{-# INLINE (<>) #-}
instance Monoid (Leftmost a) where
mempty = LPure
{-# INLINE mempty #-}
mappend x y = LStep $ case x of
LPure -> y
LLeaf _ -> x
LStep x' -> case y of
LPure -> x'
LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x')
LStep y' -> mappend x' y'
getLeftmost :: Leftmost a -> Maybe a
getLeftmost LPure = Nothing
getLeftmost (LLeaf a) = Just a
getLeftmost (LStep x) = getLeftmost x
data Rightmost a = RPure | RLeaf a | RStep (Rightmost a)
instance Semigroup (Rightmost a) where
(<>) = mappend
{-# INLINE (<>) #-}
instance Monoid (Rightmost a) where
mempty = RPure
{-# INLINE mempty #-}
mappend x y = RStep $ case y of
RPure -> x
RLeaf _ -> y
RStep y' -> case x of
RPure -> y'
RLeaf a -> RLeaf $ fromMaybe a (getRightmost y')
RStep x' -> mappend x' y'
getRightmost :: Rightmost a -> Maybe a
getRightmost RPure = Nothing
getRightmost (RLeaf a) = Just a
getRightmost (RStep x) = getRightmost x
data ReifiedMonoid a = ReifiedMonoid { reifiedMappend :: a -> a -> a, reifiedMempty :: a }
instance Reifies s (ReifiedMonoid a) => Monoid (M a s) where
mappend (M x) (M y) = reflectResult (\m -> M (reifiedMappend m x y))
mempty = reflectResult (\m -> M (reifiedMempty m ))
reflectResult :: Reifies s a => (a -> f s) -> f s
reflectResult f = let r = f (reflect r) in r
newtype M a s = M a
unM :: M a s -> proxy s -> a
unM (M a) _ = a
reifyFold :: (a -> a -> a) -> a -> (forall s. Reifies s (ReifiedMonoid a) => t -> M a s) -> t -> a
reifyFold f z m xs = reify (ReifiedMonoid f z) (unM (m xs))