{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Fresnel.Fold
( -- * Folds
  Fold
, IsFold
  -- * Construction
, folded
, unfolded
, folding
, foldring
, ignored
, backwards
  -- * Elimination
, has
, hasn't
, foldMapOf
, foldMapByOf
, foldrOf
, foldlOf'
, foldOf
, sequenceOf_
, traverseOf_
, forOf_
, toListOf
, anyOf
, allOf
, nullOf
, previews
, preview
, (^?)
, Failover(..)
, Union(..)
) where

import Data.Foldable (traverse_)
import Data.Functor.Contravariant
import Data.Monoid
import Data.Profunctor
import Data.Profunctor.Traversing
import Data.Profunctor.Unsafe ((#.), (.#))
import Fresnel.Bifunctor.Contravariant
import Fresnel.Functor.Backwards (Backwards(..))
import Fresnel.Functor.Traversed
import Fresnel.Monoid.Cons as Cons
import Fresnel.Monoid.Fork as Fork
import Fresnel.Monoid.Snoc as Snoc
import Fresnel.Optic
import Fresnel.OptionalFold.Internal (IsOptionalFold)
import Fresnel.Traversal.Internal (IsTraversal)

-- Folds

type Fold s a = forall p . IsFold p => Optic' p s a

class (IsOptionalFold p, IsTraversal p) => IsFold p

instance Monoid r => IsFold (Forget r)
instance (Applicative f, Traversable f, Contravariant f) => IsFold (Star f)


-- Construction

folded :: Foldable f => Fold (f a) a
folded :: Fold (f a) a
folded = p (f a) () -> p (f a) (f a)
forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom (p (f a) () -> p (f a) (f a))
-> (p a a -> p (f a) ()) -> p a a -> p (f a) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> f a -> f ())
-> p a a -> p (f a) ()
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander forall (f :: * -> *). Applicative f => (a -> f a) -> f a -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_

unfolded :: (s -> Maybe (a, s)) -> Fold s a
unfolded :: (s -> Maybe (a, s)) -> Fold s a
unfolded s -> Maybe (a, s)
coalg = p s () -> p s s
forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom (p s () -> p s s) -> (p a a -> p s ()) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> s -> f ())
-> p a a -> p s ()
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander (\ a -> f a
f -> let loop :: s -> f ()
loop = f () -> ((a, s) -> f ()) -> Maybe (a, s) -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\ (a
a, s
s) -> a -> f a
f a
a f a -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> s -> f ()
loop s
s) (Maybe (a, s) -> f ()) -> (s -> Maybe (a, s)) -> s -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Maybe (a, s)
coalg in s -> f ()
loop)

folding :: Foldable f => (s -> f a) -> Fold s a
folding :: (s -> f a) -> Fold s a
folding s -> f a
f = (s -> f a) -> (s -> ()) -> p (f a) () -> p s s
forall (p :: * -> * -> *) a' a b' b.
Bicontravariant p =>
(a' -> a) -> (b' -> b) -> p a b -> p a' b'
contrabimap s -> f a
f (() -> s -> ()
forall a b. a -> b -> a
const ()) (p (f a) () -> p s s) -> (p a a -> p (f a) ()) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() -> ()) -> p (f a) () -> p (f a) ()
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap (() -> () -> ()
forall a b. a -> b -> a
const ()) (p (f a) () -> p (f a) ())
-> (p a a -> p (f a) ()) -> p a a -> p (f a) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> f a -> f ())
-> p a a -> p (f a) ()
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander forall (f :: * -> *). Applicative f => (a -> f a) -> f a -> f ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_

foldring :: (forall f . Applicative f => (a -> f u -> f u) -> f v -> s -> f w) -> Fold s a
foldring :: (forall (f :: * -> *).
 Applicative f =>
 (a -> f u -> f u) -> f v -> s -> f w)
-> Fold s a
foldring forall (f :: * -> *).
Applicative f =>
(a -> f u -> f u) -> f v -> s -> f w
fr = p s w -> p s s
forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom (p s w -> p s s) -> (p a a -> p s w) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> s -> f w)
-> p a a -> p s w
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander (\ a -> f a
f -> (a -> f u -> f u) -> f v -> s -> f w
forall (f :: * -> *).
Applicative f =>
(a -> f u -> f u) -> f v -> s -> f w
fr (\ a
a -> (a -> f a
f a
a f a -> f u -> f u
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>)) (v -> f v
forall (f :: * -> *) a. Applicative f => a -> f a
pure v
forall a. a
v)) where
  v :: a
v = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"foldring: value used"

ignored :: Fold s a
ignored :: Optic' p s a
ignored = (forall (f :: * -> *).
 Applicative f =>
 (a -> f Any -> f Any) -> f Any -> s -> f Any)
