{-# LANGUAGE StandaloneDeriving, UndecidableInstances #-}

{-|
Module      : Witherable.Lens.Withering
Description : MaybeT replacement type
Copyright   : (c) Carl Howells, 2021-2022
License     : MIT
Maintainer  : chowells79@gmail.com

This module contains a replacement for @MaybeT@ intended for use in
lens-like contexts. The important difference from @MaybeT@ is that
'Withering' drops the short-circuiting behavior that requires 'Monad'
constraints.
-}
module Witherable.Lens.Withering (Withering(..), empty) where

import Control.Applicative (liftA2)

-- | A replacement for @MaybeT@ with no short-circuiting
-- behavior. This allows its 'Applicative' instance to not require @f@
-- to be an instance of 'Monad'.
newtype Withering f a = Withering { forall (f :: * -> *) a. Withering f a -> f (Maybe a)
runWithering :: f (Maybe a) }

deriving instance Eq (f (Maybe a)) => Eq (Withering f a)
deriving instance Ord (f (Maybe a)) => Ord (Withering f a)
deriving instance Show (f (Maybe a)) => Show (Withering f a)

instance Functor f => Functor (Withering f) where
    fmap :: forall a b. (a -> b) -> Withering f a -> Withering f b
fmap a -> b
f (Withering f (Maybe a)
x) = f (Maybe b) -> Withering f b
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering ((Maybe a -> Maybe b) -> f (Maybe a) -> 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 ((a -> b) -> Maybe a -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (Maybe a)
x)

instance Applicative f => Applicative (Withering f) where
    pure :: forall a. a -> Withering f a
pure a
x = f (Maybe a) -> Withering f a
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering (Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
x))
    Withering f (Maybe (a -> b))
f <*> :: forall a b. Withering f (a -> b) -> Withering f a -> Withering f b
<*> Withering f (Maybe a)
x = f (Maybe b) -> Withering f b
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering ((Maybe (a -> b) -> Maybe a -> Maybe b)
-> f (Maybe (a -> b)) -> f (Maybe a) -> f (Maybe b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Maybe (a -> b) -> Maybe a -> Maybe b
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) f (Maybe (a -> b))
f f (Maybe a)
x)

-- | A 'Withering' value wrapping 'Nothing'. This cannot be part of an
-- 'Control.Applicative.Alternative' instance for 'Withering' because
-- it needs to be available with only an 'Applicative' constraint on
-- @f@, and any lawful 'Control.Applicative.Alternative' instance
-- would require more structure than that.
empty :: Applicative f => Withering f a
empty :: forall (f :: * -> *) a. Applicative f => Withering f a
empty = f (Maybe a) -> Withering f a
forall (f :: * -> *) a. f (Maybe a) -> Withering f a
Withering (Maybe a -> f (Maybe a)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing)