{-# LANGUAGE RankNTypes, TupleSections, TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Safe #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Object.Object
-- Copyright   :  (c) Fumiaki Kinoshita 2015
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs, Rank2Types
--
-----------------------------------------------------------------------------
module Control.Object.Object (Object(..)
  , echo
  , (@>>@)
  , (@<<@)
  , liftO
  , (^>>@)
  , (@>>^)
  , (@||@)
  -- * Stateful construction
  , unfoldO
  , stateful
  , (@~)
  , variable
  -- * Method cascading
  , (@-)
  , cascadeObject
  , cascading
  -- * Filtering
  , Fallible(..)
  , filteredO
  , filterO
  -- * Manipulation on StateT
  , invokesOf
  , invokes
  , (@!=)
  , announce
  ) where
import Control.Monad.Trans.State.Strict
import Control.Monad.Skeleton
import Control.Monad.Trans.Writer.Strict
import Data.Monoid
import Data.Tuple (swap)
import qualified Data.Functor.Sum as Functor

-- | The type @Object f g@ represents objects which can handle messages @f@, perform actions in the environment @g@.
-- It can be thought of as an automaton that transforms effects.
-- 'Object's can be composed just like functions using '@>>@'; the identity element is 'echo'.
-- Objects are morphisms of the category of actions.
--
-- [/Naturality/]
--     @runObject obj . fmap f ≡ fmap f . runObject obj@
--
newtype Object f g = Object { Object f g -> forall x. f x -> g (x, Object f g)
runObject :: forall x. f x -> g (x, Object f g) }

-- | An infix alias for 'runObject'
(@-) :: Object f g -> f x -> g (x, Object f g)
Object f g
a @- :: Object f g -> f x -> g (x, Object f g)
@- f x
b = Object f g -> f x -> g (x, Object f g)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object f g
a f x
b
{-# INLINE (@-) #-}
infixr 3 @-

infixr 1 ^>>@
infixr 1 @>>^

(^>>@) :: Functor h => (forall x. f x -> g x) -> Object g h -> Object f h
forall x. f x -> g x
f ^>>@ :: (forall x. f x -> g x) -> Object g h -> Object f h
^>>@ Object g h
m0 = Object g h -> Object f h
go Object g h
m0 where go :: Object g h -> Object f h
go (Object forall x. g x -> h (x, Object g h)
m) = (forall x. f x -> h (x, Object f h)) -> Object f h
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. f x -> h (x, Object f h)) -> Object f h)
-> (forall x. f x -> h (x, Object f h)) -> Object f h
forall a b. (a -> b) -> a -> b
$ ((x, Object g h) -> (x, Object f h))
-> h (x, Object g h) -> h (x, Object f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Object g h -> Object f h) -> (x, Object g h) -> (x, Object f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object g h -> Object f h
go) (h (x, Object g h) -> h (x, Object f h))
-> (f x -> h (x, Object g h)) -> f x -> h (x, Object f h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g x -> h (x, Object g h)
forall x. g x -> h (x, Object g h)
m (g x -> h (x, Object g h))
-> (f x -> g x) -> f x -> h (x, Object g h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
forall x. f x -> g x
f
{-# INLINE (^>>@) #-}

(@>>^) :: Functor h => Object f g -> (forall x. g x -> h x) -> Object f h
Object f g
m0 @>>^ :: Object f g -> (forall x. g x -> h x) -> Object f h
@>>^ forall x. g x -> h x
g = Object f g -> Object f h
go Object f g
m0 where go :: Object f g -> Object f h
go (Object forall x. f x -> g (x, Object f g)
m) = (forall x. f x -> h (x, Object f h)) -> Object f h
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. f x -> h (x, Object f h)) -> Object f h)
-> (forall x. f x -> h (x, Object f h)) -> Object f h
forall a b. (a -> b) -> a -> b
$ ((x, Object f g) -> (x, Object f h))
-> h (x, Object f g) -> h (x, Object f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Object f g -> Object f h) -> (x, Object f g) -> (x, Object f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Object f g -> Object f h
go) (h (x, Object f g) -> h (x, Object f h))
-> (f x -> h (x, Object f g)) -> f x -> h (x, Object f h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g (x, Object f g) -> h (x, Object f g)
forall x. g x -> h x
g (g (x, Object f g) -> h (x, Object f g))
-> (f x -> g (x, Object f g)) -> f x -> h (x, Object f g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g (x, Object f g)
forall x. f x -> g (x, Object f g)
m
{-# INLINE (@>>^) #-}

-- | The trivial object
echo :: Functor f => Object f f
echo :: Object f f
echo = (forall x. f x -> f (x, Object f f)) -> Object f f
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. f x -> f (x, Object f f)) -> Object f f)
-> (forall x. f x -> f (x, Object f f)) -> Object f f
forall a b. (a -> b) -> a -> b
$ (x -> (x, Object f f)) -> f x -> f (x, Object f f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Object f f
forall (f :: * -> *). Functor f => Object f f
echo)

-- | Lift a natural transformation into an object.
liftO :: Functor g => (forall x. f x -> g x) -> Object f g
liftO :: (forall x. f x -> g x) -> Object f g
liftO forall x. f x -> g x
f = Object f g
go where go :: Object f g
go = (forall x. f x -> g (x, Object f g)) -> Object f g
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. f x -> g (x, Object f g)) -> Object f g)
-> (forall x. f x -> g (x, Object f g)) -> Object f g
forall a b. (a -> b) -> a -> b
$ (x -> (x, Object f g)) -> g x -> g (x, Object f g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\x
x -> (x
x, Object f g
go)) (g x -> g (x, Object f g))
-> (f x -> g x) -> f x -> g (x, Object f g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x
forall x. f x -> g x
f
{-# INLINE liftO #-}

-- | The categorical composition of objects.
(@>>@) :: Functor h => Object f g -> Object g h -> Object f h
Object forall x. f x -> g (x, Object f g)
m @>>@ :: Object f g -> Object g h -> Object f h
@>>@ Object forall x. g x -> h (x, Object g h)
n = (forall x. f x -> h (x, Object f h)) -> Object f h
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. f x -> h (x, Object f h)) -> Object f h)
-> (forall x. f x -> h (x, Object f h)) -> Object f h
forall a b. (a -> b) -> a -> b
$ (((x, Object f g), Object g h) -> (x, Object f h))
-> h ((x, Object f g), Object g h) -> h (x, Object f h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((x
x, Object f g
m'), Object g h
n') -> (x
x, Object f g
m' Object f g -> Object g h -> Object f h
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Functor h =>
Object f g -> Object g h -> Object f h
@>>@ Object g h
n')) (h ((x, Object f g), Object g h) -> h (x, Object f h))
-> (f x -> h ((x, Object f g), Object g h))
-> f x
-> h (x, Object f h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g (x, Object f g) -> h ((x, Object f g), Object g h)
forall x. g x -> h (x, Object g h)
n (g (x, Object f g) -> h ((x, Object f g), Object g h))
-> (f x -> g (x, Object f g))
-> f x
-> h ((x, Object f g), Object g h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g (x, Object f g)
forall x. f x -> g (x, Object f g)
m
infixr 1 @>>@

-- | Reversed '(@>>@)'
(@<<@) :: Functor h => Object g h -> Object f g -> Object f h
@<<@ :: Object g h -> Object f g -> Object f h
(@<<@) = (Object f g -> Object g h -> Object f h)
-> Object g h -> Object f g -> Object f h
forall a b c. (a -> b -> c) -> b -> a -> c
flip Object f g -> Object g h -> Object f h
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Functor h =>
Object f g -> Object g h -> Object f h
(@>>@)
{-# INLINE (@<<@) #-}
infixl 1 @<<@

-- | Combine objects so as to handle a 'Functor.Sum' of interfaces.
(@||@) :: Functor h => Object f h -> Object g h -> Object (f `Functor.Sum` g) h
Object f h
a @||@ :: Object f h -> Object g h -> Object (Sum f g) h
@||@ Object g h
b = (forall x. Sum f g x -> h (x, Object (Sum f g) h))
-> Object (Sum f g) h
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. Sum f g x -> h (x, Object (Sum f g) h))
 -> Object (Sum f g) h)
-> (forall x. Sum f g x -> h (x, Object (Sum f g) h))
-> Object (Sum f g) h
forall a b. (a -> b) -> a -> b
$ \case
  Functor.InL f -> ((x, Object f h) -> (x, Object (Sum f g) h))
-> h (x, Object f h) -> h (x, Object (Sum f g) h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Object f h -> Object (Sum f g) h)
-> (x, Object f h) -> (x, Object (Sum f g) h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Object f h -> Object g h -> Object (Sum f g) h
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Functor h =>
Object f h -> Object g h -> Object (Sum f g) h
@||@Object g h
b)) (Object f h -> f x -> h (x, Object f h)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object f h
a f x
f)
  Functor.InR g -> ((x, Object g h) -> (x, Object (Sum f g) h))
-> h (x, Object g h) -> h (x, Object (Sum f g) h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Object g h -> Object (Sum f g) h)
-> (x, Object g h) -> (x, Object (Sum f g) h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Object f h
aObject f h -> Object g h -> Object (Sum f g) h
forall (h :: * -> *) (f :: * -> *) (g :: * -> *).
Functor h =>
Object f h -> Object g h -> Object (Sum f g) h
@||@)) (Object g h -> g x -> h (x, Object g h)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object g h
b g x
g)

-- | An unwrapped analog of 'stateful'
--     @id = unfoldO runObject@
--     @'iterative' = unfoldO 'iterObject'@
--     @'cascading' = unfoldO 'cascadeObject'@
unfoldO :: Functor g => (forall a. r -> f a -> g (a, r)) -> r -> Object f g
unfoldO :: (forall a. r -> f a -> g (a, r)) -> r -> Object f g
unfoldO forall a. r -> f a -> g (a, r)
h = r -> Object f g
go where go :: r -> Object f g
go r
r = (forall x. f x -> g (x, Object f g)) -> Object f g
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. f x -> g (x, Object f g)) -> Object f g)
-> (forall x. f x -> g (x, Object f g)) -> Object f g
forall a b. (a -> b) -> a -> b
$ ((x, r) -> (x, Object f g)) -> g (x, r) -> g (x, Object f g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((r -> Object f g) -> (x, r) -> (x, Object f g)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap r -> Object f g
go) (g (x, r) -> g (x, Object f g))
-> (f x -> g (x, r)) -> f x -> g (x, Object f g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> f x -> g (x, r)
forall a. r -> f a -> g (a, r)
h r
r
{-# INLINE unfoldO #-}

-- | Build a stateful object.
--
-- @stateful t s = t ^>>\@ variable s@
--
stateful :: Monad m => (forall a. t a -> StateT s m a) -> s -> Object t m
stateful :: (forall a. t a -> StateT s m a) -> s -> Object t m
stateful forall a. t a -> StateT s m a
h = s -> Object t m
go where
  go :: s -> Object t m
go s
s = (forall x. t x -> m (x, Object t m)) -> Object t m
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. t x -> m (x, Object t m)) -> Object t m)
-> (forall x. t x -> m (x, Object t m)) -> Object t m
forall a b. (a -> b) -> a -> b
$ \t x
f -> StateT s m x -> s -> m (x, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (t x -> StateT s m x
forall a. t a -> StateT s m a
h t x
f) s
s m (x, s) -> ((x, s) -> m (x, Object t m)) -> m (x, Object t m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(x
a, s
s') -> s
s' s -> m (x, Object t m) -> m (x, Object t m)
`seq` (x, Object t m) -> m (x, Object t m)
forall (m :: * -> *) a. Monad m => a -> m a
return (x
a, s -> Object t m
go s
s')
{-# INLINE stateful #-}

-- | Flipped 'stateful'.
-- it is super convenient to use with the LambdaCase extension.
(@~) :: Monad m => s -> (forall a. t a -> StateT s m a) -> Object t m
s
s @~ :: s -> (forall a. t a -> StateT s m a) -> Object t m
@~ forall a. t a -> StateT s m a
h = (forall a. t a -> StateT s m a) -> s -> Object t m
forall (m :: * -> *) (t :: * -> *) s.
Monad m =>
(forall a. t a -> StateT s m a) -> s -> Object t m
stateful forall a. t a -> StateT s m a
h s
s
{-# INLINE (@~) #-}
infix 1 @~

-- | A mutable variable.
--
-- @variable = stateful id@
--
variable :: Monad m => s -> Object (StateT s m) m
variable :: s -> Object (StateT s m) m
variable = (forall a. StateT s m a -> StateT s m a)
-> s -> Object (StateT s m) m
forall (m :: * -> *) (t :: * -> *) s.
Monad m =>
(forall a. t a -> StateT s m a) -> s -> Object t m
stateful forall a. a -> a
forall a. StateT s m a -> StateT s m a
id
{-# INLINE variable #-}

-- | Pass zero or more messages to an object.
cascadeObject :: Monad m => Object t m -> Skeleton t a -> m (a, Object t m)
cascadeObject :: Object t m -> Skeleton t a -> m (a, Object t m)
cascadeObject Object t m
obj Skeleton t a
sk = case Skeleton t a -> MonadView t (Skeleton t) a
forall (t :: * -> *) a. Skeleton t a -> MonadView t (Skeleton t) a
debone Skeleton t a
sk of
  Return a
a -> (a, Object t m) -> m (a, Object t m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Object t m
obj)
  t a
t :>>= a -> Skeleton t a
k -> Object t m -> t a -> m (a, Object t m)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object t m
obj t a
t m (a, Object t m)
-> ((a, Object t m) -> m (a, Object t m)) -> m (a, Object t m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
a, Object t m
obj') -> Object t m -> Skeleton t a -> m (a, Object t m)
forall (m :: * -> *) (t :: * -> *) a.
Monad m =>
Object t m -> Skeleton t a -> m (a, Object t m)
cascadeObject Object t m
obj' (a -> Skeleton t a
k a
a)

-- | Add capability to handle multiple messages at once.
cascading :: Monad m => Object t m -> Object (Skeleton t) m
cascading :: Object t m -> Object (Skeleton t) m
cascading = (forall a. Object t m -> Skeleton t a -> m (a, Object t m))
-> Object t m -> Object (Skeleton t) m
forall (g :: * -> *) r (f :: * -> *).
Functor g =>
(forall a. r -> f a -> g (a, r)) -> r -> Object f g
unfoldO forall a. Object t m -> Skeleton t a -> m (a, Object t m)
forall (m :: * -> *) (t :: * -> *) a.
Monad m =>
Object t m -> Skeleton t a -> m (a, Object t m)
cascadeObject
{-# INLINE cascading #-}

-- | Send a message to an object through a lens.
invokesOf :: Monad m
  => ((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)
  -> t a -> (a -> r) -> StateT s m r
invokesOf :: ((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)
-> t a -> (a -> r) -> StateT s m r
invokesOf (Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s
t t a
f a -> r
c = (s -> m (r, s)) -> StateT s m r
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((s -> m (r, s)) -> StateT s m r)
-> (s -> m (r, s)) -> StateT s m r
forall a b. (a -> b) -> a -> b
$ ((s, r) -> (r, s)) -> m (s, r) -> m (r, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, r) -> (r, s)
forall a b. (a, b) -> (b, a)
swap (m (s, r) -> m (r, s)) -> (s -> m (s, r)) -> s -> m (r, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT r m s -> m (s, r)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT
  (WriterT r m s -> m (s, r))
-> (s -> WriterT r m s) -> s -> m (s, r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s
t (\Object t m
obj -> m (Object t m, r) -> WriterT r m (Object t m)
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
WriterT (m (Object t m, r) -> WriterT r m (Object t m))
-> m (Object t m, r) -> WriterT r m (Object t m)
forall a b. (a -> b) -> a -> b
$ Object t m -> t a -> m (a, Object t m)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object t m
obj t a
f m (a, Object t m)
-> ((a, Object t m) -> m (Object t m, r)) -> m (Object t m, r)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
x, Object t m
obj') -> (Object t m, r) -> m (Object t m, r)
forall (m :: * -> *) a. Monad m => a -> m a
return (Object t m
obj', a -> r
c a
x))
{-# INLINABLE invokesOf #-}

invokes :: (Traversable t, Monad m, Monoid r)
  => f a -> (a -> r) -> StateT (t (Object f m)) m r
invokes :: f a -> (a -> r) -> StateT (t (Object f m)) m r
invokes = ((Object f m -> WriterT r m (Object f m))
 -> t (Object f m) -> WriterT r m (t (Object f m)))
-> f a -> (a -> r) -> StateT (t (Object f m)) m r
forall (m :: * -> *) (t :: * -> *) r s a.
Monad m =>
((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)
-> t a -> (a -> r) -> StateT s m r
invokesOf (Object f m -> WriterT r m (Object f m))
-> t (Object f m) -> WriterT r m (t (Object f m))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
{-# INLINE invokes #-}

-- | Send a message to objects in a traversable container.
announce :: (Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]
announce :: f a -> StateT (t (Object f m)) m [a]
announce f a
f = ((a -> Endo [a]) -> StateT (t (Object f m)) m (Endo [a]))
-> StateT (t (Object f m)) m [a]
forall (f :: * -> *) a.
Functor f =>
((a -> Endo [a]) -> f (Endo [a])) -> f [a]
withListBuilder (f a -> (a -> Endo [a]) -> StateT (t (Object f m)) m (Endo [a])
forall (t :: * -> *) (m :: * -> *) r (f :: * -> *) a.
(Traversable t, Monad m, Monoid r) =>
f a -> (a -> r) -> StateT (t (Object f m)) m r
invokes f a
f)
{-# INLINABLE announce #-}

-- | A method invocation operator on 'StateT'.
(@!=) :: Monad m
  => ((Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s)
  -> t a -> StateT s m a
(Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s
l @!= :: ((Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s)
-> t a -> StateT s m a
@!= t a
f = ((Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s)
-> t a -> (a -> a) -> StateT s m a
forall (m :: * -> *) (t :: * -> *) r s a.
Monad m =>
((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)
-> t a -> (a -> r) -> StateT s m r
invokesOf (Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s
l t a
f a -> a
forall a. a -> a
id
{-# INLINE (@!=) #-}

withListBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]
withListBuilder :: ((a -> Endo [a]) -> f (Endo [a])) -> f [a]
withListBuilder (a -> Endo [a]) -> f (Endo [a])
f = (Endo [a] -> [a]) -> f (Endo [a]) -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Endo [a] -> [a] -> [a]) -> [a] -> Endo [a] -> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Endo [a] -> [a] -> [a]
forall a. Endo a -> a -> a
appEndo []) ((a -> Endo [a]) -> f (Endo [a])
f (([a] -> [a]) -> Endo [a]
forall a. (a -> a) -> Endo a
Endo (([a] -> [a]) -> Endo [a]) -> (a -> [a] -> [a]) -> a -> Endo [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:)))
{-# INLINABLE withListBuilder #-}

data Fallible t a where
  Fallible :: t a -> Fallible t (Maybe a)

filteredO :: Monad m
       => (forall x. t x -> Bool)
       -> Object t m -> Object (Fallible t) m
filteredO :: (forall x. t x -> Bool) -> Object t m -> Object (Fallible t) m
filteredO forall x. t x -> Bool
p Object t m
obj = (forall x. Fallible t x -> m (x, Object (Fallible t) m))
-> Object (Fallible t) m
forall (f :: * -> *) (g :: * -> *).
(forall x. f x -> g (x, Object f g)) -> Object f g
Object ((forall x. Fallible t x -> m (x, Object (Fallible t) m))
 -> Object (Fallible t) m)
-> (forall x. Fallible t x -> m (x, Object (Fallible t) m))
-> Object (Fallible t) m
forall a b. (a -> b) -> a -> b
$ \(Fallible t) -> if t a -> Bool
forall x. t x -> Bool
p t a
t
  then Object t m -> t a -> m (a, Object t m)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object t m
obj t a
t m (a, Object t m)
-> ((a, Object t m) -> m (Maybe a, Object (Fallible t) m))
-> m (Maybe a, Object (Fallible t) m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(a
a, Object t m
obj') -> (Maybe a, Object (Fallible t) m)
-> m (Maybe a, Object (Fallible t) m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a, (forall x. t x -> Bool) -> Object t m -> Object (Fallible t) m
forall (m :: * -> *) (t :: * -> *).
Monad m =>
(forall x. t x -> Bool) -> Object t m -> Object (Fallible t) m
filteredO forall x. t x -> Bool
p Object t m
obj')
  else (Maybe a, Object (Fallible t) m)
-> m (Maybe a, Object (Fallible t) m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, (forall x. t x -> Bool) -> Object t m -> Object (Fallible t) m
forall (m :: * -> *) (t :: * -> *).
Monad m =>
(forall x. t x -> Bool) -> Object t m -> Object (Fallible t) m
filteredO forall x. t x -> Bool
p Object t m
obj)

filterO :: (forall x. t x -> Bool) -> Object (Fallible t) (Skeleton t)
filterO :: (forall x. t x -> Bool) -> Object (Fallible t) (Skeleton t)
filterO forall x. t x -> Bool
p = (forall x. t x -> Bool)
-> Object t (Skeleton t) -> Object (Fallible t) (Skeleton t)
forall (m :: * -> *) (t :: * -> *).
Monad m =>
(forall x. t x -> Bool) -> Object t m -> Object (Fallible t) m
filteredO forall x. t x -> Bool
p ((forall x. t x -> Skeleton t x) -> Object t (Skeleton t)
forall (g :: * -> *) (f :: * -> *).
Functor g =>
(forall x. f x -> g x) -> Object f g
liftO forall x. t x -> Skeleton t x
forall (t :: * -> *) a. t a -> Skeleton t a
bone)
{-# INLINE filterO #-}