Wither.hs

{- |
Module      : Control.Lens.Wither
Description : withers
Copyright   : (C) 2026 - 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

{- | `AWither` is monomorphically 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 w f = (\g z -> runAltar z g) f . w sell

{- | Construct a `Wither` for a `Witherable`. -}
withered :: Witherable t => Wither (t a) (t b) a b
withered f = wither (optional . f)

{- |
prop> withered = filtraversed
-}
filtraversed :: (Filterable t, Traversable t) => Wither (t a) (t b) a b
filtraversed f = fmap catMaybes . traverse (optional . f)

{- | Filter a traversed structure based on a predicate. -}
filterOf :: Alternative m => Wither s t a a -> (a -> Bool) -> s -> m t
filterOf w p s = w guardingp s where
  guardingp a
    | p a = pure a
    | otherwise = 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 prsm =
  withPrism prsm $ \embed match ->
    dimap match (either (const empty) (fmap embed)) . right'

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