{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Data.Profunctor.Optic.Fold (
Fold
, Ixfold
, fold_
, folding
, foldVl
, ifoldVl
, afold
, aifold
, Fold1
, Ixfold1
, fold1_
, folding1
, fold1Vl
, ifold1Vl
, afold1
, aifold1
, folded
, folded_
, folded1
, folded1_
, ifolded
, ifoldedRep
, ifolded1
, aifolded
, aifolded1
, withFold
, withIxfold
, withFold1
, withIxfold1
, lists
, (^..)
, ilists
, ilistsFrom
, (^%%)
, nelists
, folds
, ifolds
, folds1
, foldsa
, foldsr
, ifoldsr
, ifoldsrFrom
, foldsl
, ifoldsl
, ifoldslFrom
, foldsr'
, ifoldsr'
, foldsl'
, ifoldsl'
, foldsrM
, ifoldsrM
, foldslM
, ifoldslM
, traverses_
, itraverses_
, Nedl(..)
) where
import Control.Monad (void)
import Control.Monad.Reader as Reader hiding (lift)
import Data.Foldable (Foldable, foldMap, traverse_)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Key as K
import Data.Monoid
import Data.Semiring as Rng
import Data.Profunctor.Optic.Carrier
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Traversal
import Data.Profunctor.Optic.Types
import Data.Profunctor.Optic.View
import qualified Data.Functor.Rep as F
import qualified Data.List.NonEmpty as NEL
fold_ :: Foldable f => (s -> f a) -> Fold s a
fold_ f = to f . foldVl traverse_
{-# INLINE fold_ #-}
folding :: Traversable f => (s -> a) -> Fold (f s) a
folding f = foldVl traverse . to f
{-# INLINE folding #-}
foldVl :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Fold s a
foldVl f = coercer . traversalVl f . coercer
{-# INLINE foldVl #-}
ifoldVl :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t) -> Ixfold i s a
ifoldVl f = coercer . itraversalVl f . coercer
{-# INLINE ifoldVl #-}
afold :: Monoid r => ((a -> r) -> s -> r) -> APrimView r s t a b
afold f = Star #. (Const #.) #. f .# (getConst #.) .# runStar
{-# INLINE afold #-}
aifold :: Monoid r => ((i -> a -> r) -> s -> r) -> AIxfold r i s a
aifold f = afold $ \iar s -> f (curry iar) $ snd s
{-# INLINE aifold #-}
fold1_ :: Foldable1 f => (s -> f a) -> Fold1 s a
fold1_ f = to f . fold1Vl traverse1_
{-# INLINE fold1_ #-}
folding1 :: Traversable1 f => (s -> a) -> Fold1 (f s) a
folding1 f = fold1Vl traverse1 . to f
{-# INLINE folding1 #-}
fold1Vl :: (forall f. Apply f => (a -> f b) -> s -> f t) -> Fold1 s a
fold1Vl f = coercer . repn f . coercer
{-# INLINE fold1Vl #-}
ifold1Vl :: (forall f. Apply f => (i -> a -> f b) -> s -> f t) -> Ixfold1 i s a
ifold1Vl f = coercer . itraversal1Vl f . coercer
{-# INLINE ifold1Vl #-}
afold1 :: ((a -> r) -> s -> r) -> APrimView r s t a b
afold1 f = Star #. (Const #.) #. f .# (getConst #.) .# runStar
{-# INLINE afold1 #-}
aifold1 :: ((i -> a -> r) -> s -> r) -> AIxfold1 r i s a
aifold1 f = afold1 $ \iar s -> f (curry iar) $ snd s
{-# INLINE aifold1 #-}
folded :: Traversable f => Fold (f a) a
folded = folding id
{-# INLINE folded #-}
folded_ :: Foldable f => Fold (f a) a
folded_ = fold_ id
{-# INLINE folded_ #-}
folded1 :: Traversable1 f => Fold1 (f a) a
folded1 = folding1 id
{-# INLINE folded1 #-}
folded1_ :: Foldable1 f => Fold1 (f a) a
folded1_ = fold1_ id
{-# INLINE folded1_ #-}
ifolded :: FoldableWithKey f => Ixfold (Key f) (f a) a
ifolded = ifoldVl K.traverseWithKey_
{-# INLINE ifolded #-}
ifoldedRep :: F.Representable f => Traversable f => Ixfold (F.Rep f) (f a) a
ifoldedRep = ifoldVl F.itraverseRep
{-# INLINE ifoldedRep #-}
ifolded1 :: FoldableWithKey1 f => Ixfold1 (Key f) (f a) a
ifolded1 = ifold1Vl K.traverseWithKey1_
{-# INLINE ifolded1 #-}
aifolded :: FoldableWithKey f => Monoid r => AIxfold r (Key f) (f a) a
aifolded = aifold K.foldMapWithKey
{-# INLINE aifolded #-}
aifolded1 :: FoldableWithKey1 f => Semigroup r => AIxfold1 r (Key f) (f a) a
aifolded1 = aifold1 K.foldMapWithKey1
{-# INLINE aifolded1 #-}
withFold :: Monoid r => APrimView r s t a b -> (a -> r) -> s -> r
withFold = withPrimView
{-# INLINE withFold #-}
withIxfold :: Monoid r => AIxfold r i s a -> (i -> a -> r) -> i -> s -> r
withIxfold o f = curry $ withFold o (uncurry f)
{-# INLINE withIxfold #-}
withFold1 :: Semigroup r => APrimView r s t a b -> (a -> r) -> s -> r
withFold1 = withPrimView
{-# INLINE withFold1 #-}
withIxfold1 :: Semigroup r => AIxfold1 r i s a -> (i -> a -> r) -> i -> s -> r
withIxfold1 o f = curry $ withFold1 o (uncurry f)
{-# INLINE withIxfold1 #-}
lists :: AFold (Endo [a]) s a -> s -> [a]
lists o = foldsr o (:) []
{-# INLINE lists #-}
infixl 8 ^..
(^..) :: s -> AFold (Endo [a]) s a -> [a]
(^..) = flip lists
{-# INLINE (^..) #-}
ilistsFrom :: AIxfold (Endo [(i, a)]) i s a -> i -> s -> [(i, a)]
ilistsFrom o i = ifoldsrFrom o (\i a -> ((i,a):)) i []
{-# INLINE ilistsFrom #-}
ilists :: (Additive-Monoid) i => AIxfold (Endo [(i, a)]) i s a -> s -> [(i, a)]
ilists o = ifoldsr o (\i a -> ((i,a):)) []
{-# INLINE ilists #-}
infixl 8 ^%%
(^%%) :: (Additive-Monoid) i => s -> AIxfold (Endo [(i, a)]) i s a -> [(i, a)]
(^%%) = flip ilists
{-# INLINE (^%%) #-}
nelists :: AFold1 (Nedl a) s a -> s -> NonEmpty a
nelists l = flip getNedl [] . withFold1 l (Nedl #. (:|))
{-# INLINE nelists #-}
folds :: Monoid a => AFold a s a -> s -> a
folds = flip withFold id
{-# INLINE folds #-}
ifolds :: (Additive-Monoid) i => Monoid a => AIxfold (Additive i, a) i s a -> s -> (i, a)
ifolds o = first unAdditive . withIxfold o (\i a -> (Additive i, a)) zero
{-# INLINE ifolds #-}
folds1 :: Semigroup a => AFold1 a s a -> s -> a
folds1 = flip withFold1 id
{-# INLINE folds1 #-}
foldsa :: Applicative f => Monoid (f a) => AFold (f a) s a -> s -> f a
foldsa = flip withFold pure
{-# INLINE foldsa #-}
foldsr :: AFold (Endo r) s a -> (a -> r -> r) -> r -> s -> r
foldsr o f r = (`appEndo` r) . withFold o (Endo . f)
{-# INLINE foldsr #-}
ifoldsr :: (Additive-Monoid) i => AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> r -> s -> r
ifoldsr o f = ifoldsrFrom o f zero
{-# INLINE ifoldsr #-}
ifoldsrFrom :: AIxfold (Endo r) i s a -> (i -> a -> r -> r) -> i -> r -> s -> r
ifoldsrFrom o f i r = (`appEndo` r) . withIxfold o (\j -> Endo . f j) i
{-# INLINE ifoldsrFrom #-}
foldsl :: AFold ((Endo-Dual) r) s a -> (r -> a -> r) -> r -> s -> r
foldsl o f r = (`appEndo` r) . getDual . withFold o (Dual . Endo . flip f)
{-# INLINE foldsl #-}
ifoldsl :: (Additive-Monoid) i => AIxfold ((Endo-Dual) r) i s a -> (i -> r -> a -> r) -> r -> s -> r
ifoldsl o f = ifoldslFrom o f zero
{-# INLINE ifoldsl #-}
ifoldslFrom :: AIxfold ((Endo-Dual) r) i s a -> (i -> r -> a -> r) -> i -> r -> s -> r
ifoldslFrom o f i r = (`appEndo` r) . getDual . withIxfold o (\i -> Dual . Endo . flip (f i)) i
{-# INLINE ifoldslFrom #-}
foldsr' :: AFold ((Endo-Dual) (Endo r)) s a -> (a -> r -> r) -> r -> s -> r
foldsr' l f z0 xs = foldsl l f' (Endo id) xs `appEndo` z0 where f' (Endo k) x = Endo $ \ z -> k $! f x z
{-# INLINE foldsr' #-}
ifoldsr' :: (Additive-Monoid) i => AIxfold ((Endo-Dual) (r -> r)) i s a -> (i -> a -> r -> r) -> r -> s -> r
ifoldsr' l f z0 xs = ifoldsl l f' id xs z0 where f' i k x z = k $! f i x z
{-# INLINE ifoldsr' #-}
foldsl' :: AFold ((Endo-Endo) r) s a -> (r -> a -> r) -> r -> s -> r
foldsl' o f r s = foldsr o f' (Endo id) s `appEndo` r where f' x (Endo k) = Endo $ \z -> k $! f z x
{-# INLINE foldsl' #-}
ifoldsl' :: (Additive-Monoid) i => AIxfold (Endo (r -> r)) i s a -> (i -> r -> a -> r) -> r -> s -> r
ifoldsl' l f z0 xs = ifoldsr l f' id xs z0 where f' i x k z = k $! f i z x
{-# INLINE ifoldsl' #-}
foldsrM :: Monad m => AFold ((Endo-Dual) (r -> m r)) s a -> (a -> r -> m r) -> r -> s -> m r
foldsrM l f z0 xs = foldsl l f' return xs z0 where f' k x z = f x z >>= k
{-# INLINE foldsrM #-}
ifoldsrM :: (Additive-Monoid) i => Monad m => AIxfold ((Endo-Dual) (r -> m r)) i s a -> (i -> a -> r -> m r) -> r -> s -> m r
ifoldsrM o f z0 xs = ifoldsl o f' return xs z0 where f' i k x z = f i x z >>= k
{-# INLINE ifoldsrM #-}
foldslM :: Monad m => AFold (Endo (r -> m r)) s a -> (r -> a -> m r) -> r -> s -> m r
foldslM o f z0 xs = foldsr o f' return xs z0 where f' x k z = f z x >>= k
{-# INLINE foldslM #-}
ifoldslM :: (Additive-Monoid) i => Monad m => AIxfold (Endo (r -> m r)) i s a -> (i -> r -> a -> m r) -> r -> s -> m r
ifoldslM o f z0 xs = ifoldsr o f' return xs z0 where f' i x k z = f i z x >>= k
{-# INLINE ifoldslM #-}
traverses_ :: Applicative f => AFold (Endo (f ())) s a -> (a -> f r) -> s -> f ()
traverses_ p f = foldsr p (\a fu -> void (f a) *> fu) (pure ())
{-# INLINE traverses_ #-}
itraverses_ :: (Additive-Monoid) i => Applicative f => AIxfold (Endo (f ())) i s a -> (i -> a -> f r) -> s -> f ()
itraverses_ p f = ifoldsr p (\i a fu -> void (f i a) *> fu) (pure ())
{-# INLINE itraverses_ #-}
newtype Nedl a = Nedl { getNedl :: [a] -> NEL.NonEmpty a }
instance Semigroup (Nedl a) where
Nedl f <> Nedl g = Nedl (f . NEL.toList . g)