module Data.Profunctor.Withering where

import Data.Profunctor
import Data.Profunctor.Traversing
import Control.Applicative

class (Traversing p) => Withering p where
  cull :: (forall f. Alternative f => (a -> f b) -> (s -> f t)) -> p a b -> p s t

instance Alternative f => Withering (Star f) where
  cull :: (forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t)
-> Star f a b -> Star f s t
cull f :: forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t
f (Star amb :: a -> f b
amb) = (s -> f t) -> Star f s t
forall (f :: * -> *) d c. (d -> f c) -> Star f d c
Star ((a -> f b) -> s -> f t
forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t
f a -> f b
amb)

instance Monoid m => Withering (Forget m) where
  cull :: (forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t)
-> Forget m a b -> Forget m s t
cull f :: forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t
f (Forget h :: a -> m
h) = (s -> m) -> Forget m s t
forall r a b. (a -> r) -> Forget r a b
Forget (AltConst m t -> m
forall p b. Monoid p => AltConst p b -> p
getAnnihilation (AltConst m t -> m) -> (s -> AltConst m t) -> s -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> AltConst m b) -> s -> AltConst m t
forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t
f (Maybe m -> AltConst m b
forall a b. Maybe a -> AltConst a b
AltConst (Maybe m -> AltConst m b) -> (a -> Maybe m) -> a -> AltConst m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> Maybe m
forall a. a -> Maybe a
Just (m -> Maybe m) -> (a -> m) -> a -> Maybe m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m
h))
    where
      getAnnihilation :: AltConst p b -> p
getAnnihilation (AltConst Nothing) = p
forall a. Monoid a => a
mempty
      getAnnihilation (AltConst (Just m :: p
m)) = p
m

