{-# LANGUAGE ScopedTypeVariables #-}
module Proton.Wither where

import Data.Profunctor
import Data.Profunctor.Withering
import Control.Applicative
import Proton.Types
import Proton.Prisms

type Wither s t a b = forall p. Withering p => Optic p s t a b
type Wither' s a = Wither s s a a

-- type Selector' s a = Selector s s a a
-- type Selector s t a b = forall p. (Withering p, Depending p) => Optic p s t a b


guarding :: Alternative f => (a -> Bool) -> a -> f a
guarding :: (a -> Bool) -> a -> f a
guarding p :: a -> Bool
p a :: a
a
    | a -> Bool
p a
a = a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    | Bool
otherwise = f a
forall (f :: * -> *) a. Alternative f => f a
empty

guarded :: forall a b. (a -> Bool) -> Wither a b a b
guarded :: (a -> Bool) -> Wither a b a b
guarded p :: a -> Bool
p = (forall (f :: * -> *). Alternative f => (a -> f b) -> a -> f b)
-> p a b -> p a b
forall (p :: * -> * -> *) a b s t.
Withering p =>
(forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
cull forall (f :: * -> *). Alternative f => (a -> f b) -> a -> f b
guarded'
  where
    guarded' :: forall f. Alternative f => (a -> f b) -> a -> f b
    guarded' :: (a -> f b) -> a -> f b
guarded' f :: a -> f b
f a :: a
a
      | a -> Bool
p a
a = a -> f b
f a
a
      | Bool
otherwise = f b
forall (f :: * -> *) a. Alternative f => f a
empty

-- selectResult :: forall a b. (b -> Bool) -> Selector a b a b
-- selectResult p = cull _collapse . depend check
--   where
--     -- collapse :: forall f. Alternative f => (a -> f (b)) -> a -> f b
--     check :: forall f. Monad f => (a -> f b) -> a -> f (Maybe b)
--     check f a = do
--         f a >>= \b ->
--             if p b then pure $ Just b
--                    else pure $ Nothing

filterOf :: Optic (Star Maybe) s t a a -> (a -> Bool) -> s -> Maybe t
filterOf :: Optic (Star Maybe) s t a a -> (a -> Bool) -> s -> Maybe t
filterOf w :: Optic (Star Maybe) s t a a
w p :: a -> Bool
p s :: s
s = Star Maybe s t -> s -> Maybe t
forall (f :: * -> *) d c. Star f d c -> d -> f c
runStar (Optic (Star Maybe) s t a a
w ((a -> Maybe a) -> Star Maybe a a
forall (f :: * -> *) d c. (d -> f c) -> Star f d c
Star ((a -> Bool) -> a -> Maybe a
forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
guarding a -> Bool
p))) s
s

witherPrism :: forall p s t a b. Withering p => Prism s t a b -> Optic p s t a b
witherPrism :: Prism s t a b -> Optic p s t a b
witherPrism prsm :: Prism s t a b
prsm =
    Prism s t a b
-> ((b -> t) -> (s -> Either t a) -> Optic p s t a b)
-> Optic p s t a b
forall s t a b r.
Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Prism s t a b
prsm (((b -> t) -> (s -> Either t a) -> Optic p s t a b)
 -> Optic p s t a b)
-> ((b -> t) -> (s -> Either t a) -> Optic p s t a b)
-> Optic p s t a b
forall a b. (a -> b) -> a -> b
$ \embed :: b -> t
embed match :: s -> Either t a
match ->
      let
        go :: Alternative f => (a -> f b) -> s -> f t
        go :: (a -> f b) -> s -> f t
go f :: a -> f b
f s :: s
s = 
            case s -> Either t a
match s
s of
                Left _ -> f t
forall (f :: * -> *) a. Alternative f => f a
empty
                Right a :: a
a -> (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
embed (f b -> f t) -> f b -> f t
forall a b. (a -> b) -> a -> b
$ a -> f b
f a
a
      in (forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t)
-> Optic p s t a b
forall (p :: * -> * -> *) a b s t.
Withering p =>
(forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t)
-> p a b -> p s t
cull forall (f :: * -> *). Alternative f => (a -> f b) -> s -> f t
go