{-# LANGUAGE RankNTypes #-}
module Fresnel.OptionalFold
( -- * Optional folds
  OptionalFold
, IsOptionalFold
  -- * Construction
, folding
, filtered
  -- * Elimination
, is
, isn't
, traverseOf_
, Failover(..)
) where

import Control.Applicative ((<|>))
import Data.Functor (void)
import Data.Maybe (isJust, isNothing)
import Data.Profunctor
import Fresnel.Bifunctor.Contravariant
import Fresnel.Fold (preview)
import Fresnel.Optic
import Fresnel.OptionalFold.Internal

-- Optional folds

type OptionalFold s a = forall p . IsOptionalFold p => Optic' p s a


-- Construction

folding :: (s -> Maybe a) -> OptionalFold s a
folding :: forall s a. (s -> Maybe a) -> OptionalFold s a
folding s -> Maybe a
f = (s -> Either s a)
-> (s -> Either s a) -> p (Either s a) (Either s a) -> p s s
forall (p :: * -> * -> *) a' a b' b.
Bicontravariant p =>
(a' -> a) -> (b' -> b) -> p a b -> p a' b'
contrabimap ((Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
`maybe` a -> Either s a
forall a b. b -> Either a b
Right) (Either s a -> Maybe a -> Either s a)
-> (s -> Either s a) -> s -> Maybe a -> Either s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Either s a
forall a b. a -> Either a b
Left (s -> Maybe a -> Either s a) -> (s -> Maybe a) -> s -> Either s a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> s -> Maybe a
f) s -> Either s a
forall a b. a -> Either a b
Left (p (Either s a) (Either s a) -> p s s)
-> (p a a -> p (Either s a) (Either s a)) -> p a a -> p s s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a a -> p (Either s a) (Either s a)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

filtered :: (a -> Bool) -> OptionalFold a a
filtered :: forall a. (a -> Bool) -> OptionalFold a a
filtered a -> Bool
p = (a -> Maybe a) -> OptionalFold a a
forall s a. (s -> Maybe a) -> OptionalFold s a
folding (\ a
a -> if a -> Bool
p a
a then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing)


-- Elimination

is :: OptionalFold s a -> (s -> Bool)
is :: forall s a. OptionalFold s a -> s -> Bool
is OptionalFold s a
o = Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool) -> (s -> Maybe a) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold s a -> s -> Maybe a
forall s a. Fold s a -> s -> Maybe a
preview OptionalFold s a
Fold s a
o

isn't :: OptionalFold s a -> (s -> Bool)
isn't :: forall s a. OptionalFold s a -> s -> Bool
isn't OptionalFold s a
o = Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> (s -> Maybe a) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fold s a -> s -> Maybe a
forall s a. Fold s a -> s -> Maybe a
preview OptionalFold s a
Fold s a
o

traverseOf_ :: Functor f => OptionalFold s a -> ((forall x . x -> f x) -> (a -> f u) -> (s -> f ()))
traverseOf_ :: forall (f :: * -> *) s a u.
Functor f =>
OptionalFold s a -> (forall x. x -> f x) -> (a -> f u) -> s -> f ()
traverseOf_ OptionalFold s a
o forall x. x -> f x
point a -> f u
f s
s = f () -> (a -> f ()) -> Maybe a -> f ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> f ()
forall x. x -> f x
point ()) (f u -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f u -> f ()) -> (a -> f u) -> a -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f u
f) (Fold s a -> s -> Maybe a
forall s a. Fold s a -> s -> Maybe a
preview OptionalFold s a
Fold s a
o s
s)


newtype Failover s a = Failover { forall s a. Failover s a -> OptionalFold s a
getFailover :: OptionalFold s a }

instance Semigroup (Failover s a) where
  Failover OptionalFold s a
a1 <> :: Failover s a -> Failover s a -> Failover s a
<> Failover OptionalFold s a
a2 = OptionalFold s a -> Failover s a
forall s a. OptionalFold s a -> Failover s a
Failover ((s -> Maybe a) -> OptionalFold s a
forall s a. (s -> Maybe a) -> OptionalFold s a
folding (\ s
s -> Fold s a -> s -> Maybe a
forall s a. Fold s a -> s -> Maybe a
preview OptionalFold s a
Fold s a
a1 s
s Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Fold s a -> s -> Maybe a
forall s a. Fold s a -> s -> Maybe a
preview OptionalFold s a
Fold s a
a2 s
s))