-> Fold s a
forall a u v s w.
(forall (f :: * -> *).
 Applicative f =>
 (a -> f u -> f u) -> f v -> s -> f w)
-> Fold s a
foldring (\ a -> f Any -> f Any
_ f Any
nil s
_ -> f Any
nil)

backwards :: Fold s a -> Fold s a
backwards :: Fold s a -> Fold s a
backwards Fold s a
o = p s () -> p s s
forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom (p s () -> p s s) -> (p a a -> p s ()) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f a) -> s -> f ())
-> p a a -> p s ()
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander (\ a -> f a
f -> Backwards f () -> f ()
forall (f :: * -> *) a. Backwards f a -> f a
forwards (Backwards f () -> f ()) -> (s -> Backwards f ()) -> s -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold s a -> (a -> Backwards f a) -> s -> Backwards f ()
forall (f :: * -> *) s a r.
Applicative f =>
Fold s a -> (a -> f r) -> s -> f ()
traverseOf_ Fold s a
o (f a -> Backwards f a
forall (f :: * -> *) a. f a -> Backwards f a
Backwards (f a -> Backwards f a) -> (a -> f a) -> a -> Backwards f a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> f a
f))


-- Elimination

has :: Fold s a -> (s -> Bool)
has :: Fold s a -> s -> Bool
has Fold s a
o = Fold s a -> (a -> Bool) -> s -> Bool
forall s a. Fold s a -> (a -> Bool) -> s -> Bool
anyOf Fold s a
o (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)

hasn't :: Fold s a -> (s -> Bool)
hasn't :: Fold s a -> s -> Bool
hasn't = Fold s a -> s -> Bool
forall s a. Fold s a -> s -> Bool
nullOf


foldMapOf :: Monoid m => Fold s a -> ((a -> m) -> (s -> m))
foldMapOf :: Fold s a -> (a -> m) -> s -> m
foldMapOf Fold s a
o = Forget m s s -> s -> m
forall r a k (b :: k). Forget r a b -> a -> r
runForget (Forget m s s -> s -> m)
-> (Forget m a a -> Forget m s s) -> Forget m a a -> s -> m
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Forget m a a -> Forget m s s
Fold s a
o (Forget m a a -> s -> m)
-> ((a -> m) -> Forget m a a) -> (a -> m) -> s -> m
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# (a -> m) -> Forget m a a
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget

foldMapByOf :: Fold s a -> ((r -> r -> r) -> r -> (a -> r) -> (s -> r))
foldMapByOf :: Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
foldMapByOf Fold s a
o r -> r -> r
fork r
nil a -> r
leaf s
s = Fork a -> (r -> r -> r) -> (a -> r) -> r -> r
forall a. Fork a -> forall r. (r -> r -> r) -> (a -> r) -> r -> r
runFork (Forget (Fork a) s s -> s -> Fork a
forall r a k (b :: k). Forget r a b -> a -> r
runForget (Optic' (Forget (Fork a)) s a
Fold s a
o ((a -> Fork a) -> Forget (Fork a) a a
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget a -> Fork a
forall a. a -> Fork a
Fork.singleton)) s
s) r -> r -> r
fork a -> r
leaf r
nil

foldrOf :: Fold s a -> ((a -> r -> r) -> r -> s -> r)
foldrOf :: Fold s a -> (a -> r -> r) -> r -> s -> r
foldrOf Fold s a
o a -> r -> r
cons r
nil s
s = Cons a -> (a -> r -> r) -> r -> r
forall a. Cons a -> forall r. (a -> r -> r) -> r -> r
runCons (Forget (Cons a) s s -> s -> Cons a
forall r a k (b :: k). Forget r a b -> a -> r
runForget (Optic' (Forget (Cons a)) s a
Fold s a
o ((a -> Cons a) -> Forget (Cons a) a a
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget a -> Cons a
forall a. a -> Cons a
Cons.singleton)) s
s) a -> r -> r
cons r
nil

foldlOf' :: Fold s a -> ((r -> a -> r) -> r -> s -> r)
foldlOf' :: Fold s a -> (r -> a -> r) -> r -> s -> r
foldlOf' Fold s a
o r -> a -> r
snoc r
nil s
s = Snoc a -> (r -> a -> r) -> r -> r
forall a. Snoc a -> forall r. (r -> a -> r) -> r -> r
runSnoc (Forget (Snoc a) s s -> s -> Snoc a
forall r a k (b :: k). Forget r a b -> a -> r
runForget (Optic' (Forget (Snoc a)) s a
Fold s a
o ((a -> Snoc a) -> Forget (Snoc a) a a
forall k r a (b :: k). (a -> r) -> Forget r a b
Forget a -> Snoc a
forall a. a -> Snoc a
Snoc.singleton)) s
s) r -> a -> r
snoc r
nil

