{-|
Module      : Witherable.Lens
Description : Tools for using the Witherable interface with lens
Copyright   : (c) Carl Howells, 2021-2022
License     : MIT
Maintainer  : chowells79@gmail.com

-}
module Witherable.Lens where


import Data.Functor.Identity (Identity(runIdentity))

import Witherable (Witherable(wither))

import Witherable.Lens.Withering


-- | A variant on 'traverse' that allows the targets to be filtered
-- out of the 'Witherable' structure. Note that this introduces a
-- change in types down the lens composition chain, which means that
-- it is not a a valid optic at all.  The use of 'Withering' in the
-- changed type also means that standard lens combinators don't fit
--
-- To address these issues, you can use 'unwithered' to strip the
-- 'Withering' type back out. This allows the composed optic to be
-- used with standard combinators from lens. In addition, the sequence
-- @'withered' . 'unwithered'@ will act like a type-restricted version
-- of 'traverse' for all lawful instances of 'Witherable'.
--
-- In some sense, this is a @catch@-like combinator. This marks the
-- point where removing elements stops propagating and actually
-- modifies the structure being focused.
withered
    :: (Applicative f, Witherable t)
    => (a -> Withering f b) -> t a -> f (t b)
withered :: forall (f :: * -> *) (t :: * -> *) a b.
(Applicative f, Witherable t) =>
(a -> Withering f b) -> t a -> f (t b)
withered a -> Withering f b
f = (a -> f (Maybe b)) -> t a -> f (t b)
forall (t :: * -> *) (f :: * -> *) a b.
(Witherable t, Applicative f) =>
(a -> f (Maybe b)) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f (Maybe b)) -> t a -> f (t b)
wither (Withering f b -> f (Maybe b)
forall (f :: * -> *) a. Withering f a -> f (Maybe a)
runWithering (Withering f b -> f (Maybe b))
-> (a -> Withering f b) -> a -> f (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Withering f b
f)

-- | Restore types in a lens composition chain that has had
-- 'Withering' introduced. Makes no changes to what elements are
-- focused on.
unwithered :: Functor f => (a -> f b) -> a -> Withering f b
unwithered :: forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> a -> Withering f b
unwithered a -> f b
f a
s = f (Maybe b) -> Withering f b
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering ((b -> Maybe b) -> f b -> f (Maybe b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall a. a -> Maybe a
Just (a -> f b
f a
s))

-- | A variant of withered for when you're already working in a
-- Withering chain and want to change what structure elements are
-- being removed from.
--
-- @'rewithered' = 'unwithered' . 'withered'@
rewithered
    :: (Applicative f, Witherable t)
    => (a -> Withering f b) -> t a -> Withering f (t b)
rewithered :: forall (f :: * -> *) (t :: * -> *) a b.
(Applicative f, Witherable t) =>
(a -> Withering f b) -> t a -> Withering f (t b)
rewithered = (t a -> f (t b)) -> t a -> Withering f (t b)
forall (f :: * -> *) a b.
Functor f =>
(a -> f b) -> a -> Withering f b
unwithered ((t a -> f (t b)) -> t a -> Withering f (t b))
-> ((a -> Withering f b) -> t a -> f (t b))
-> (a -> Withering f b)
-> t a
-> Withering f (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Withering f b) -> t a -> f (t b)
forall (f :: * -> *) (t :: * -> *) a b.
(Applicative f, Witherable t) =>
(a -> Withering f b) -> t a -> f (t b)
withered

-- | The trivial optic in a Withering chain that removes everything.
--
-- The arguments are unused.
decayed :: Applicative f => pafb -> s -> Withering f t
decayed :: forall (f :: * -> *) pafb s t.
Applicative f =>
pafb -> s -> Withering f t
decayed pafb
_ s
_ = Withering f t
forall (f :: * -> *) a. Applicative f => Withering f a
empty

-- | Remove elements from the current 'Withering' context if they
-- don't match the predicate. This is similar in concept to @filtered@
-- from lens but instead of merely removing non-matching
-- targets from the traversal, it removes those targets and their
-- parents up to the next 'withered' combinator.
guarded
    :: Applicative f
    => (a -> Bool) -> (a -> Withering f b)
    -> a -> Withering f b
guarded :: forall (f :: * -> *) a b.
Applicative f =>
(a -> Bool) -> (a -> Withering f b) -> a -> Withering f b
guarded a -> Bool
p a -> Withering f b
f a
a
    | a -> Bool
p a
a = a -> Withering f b
f a
a
    | Bool
otherwise = Withering f b
forall (f :: * -> *) a. Applicative f => Withering f a
empty


-- | Remove elements matched by a specific 'Withering' context if they
-- don't match a predicate.
filterOf
    :: ((a -> Withering Identity a) -> s -> Identity s)
    -> (a -> Bool) -> s -> s
filterOf :: forall a s.
((a -> Withering Identity a) -> s -> Identity s)
-> (a -> Bool) -> s -> s
filterOf (a -> Withering Identity a) -> s -> Identity s
w a -> Bool
p = Identity s -> s
forall a. Identity a -> a
runIdentity (Identity s -> s) -> (s -> Identity s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Withering Identity a) -> s -> Identity s
w a -> Withering Identity a
forall {f :: * -> *}. Applicative f => a -> Withering f a
toWithering
  where
    toWithering :: a -> Withering f a
toWithering a
a
        | a -> Bool
p a
a = a -> Withering f a
forall a. a -> Withering f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
        | Bool
otherwise = Withering f a
forall (f :: * -> *) a. Applicative f => Withering f a
empty
infix 2 `filterOf`

-- | Remove elements matched by a specific 'Withering' context if they
-- don't match a predicate returning a result in an arbitrary
-- Applicative context.
filterOfA
    :: Applicative f
    => ((a -> Withering f a) -> s -> f s)
    -> (a -> f Bool) -> s -> f s
filterOfA :: forall (f :: * -> *) a s.
Applicative f =>
((a -> Withering f a) -> s -> f s) -> (a -> f Bool) -> s -> f s
filterOfA (a -> Withering f a) -> s -> f s
w a -> f Bool
p = (a -> Withering f a) -> s -> f s
w a -> Withering f a
toWitheringA
  where
    toWitheringA :: a -> Withering f a
toWitheringA a
a = f (Maybe a) -> Withering f a
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering (f (Maybe a) -> Withering f a) -> f (Maybe a) -> Withering f a
forall a b. (a -> b) -> a -> b
$ (\Bool
x -> if Bool
x then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing) (Bool -> Maybe a) -> f Bool -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f Bool
p a
a
infix 2 `filterOfA`

-- | Transform and filter elements matched by a specific 'Withering'
-- context, a la 'Data.Maybe.mapMaybe'. See 'witherOf' for a more
-- flexible version that works within arbitrary 'Applicative' effects.
mapMaybeOf
    :: ((a -> Withering Identity b) -> s -> Identity t)
    -> (a -> Maybe b) -> s -> t
mapMaybeOf :: forall a b s t.
((a -> Withering Identity b) -> s -> Identity t)
-> (a -> Maybe b) -> s -> t
mapMaybeOf (a -> Withering Identity b) -> s -> Identity t
w a -> Maybe b
p = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Withering Identity b) -> s -> Identity t
w (Identity (Maybe b) -> Withering Identity b
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering (Identity (Maybe b) -> Withering Identity b)
-> (a -> Identity (Maybe b)) -> a -> Withering Identity b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe b -> Identity (Maybe b)
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe b -> Identity (Maybe b))
-> (a -> Maybe b) -> a -> Identity (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe b
p)
infix 2 `mapMaybeOf`

-- | Transform and effectfully filter elements matched by a specific
-- 'Withering' context, a la 'wither'.
witherOf
    :: ((a -> Withering f b) -> s -> f t)
    -> (a -> f (Maybe b)) -> s -> f t
witherOf :: forall a (f :: * -> *) b s t.
((a -> Withering f b) -> s -> f t)
-> (a -> f (Maybe b)) -> s -> f t
witherOf (a -> Withering f b) -> s -> f t
w a -> f (Maybe b)
p = (a -> Withering f b) -> s -> f t
w (f (Maybe b) -> Withering f b
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering (f (Maybe b) -> Withering f b)
-> (a -> f (Maybe b)) -> a -> Withering f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f (Maybe b)
p)
infix 2 `witherOf`