module Data.Profunctor.Optic.Fold where import Control.Foldl (EndoM(..)) import Control.Monad ((<=<)) import Data.Foldable (Foldable, foldMap, traverse_) import Data.Functor.Foldable (Recursive, Base) import Data.Monoid import Data.Prd (Prd(..), Min(..), Max(..)) import Data.Prd.Lattice (Lattice(..)) import Data.Profunctor.Optic.Prelude hiding (min, max, join) import Data.Profunctor.Optic.Traversal import Data.Profunctor.Optic.Type import Data.Profunctor.Optic.View (to, view, cloneView) import qualified Control.Foldl as L import qualified Data.Functor.Foldable as F import qualified Data.Prd as Prd import qualified Data.Prd.Lattice as Lat import qualified Prelude as Pre --------------------------------------------------------------------- -- 'Fold' --------------------------------------------------------------------- -- | Transform a Van Laarhoven 'Fold' into a profunctor 'Fold'. -- foldVL :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> Fold s a foldVL f = coercer . lift f . coercer {-# INLINE foldVL #-} -- | Obtain a 'Fold' using a 'Traversable' functor. -- -- @ -- 'folded' f ≡ 'lift' 'traverse' . 'to' f -- @ -- folded :: Traversable f => (s -> a) -> Fold (f s) a folded f = traversed . to f {-# INLINE folded #-} -- | Obtain a 'Fold' by lifting an operation that returns a 'Foldable' result. -- -- @ -- 'folding' ('toListOf' o) ≡ o -- @ -- -- This can be useful to lift operations from @Data.List@ and elsewhere into a 'Fold'. -- -- >>> [1,2,3,4] ^.. folding tail -- [2,3,4] -- -- -- See 'Data.Profunctor.Optic.Property'. -- folding :: Foldable f => (s -> f a) -> Fold s a folding f = coercer . lmap f . lift traverse_ {-# INLINE folding #-} -- | TODO: Document -- folding' :: Foldable f => Fold (f a) a folding' = folding id {-# INLINE folding' #-} -- | Build a 'Fold' from a 'View'. -- toFold :: AView s a -> Fold0 s a toFold = to . view {-# INLINE toFold #-} -- | Build a monoidal 'View' from a 'Fold'. -- fromFold :: Monoid a => AFold a s a -> View s a fromFold = cloneView {-# INLINE fromFold #-} --------------------------------------------------------------------- -- 'FoldRep' --------------------------------------------------------------------- -- | TODO: Document -- afold :: Monoid r => ((a -> r) -> s -> r) -> AFold r s a afold = between (Star . (Const .)) ((getConst .) . runStar) -- | TODO: Document -- afold' :: Foldable f => AFold r (f a) a afold' = afold foldMap {- import Data.Functor.Foldable (ListF(..)) fromListF :: Num a => ListF a (Sum a) -> Sum a fromListF Nil = mempty fromListF (Cons a r) = Sum a <> r foldMapOf (recursing) fromListF $ [1..5] Sum {getSum = 15} -} -- | TODO: Document -- recursing :: Recursive s => AFold a s (Base s a) recursing = afold F.fold --------------------------------------------------------------------- -- Primitive operators --------------------------------------------------------------------- -- | Map parts of a structure to a monoid and combine the results. -- -- @ -- 'Data.Foldable.foldMap' = 'foldMapOf' 'folding'' -- @ -- -- >>> foldMapOf both id (["foo"], ["bar", "baz"]) -- ["foo","bar","baz"] -- -- @ -- 'foldMapOf' :: 'Iso'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Lens'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Prism'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Traversal'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Traversal0'' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Monoid' r => 'Fold' s a -> (a -> r) -> s -> r -- 'foldMapOf' :: 'Semigroup' r => 'Fold1' s a -> (a -> r) -> s -> r -- @ -- foldMapOf :: Monoid r => AFold r s a -> (a -> r) -> s -> r foldMapOf = between ((getConst .) . runStar) (Star . (Const .)) -- | Collect the foci of a `Fold` into a list. -- toListOf :: AFold (Endo [a]) s a -> s -> [a] toListOf o = foldrOf o (:) [] -- | TODO: Document -- foldOf :: Monoid a => AFold a s a -> s -> a foldOf = flip foldMapOf id -- ^ @ -- toPureOf :: Fold s a -> s -> [a] -- toPureOf :: Applicative f => Setter s t a b -> s -> f a -- @ toPureOf :: Applicative f => Monoid (f a) => AFold (f a) s a -> s -> f a toPureOf o = foldMapOf o pure -- | Right fold lift a 'Fold'. -- -- >>> foldrOf'' folded (<>) (zero :: Int) [1..5] -- 15 -- foldrOf :: AFold (Endo r) s a -> (a -> r -> r) -> r -> s -> r foldrOf p f r = (`appEndo` r) . foldMapOf p (Endo . f) -- | Left fold lift a 'Fold'. -- foldlOf :: AFold (Dual (Endo c)) s a -> (c -> a -> c) -> c -> s -> c foldlOf p f r = (`appEndo` r) . getDual . foldMapOf p (Dual . Endo . flip f) -- | Fold lift the elements of a structure, associating to the left, but strictly. -- -- @ -- 'Data.Foldable.foldl'' ≡ 'foldlOf'' 'folded' -- @ -- -- @ -- 'foldlOf'' :: 'Iso'' s a -> (c -> a -> c) -> c -> s -> c -- 'foldlOf'' :: 'Lens'' s a -> (c -> a -> c) -> c -> s -> c -- 'foldlOf'' :: 'View' s a -> (c -> a -> c) -> c -> s -> c -- 'foldlOf'' :: 'Fold' s a -> (c -> a -> c) -> c -> s -> c -- 'foldlOf'' :: 'Traversal'' s a -> (c -> a -> c) -> c -> s -> c -- 'foldlOf'' :: 'Traversal0'' s a -> (c -> a -> c) -> c -> s -> c -- @ -- foldlOf' :: AFold (Endo (Endo c)) s a -> (c -> a -> c) -> c -> s -> c foldlOf' o f c s = foldrOf o f' (Endo id) s `appEndo` c where f' x (Endo k) = Endo $ \z -> k $! f z x {-# INLINE foldlOf' #-} -- | TODO: Document -- foldMlOf' :: Monad m => AFold (Endo (EndoM m r)) s a -> (r -> a -> m r) -> r -> s -> m r foldMlOf' o f c s = foldrOf o f' mempty s `appEndoM` c where f' x (EndoM k) = EndoM $ \z -> (f $! z) x >>= k -- | TODO: Document -- toEndoOf :: AFold (Endo (a -> a)) s (a -> a) -> s -> a -> a toEndoOf o = foldrOf o (.) id -- | TODO: Document -- toEndoMOf :: Monad m => AFold (Endo (a -> m a)) s (a -> m a) -> s -> a -> m a toEndoMOf o = foldrOf o (<=<) pure --------------------------------------------------------------------- -- Derived operators --------------------------------------------------------------------- infixl 8 ^.. -- | Infix version of 'toListOf'. -- -- @ -- 'Data.Foldable.toList' xs ≡ xs '^..' 'folded' -- ('^..') ≡ 'flip' 'toListOf' -- @ -- -- >>> [[1,2],[3]] ^.. id -- [[[1,2],[3]]] -- >>> [[1,2],[3]] ^.. traversed -- [[1,2],[3]] -- >>> [[1,2],[3]] ^.. traversed . traversed -- [1,2,3] -- -- >>> (1,2) ^.. bitraversed -- [1,2] -- -- @ -- ('^..') :: s -> 'View' s a -> [a] -- ('^..') :: s -> 'Fold' s a -> [a] -- ('^..') :: s -> 'Lens'' s a -> [a] -- ('^..') :: s -> 'Iso'' s a -> [a] -- ('^..') :: s -> 'Traversal'' s a -> [a] -- ('^..') :: s -> 'Prism'' s a -> [a] -- ('^..') :: s -> 'Traversal0'' s a -> [a] -- @ -- (^..) :: s -> AFold (Endo [a]) s a -> [a] (^..) = flip toListOf {-# INLINE (^..) #-} -- | Precompose with a Moore machine. -- premap :: Handler b a -> L.Fold a c -> L.Fold b c premap o (L.Fold h z k) = L.Fold (foldlOf' o h) z k -- | Precompose with an effectful Moore machine. -- premapM :: Monad m => HandlerM m b a -> L.FoldM m a c -> L.FoldM m b c premapM o (L.FoldM h z k) = L.FoldM (foldMlOf' o h) z k -- | TODO: Document -- all :: AFold All s a -> (a -> Bool) -> s -> Bool all o p = getAll . foldMapOf o (All . p) -- | TODO: Document -- any :: AFold Any s a -> (a -> Bool) -> s -> Bool any o p = getAny . foldMapOf o (Any . p) -- | TODO: Document -- null :: AFold All s a -> s -> Bool null o = all o (const False) -- | Determine whether a `Fold` contains a given element. elem :: Eq a => AFold Any s a -> a -> s -> Bool elem p a = any p (== a) -- | Determine whether a `Fold` not contains a given element. notElem :: Eq a => AFold All s a -> a -> s -> Bool notElem p a = all p (/= a) -- | Determine whether a `Fold` has at least one focus. -- has :: AFold Any s a -> s -> Bool has p = getAny . foldMapOf p (const (Any True)) -- | Determine whether a `Fold` does not have a focus. -- hasnt :: AFold All s a -> s -> Bool hasnt p = getAll . foldMapOf p (const (All False)) -- | Find the minimum of a totally ordered set. -- min :: Ord a => AFold (Endo (Endo a)) s a -> a -> s -> a min o = foldlOf' o Pre.min -- | Find the maximum of a totally ordered set. -- max :: Ord a => AFold (Endo (Endo a)) s a -> a -> s -> a max o = foldlOf' o Pre.max -- | Find the (partial) minimum of a partially ordered set. -- pmin :: Eq a => Prd a => AFold (Endo (EndoM Maybe a)) s a -> a -> s -> Maybe a pmin o = foldMlOf' o Prd.pmin -- | Find the (partial) minimum of a partially ordered set. -- pmax :: Eq a => Prd a => AFold (Endo (EndoM Maybe a)) s a -> a -> s -> Maybe a pmax o = foldMlOf' o Prd.pmax -- | Find the (partial) join of a sublattice. -- join :: Lattice a => AFold (Endo (Endo a)) s a -> a -> s -> a join o = foldlOf' o (\/) -- | Find the join of a sublattice or return the bottom. -- join' :: Lattice a => Min a => AFold (Endo (Endo a)) s a -> s -> a join' o = join o minimal -- | Find the (partial) meet of a sublattice. -- meet :: Lattice a => AFold (Endo (Endo a)) s a -> a -> s -> a meet o = foldlOf' o (/\) -- | Find the meet of a sublattice or return the top. -- meet' :: Lattice a => Max a => AFold (Endo (Endo a)) s a -> s -> a meet' o = meet o maximal