foldOf :: Monoid a => Fold s a -> (s -> a)
foldOf :: Fold s a -> s -> a
foldOf Fold s a
o = Fold s a -> (a -> a) -> s -> a
forall m s a. Monoid m => Fold s a -> (a -> m) -> s -> m
foldMapOf Fold s a
o a -> a
forall a. a -> a
id

sequenceOf_ :: Applicative f => Fold s (f a) -> (s -> f ())
sequenceOf_ :: Fold s (f a) -> s -> f ()
sequenceOf_ Fold s (f a)
o = Traversed f a -> f ()
forall (f :: * -> *) a. Functor f => Traversed f a -> f ()
runTraversed (Traversed f a -> f ()) -> (s -> Traversed f a) -> s -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold s (f a) -> (f a -> Traversed f a) -> s -> Traversed f a
forall m s a. Monoid m => Fold s a -> (a -> m) -> s -> m
foldMapOf Fold s (f a)
o f a -> Traversed f a
forall (f :: * -> *) a. f a -> Traversed f a
Traversed

traverseOf_ :: Applicative f => Fold s a -> ((a -> f r) -> (s -> f ()))
traverseOf_ :: Fold s a -> (a -> f r) -> s -> f ()
traverseOf_ Fold s a
o a -> f r
f = Traversed f r -> f ()
forall (f :: * -> *) a. Functor f => Traversed f a -> f ()
runTraversed (Traversed f r -> f ()) -> (s -> Traversed f r) -> s -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold s a -> (a -> Traversed f r) -> s -> Traversed f r
forall m s a. Monoid m => Fold s a -> (a -> m) -> s -> m
foldMapOf Fold s a
o (f r -> Traversed f r
forall (f :: * -> *) a. f a -> Traversed f a
Traversed (f r -> Traversed f r) -> (a -> f r) -> a -> Traversed f r
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> f r
f)

forOf_ :: Applicative f => Fold s a -> (s -> (a -> f r) -> f ())
forOf_ :: Fold s a -> s -> (a -> f r) -> f ()
forOf_ Fold s a
o = ((a -> f r) -> s -> f ()) -> s -> (a -> f r) -> f ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Fold s a -> (a -> f r) -> s -> f ()
forall (f :: * -> *) s a r.
Applicative f =>
Fold s a -> (a -> f r) -> s -> f ()
traverseOf_ Fold s a
o)

toListOf :: Fold s a -> s -> [a]
toListOf :: Fold s a -> s -> [a]
toListOf Fold s a
o = Fold s a -> (a -> [a] -> [a]) -> [a] -> s -> [a]
forall s a r. Fold s a -> (a -> r -> r) -> r -> s -> r
foldrOf Fold s a
o (:) []

anyOf :: Fold s a -> (a -> Bool) -> (s -> Bool)
anyOf :: Fold s a -> (a -> Bool) -> s -> Bool
anyOf Fold s a
o = Fold s a
-> (Bool -> Bool -> Bool) -> Bool -> (a -> Bool) -> s -> Bool
forall s a r. Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
foldMapByOf Fold s a
o Bool -> Bool -> Bool
(||) Bool
False

allOf :: Fold s a -> (a -> Bool) -> (s -> Bool)
allOf :: Fold s a -> (a -> Bool) -> s -> Bool
allOf Fold s a
o = Fold s a
-> (Bool -> Bool -> Bool) -> Bool -> (a -> Bool) -> s -> Bool
forall s a r. Fold s a -> (r -> r -> r) -> r -> (a -> r) -> s -> r
foldMapByOf Fold s a
o Bool -> Bool -> Bool
(&&) Bool
True

nullOf :: Fold s a -> (s -> Bool)
nullOf :: Fold s a -> s -> Bool
nullOf Fold s a
o = Fold s a -> (a -> Bool -> Bool) -> Bool -> s -> Bool
forall s a r. Fold s a -> (a -> r -> r) -> r -> s -> r
foldrOf Fold s a
o (\ a
_ Bool
_ -> Bool
False) Bool
True


previews :: Fold s a -> (a -> r) -> (s -> Maybe r)
previews :: Fold s a -> (a -> r) -> s -> Maybe r
previews Fold s a
o a -> r
f = First r -> Maybe r
forall a. First a -> Maybe a
getFirst (First r -> Maybe r) -> (s -> First r) -> s -> Maybe r
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Fold s a -> (a -> First r) -> s -> First r
forall m s a. Monoid m => Fold s a -> (a -> m) -> s -> m
foldMapOf Fold s a
o (Maybe r -> First r
forall a. Maybe a -> First a
First (Maybe r -> First r) -> (a -> Maybe r) -> a -> First r
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. r -> Maybe r
forall a. a -> Maybe a
Just (r -> Maybe r) -> (a -> r) -> a -> Maybe r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> r
f)

