{- |
Module      : Control.Lens.Wither
Description : withers
Copyright   : (C) 2025 - Eitan Chatav
License     : BSD-style (see the file LICENSE)
Maintainer  : Eitan Chatav <eitan.chatav@gmail.com>
Stability   : provisional
Portability : non-portable

See Chris Penner,
[Composable Filters Using Witherable Optics](https://chrispenner.ca/posts/witherable-optics)
-}

module Control.Lens.Wither
  ( -- * Wither
    Wither
  , AWither
    -- * Combinators
  , cloneWither
  , withered
  , filtraversed
  , filterOf
    -- * Witheroid
  , Witheroid
  , witherPrism
    -- * Altar
  , Altar (..)
  ) where

import Control.Applicative
import Control.Lens
import Control.Lens.Internal.Context
import Data.Profunctor.Rep
import Data.Profunctor.Sieve
import Prelude hiding (filter)
import Witherable

{- | `Wither`s extends `Control.Lens.Traversal.Traversal`s by filtering.


Every one of the following is a `Wither`.

* `Control.Lens.Iso.Iso`
* `Control.Lens.Lens.Lens`
* `Control.Lens.Prism.Prism`
* `Control.Lens.Traversal.Traversal`
* `Witheroid`
-}
type Wither s t a b = forall f. Alternative f => (a -> f b) -> s -> f t

{- | If you see `AWither` in a signature for a function,
the function is expecting a `Wither`. -}
type AWither s t a b = (a -> Altar a b b) -> s -> Altar a b t

{- | `Witheroid`s generalize `Wither`s.
Every `Control.Lens.Prism.Prism` is a `Witheroid`.
-}
type Witheroid s t a b = forall p f.
  (Choice p, Alternative f)
    => p a (f b) -> p s (f t)

{- | Clone `AWither` so that you can reuse the same
monomorphically typed `Wither` for different purposes.
-}
cloneWither :: AWither s t a b -> Wither s t a b
cloneWither :: forall s t a b. AWither s t a b -> Wither s t a b
cloneWither AWither s t a b
w a -> f b
f = (\a -> f b
g Altar a b t
z -> Altar a b t
-> forall (f :: * -> *). Alternative f => (a -> f b) -> f t
forall a b t.
Altar a b t
-> forall (f :: * -> *). Alternative f => (a -> f b) -> f t
runAltar Altar a b t
z a -> f b
g) a -> f b
f (Altar a b t -> f t) -> (s -> Altar a b t) -> s -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AWither s t a b
w a -> Altar a b b
forall a b. a -> Altar a b b
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell

{- | Construct a `Wither` for a `Witherable`. -}
withered :: Witherable t => Wither (t a) (t b) a b
withered :: forall (t :: * -> *) a b. Witherable t => Wither (t a) (t b) a b
withered a -> 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 (f b -> f (Maybe b)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (f b -> f (Maybe b)) -> (a -> f b) -> a -> f (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)

{- |
prop> withered = filtraversed
-}
filtraversed :: (Filterable t, Traversable t) => Wither (t a) (t b) a b
filtraversed :: forall (t :: * -> *) a b.
(Filterable t, Traversable t) =>
Wither (t a) (t b) a b
filtraversed a -> f b
f = (t (Maybe b) -> t b) -> f (t (Maybe b)) -> f (t b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t (Maybe b) -> t b
forall a. t (Maybe a) -> t a
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes (f (t (Maybe b)) -> f (t b))
-> (t a -> f (t (Maybe b))) -> t a -> f (t b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Maybe b)) -> t a -> f (t (Maybe b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (f b -> f (Maybe b)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (f b -> f (Maybe b)) -> (a -> f b) -> a -> f (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f)

{- | Filter a traversed structure based on a predicate. -}
filterOf :: Alternative m => Wither s t a a -> (a -> Bool) -> s -> m t
filterOf :: forall (m :: * -> *) s t a.
Alternative m =>
Wither s t a a -> (a -> Bool) -> s -> m t
filterOf Wither s t a a
w a -> Bool
p s
s = (a -> m a) -> s -> m t
Wither s t a a
w a -> m a
guardingp s
s where
  guardingp :: a -> m a
guardingp a
a
    | a -> Bool
p a
a = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    | Bool
otherwise = m a
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty

{- |
`Control.Lens.Prism.Prism`s already capture the idea of success and failure,
but they simply skip the traversal if the prism doesn't match.
Lift prisms into withers such that they'll fail in a way that wither can catch.
-}
witherPrism :: APrism s t a b -> Witheroid s t a b
witherPrism :: forall s t a b. APrism s t a b -> Witheroid s t a b
witherPrism APrism s t a b
prsm =
  APrism s t a b
-> ((b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t))
-> p a (f b)
-> p s (f t)
forall s t a b r.
APrism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism APrism s t a b
prsm (((b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t))
 -> p a (f b) -> p s (f t))
-> ((b -> t) -> (s -> Either t a) -> p a (f b) -> p s (f t))
-> p a (f b)
-> p s (f t)
forall a b. (a -> b) -> a -> b
$ \b -> t
embed s -> Either t a
match ->
    (s -> Either t a)
-> (Either t (f b) -> f t)
-> p (Either t a) (Either t (f b))
-> p s (f t)
forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
match ((t -> f t) -> (f b -> f t) -> Either t (f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (f t -> t -> f t
forall a b. a -> b -> a
const f t
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty) ((b -> t) -> f b -> f t
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
embed)) (p (Either t a) (Either t (f b)) -> p s (f t))
-> (p a (f b) -> p (Either t a) (Either t (f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either t a) (Either t (f b))
forall a b c. p a b -> p (Either c a) (Either c b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

{- | This is used to characterize `Wither`s. -}
newtype Altar a b t = Altar
  { forall a b t.
Altar a b t
-> forall (f :: * -> *). Alternative f => (a -> f b) -> f t
runAltar :: forall f. Alternative f => (a -> f b) -> f t }
instance Functor (Altar a b) where
  fmap :: forall a b. (a -> b) -> Altar a b a -> Altar a b b
fmap a -> b
f (Altar forall (f :: * -> *). Alternative f => (a -> f b) -> f a
k) = (forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
-> Altar a b b
forall a b t.
(forall (f :: * -> *). Alternative f => (a -> f b) -> f t)
-> Altar a b t
Altar ((a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (f a -> f b) -> ((a -> f b) -> f a) -> (a -> f b) -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> f a
forall (f :: * -> *). Alternative f => (a -> f b) -> f a
k)
instance Applicative (Altar a b) where
  pure :: forall a. a -> Altar a b a
pure a
a = (forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
-> Altar a b a
forall a b t.
(forall (f :: * -> *). Alternative f => (a -> f b) -> f t)
-> Altar a b t
Altar ((forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
 -> Altar a b a)
-> (forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
-> Altar a b a
forall a b. (a -> b) -> a -> b
$ f a -> (a -> f b) -> f a
forall a b. a -> b -> a
const (a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
  Altar forall (f :: * -> *). Alternative f => (a -> f b) -> f (a -> b)
mf <*> :: forall a b. Altar a b (a -> b) -> Altar a b a -> Altar a b b
<*> Altar forall (f :: * -> *). Alternative f => (a -> f b) -> f a
ma = (forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
-> Altar a b b
forall a b t.
(forall (f :: * -> *). Alternative f => (a -> f b) -> f t)
-> Altar a b t
Altar ((forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
 -> Altar a b b)
-> (forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
-> Altar a b b
forall a b. (a -> b) -> a -> b
$ (f (a -> b) -> f a -> f b)
-> ((a -> f b) -> f (a -> b))
-> ((a -> f b) -> f a)
-> (a -> f b)
-> f b
forall a b c.
(a -> b -> c)
-> ((a -> f b) -> a) -> ((a -> f b) -> b) -> (a -> f b) -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f (a -> b) -> f a -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (a -> f b) -> f (a -> b)
forall (f :: * -> *). Alternative f => (a -> f b) -> f (a -> b)
mf (a -> f b) -> f a
forall (f :: * -> *). Alternative f => (a -> f b) -> f a
ma
instance Alternative (Altar a b) where
  empty :: forall a. Altar a b a
empty = (forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
-> Altar a b a
forall a b t.
(forall (f :: * -> *). Alternative f => (a -> f b) -> f t)
-> Altar a b t
Altar ((forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
 -> Altar a b a)
-> (forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
-> Altar a b a
forall a b. (a -> b) -> a -> b
$ f a -> (a -> f b) -> f a
forall a b. a -> b -> a
const f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty
  Altar forall (f :: * -> *). Alternative f => (a -> f b) -> f a
mx <|> :: forall a. Altar a b a -> Altar a b a -> Altar a b a
<|> Altar forall (f :: * -> *). Alternative f => (a -> f b) -> f a
my = (forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
-> Altar a b a
forall a b t.
(forall (f :: * -> *). Alternative f => (a -> f b) -> f t)
-> Altar a b t
Altar ((forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
 -> Altar a b a)
-> (forall (f :: * -> *). Alternative f => (a -> f b) -> f a)
-> Altar a b a
forall a b. (a -> b) -> a -> b
$ (f a -> f a -> f a)
-> ((a -> f b) -> f a) -> ((a -> f b) -> f a) -> (a -> f b) -> f a
forall a b c.
(a -> b -> c)
-> ((a -> f b) -> a) -> ((a -> f b) -> b) -> (a -> f b) -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f a -> f a -> f a
forall a. f a -> f a -> f a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (a -> f b) -> f a
forall (f :: * -> *). Alternative f => (a -> f b) -> f a
mx (a -> f b) -> f a
forall (f :: * -> *). Alternative f => (a -> f b) -> f a
my
instance Sellable (->) Altar where
  sell :: forall a b. a -> Altar a b b
sell
    = (Corep (->) a -> Altar a b b) -> a -> Altar a b b
forall d c. (Corep (->) d -> c) -> d -> c
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate
    ((Corep (->) a -> Altar a b b) -> a -> Altar a b b)
-> (Corep (->) a -> Altar a b b) -> a -> Altar a b b
forall a b. (a -> b) -> a -> b
$ \Corep (->) a
w -> (forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
-> Altar a b b
forall a b t.
(forall (f :: * -> *). Alternative f => (a -> f b) -> f t)
-> Altar a b t
Altar
    ((forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
 -> Altar a b b)
-> (forall (f :: * -> *). Alternative f => (a -> f b) -> f b)
-> Altar a b b
forall a b. (a -> b) -> a -> b
$ ((a -> f b) -> Rep (->) (f b)) -> (a -> f b) -> f b
forall d c. (d -> Rep (->) c) -> d -> c
forall (p :: * -> * -> *) d c.
Representable p =>
(d -> Rep p c) -> p d c
tabulate
    (((a -> f b) -> Rep (->) (f b)) -> (a -> f b) -> f b)
-> ((a -> f b) -> Rep (->) (f b)) -> (a -> f b) -> f b
forall a b. (a -> b) -> a -> b
$ \a -> f b
k -> f b -> Rep (->) (f b)
forall a. a -> Rep (->) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> f b) -> Corep (->) a -> f b
forall a b. (a -> b) -> Corep (->) a -> b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
cosieve a -> f b
k Corep (->) a
w)