newtype AltConst a b = AltConst (Maybe a)
  deriving stock (AltConst a b -> AltConst a b -> Bool
(AltConst a b -> AltConst a b -> Bool)
-> (AltConst a b -> AltConst a b -> Bool) -> Eq (AltConst a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. Eq a => AltConst a b -> AltConst a b -> Bool
/= :: AltConst a b -> AltConst a b -> Bool
$c/= :: forall a b. Eq a => AltConst a b -> AltConst a b -> Bool
== :: AltConst a b -> AltConst a b -> Bool
$c== :: forall a b. Eq a => AltConst a b -> AltConst a b -> Bool
Eq, Eq (AltConst a b)
Eq (AltConst a b) =>
(AltConst a b -> AltConst a b -> Ordering)
-> (AltConst a b -> AltConst a b -> Bool)
-> (AltConst a b -> AltConst a b -> Bool)
-> (AltConst a b -> AltConst a b -> Bool)
-> (AltConst a b -> AltConst a b -> Bool)
-> (AltConst a b -> AltConst a b -> AltConst a b)
-> (AltConst a b -> AltConst a b -> AltConst a b)
-> Ord (AltConst a b)
AltConst a b -> AltConst a b -> Bool
AltConst a b -> AltConst a b -> Ordering
AltConst a b -> AltConst a b -> AltConst a b
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. Ord a => Eq (AltConst a b)
forall a b. Ord a => AltConst a b -> AltConst a b -> Bool
forall a b. Ord a => AltConst a b -> AltConst a b -> Ordering
forall a b. Ord a => AltConst a b -> AltConst a b -> AltConst a b
min :: AltConst a b -> AltConst a b -> AltConst a b
$cmin :: forall a b. Ord a => AltConst a b -> AltConst a b -> AltConst a b
max :: AltConst a b -> AltConst a b -> AltConst a b
$cmax :: forall a b. Ord a => AltConst a b -> AltConst a b -> AltConst a b
>= :: AltConst a b -> AltConst a b -> Bool
$c>= :: forall a b. Ord a => AltConst a b -> AltConst a b -> Bool
> :: AltConst a b -> AltConst a b -> Bool
$c> :: forall a b. Ord a => AltConst a b -> AltConst a b -> Bool
<= :: AltConst a b -> AltConst a b -> Bool
$c<= :: forall a b. Ord a => AltConst a b -> AltConst a b -> Bool
< :: AltConst a b -> AltConst a b -> Bool
$c< :: forall a b. Ord a => AltConst a b -> AltConst a b -> Bool
compare :: AltConst a b -> AltConst a b -> Ordering
$ccompare :: forall a b. Ord a => AltConst a b -> AltConst a b -> Ordering
$cp1Ord :: forall a b. Ord a => Eq (AltConst a b)
Ord, Int -> AltConst a b -> ShowS
[AltConst a b] -> ShowS
AltConst a b -> String
(Int -> AltConst a b -> ShowS)
-> (AltConst a b -> String)
-> ([AltConst a b] -> ShowS)
-> Show (AltConst a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. Show a => Int -> AltConst a b -> ShowS
forall a b. Show a => [AltConst a b] -> ShowS
forall a b. Show a => AltConst a b -> String
showList :: [AltConst a b] -> ShowS
$cshowList :: forall a b. Show a => [AltConst a b] -> ShowS
show :: AltConst a b -> String
$cshow :: forall a b. Show a => AltConst a b -> String
showsPrec :: Int -> AltConst a b -> ShowS
$cshowsPrec :: forall a b. Show a => Int -> AltConst a b -> ShowS
Show, (a -> b) -> AltConst a a -> AltConst a b
(forall a b. (a -> b) -> AltConst a a -> AltConst a b)
-> (forall a b. a -> AltConst a b -> AltConst a a)
-> Functor (AltConst a)
forall a b. a -> AltConst a b -> AltConst a a
forall a b. (a -> b) -> AltConst a a -> AltConst a b
forall a a b. a -> AltConst a b -> AltConst a a
forall a a b. (a -> b) -> AltConst a a -> AltConst a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> AltConst a b -> AltConst a a
$c<$ :: forall a a b. a -> AltConst a b -> AltConst a a
fmap :: (a -> b) -> AltConst a a -> AltConst a b
$cfmap :: forall a a b. (a -> b) -> AltConst a a -> AltConst a b
Functor)

instance Monoid a => Applicative (AltConst a) where
  pure :: a -> AltConst a a
pure _ = (Maybe a -> AltConst a a
forall a b. Maybe a -> AltConst a b
AltConst (a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Monoid a => a
mempty))
  (AltConst Nothing) <*> :: AltConst a (a -> b) -> AltConst a a -> AltConst a b
<*> _ = (Maybe a -> AltConst a b
forall a b. Maybe a -> AltConst a b
AltConst Maybe a
forall a. Maybe a
Nothing)
  _ <*> (AltConst Nothing) = (Maybe a -> AltConst a b
forall a b. Maybe a -> AltConst a b
AltConst Maybe a
forall a. Maybe a
Nothing)
  (AltConst (Just a :: a
a)) <*> (AltConst (Just b :: a
b)) = Maybe a -> AltConst a b
forall a b. Maybe a -> AltConst a b
AltConst (a -> Maybe a
forall a. a -> Maybe a
Just (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b))

instance (Semigroup a) => Semigroup (AltConst a x) where
  (AltConst Nothing) <> :: AltConst a x -> AltConst a x -> AltConst a x
<> _ = (Maybe a -> AltConst a x
forall a b. Maybe a -> AltConst a b
AltConst Maybe a
forall a. Maybe a
Nothing)
  _ <> (AltConst Nothing) = (Maybe a -> AltConst a x
forall a b. Maybe a -> AltConst a b
AltConst Maybe a
forall a. Maybe a
Nothing)
  (AltConst (Just a :: a
a)) <> (AltConst (Just b :: a
b)) = Maybe a -> AltConst a x
forall a b. Maybe a -> AltConst a b
AltConst (a -> Maybe a
forall a. a -> Maybe a
Just (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
b))

instance (Monoid a) => Monoid (AltConst a x) where
  mempty :: AltConst a x
mempty = (Maybe a -> AltConst a x
forall a b. Maybe a -> AltConst a b
AltConst (a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Monoid a => a
mempty))

instance Monoid m => Alternative (AltConst m) where
  empty :: AltConst m a
empty = (Maybe m -> AltConst m a
forall a b. Maybe a -> AltConst a b
AltConst Maybe m
forall a. Maybe a
Nothing)
  (AltConst Nothing) <|> :: AltConst m a -> AltConst m a -> AltConst m a
<|> a :: AltConst m a
a = AltConst m a
a
  a :: AltConst m a
a <|> (AltConst Nothing) = AltConst m a
a
  (AltConst (Just a :: m
a)) <|> (AltConst (Just b :: m
b)) = (Maybe m -> AltConst m a
forall a b. Maybe a -> AltConst a b
AltConst (m -> Maybe m
forall a. a -> Maybe a
Just (m
a m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
b)))