preview :: Fold s a -> s -> Maybe a
preview :: Fold s a -> s -> Maybe a
preview Fold s a
o = Fold s a -> (a -> a) -> s -> Maybe a
forall s a r. Fold s a -> (a -> r) -> s -> Maybe r
previews Fold s a
o a -> a
forall a. a -> a
id

(^?) :: s -> Fold s a -> Maybe a
s
s ^? :: s -> Fold s a -> Maybe a
^? Fold s a
o = Fold s a -> s -> Maybe a
forall s a. Fold s a -> s -> Maybe a
preview Fold s a
o s
s

infixl 8 ^?


newtype Failover s a = Failover { Failover s a -> forall (p :: * -> * -> *). IsFold p => Optic' p s a
getFailover :: Fold s a }

instance Semigroup (Failover s a) where
  Failover Fold s a
a1 <> :: Failover s a -> Failover s a -> Failover s a
<> Failover Fold s a
a2 = Fold s a -> Failover s a
forall s a. Fold s a -> Failover s a
Failover ((s -> Cons a) -> Fold s a
forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding (\ s
s -> (forall r. (a -> r -> r) -> r -> r) -> Cons a
forall a. (forall r. (a -> r -> r) -> r -> r) -> Cons a
Cons (\ a -> r -> r
cons r
nil -> r -> ((a, r) -> r) -> Maybe (a, r) -> r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Fold s a -> (a -> r -> r) -> r -> s -> r
forall s a r. Fold s a -> (a -> r -> r) -> r -> s -> r
foldrOf Fold s a
a2 a -> r -> r
cons r
nil s
s) ((a -> r -> r) -> (a, r) -> r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> r -> r
cons) (Fold s a
-> (a -> Maybe (a, r) -> Maybe (a, r))
-> Maybe (a, r)
-> s
-> Maybe (a, r)
forall s a r. Fold s a -> (a -> r -> r) -> r -> s -> r
foldrOf Fold s a
a1 (\ a
a -> (a, r) -> Maybe (a, r)
forall a. a -> Maybe a
Just ((a, r) -> Maybe (a, r))
-> (Maybe (a, r) -> (a, r)) -> Maybe (a, r) -> Maybe (a, r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) a
a (r -> (a, r)) -> (Maybe (a, r) -> r) -> Maybe (a, r) -> (a, r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> ((a, r) -> r) -> Maybe (a, r) -> r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe r
nil ((a -> r -> r) -> (a, r) -> r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> r -> r
cons)) Maybe (a, r)
forall a. Maybe a
Nothing s
s))))

instance Monoid (Failover s a) where
  mempty :: Failover s a
mempty = Fold s a -> Failover s a
forall s a. Fold s a -> Failover s a
Failover forall s a. Fold s a
Fold s a
ignored


newtype Union s a = Union { Union s a -> forall (p :: * -> * -> *). IsFold p => Optic' p s a
getUnion :: Fold s a }

instance Semigroup (Union s a) where
  Union Fold s a
a1 <> :: Union s a -> Union s a -> Union s a
<> Union Fold s a
a2 = Fold s a -> Union s a
forall s a. Fold s a -> Union s a
Union (p s () -> p s s
forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom (p s () -> p s s) -> (p a a -> p s ()) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (f :: * -> *). Applicative f => (a -> f Any) -> s -> f ())
-> p a Any -> p s ()
forall (p :: * -> * -> *) a b s t.
Traversing p =>
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander (\ a -> f Any
f s
s -> Fold s a -> (a -> f Any) -> s -> f ()
forall (f :: * -> *) s a r.
Applicative f =>
Fold s a -> (a -> f r) -> s -> f ()
traverseOf_ Fold s a
a1 a -> f Any
f s
s f () -> f () -> f ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Fold s a -> (a -> f Any) -> s -> f ()
forall (f :: * -> *) s a r.
Applicative f =>
Fold s a -> (a -> f r) -> s -> f ()
traverseOf_ Fold s a
a2 a -> f Any
f s
s) (p a Any -> p s ()) -> (p a a -> p a Any) -> p a a -> p s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a a -> p a Any
forall (p :: * -> * -> *) a b c.
(Profunctor p, Bicontravariant p) =>
p a b -> p a c
rphantom)

instance Monoid (Union s a) where
  mempty :: Union s a
mempty = Fold s a -> Union s a
forall s a. Fold s a -> Union s a
Union forall s a. Fold s a
Fold s a
ignored