module Focus where

import Focus.Prelude hiding (delete, insert, lookup)

-- |
-- Abstraction over the modification of an element of a datastructure.
--
-- It is composable using the standard typeclasses, e.g.:
--
-- >lookupAndDelete :: Monad m => Focus a m (Maybe a)
-- >lookupAndDelete = lookup <* delete
data Focus element m result = Focus (m (result, Change element)) (element -> m (result, Change element))

deriving instance (Functor m) => Functor (Focus element m)

instance (Monad m) => Applicative (Focus element m) where
  pure :: forall a. a -> Focus element m a
pure a
a = m (a, Change element)
-> (element -> m (a, Change element)) -> Focus element m a
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus ((a, Change element) -> m (a, Change element)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, Change element
forall a. Change a
Leave)) (m (a, Change element) -> element -> m (a, Change element)
forall a b. a -> b -> a
const ((a, Change element) -> m (a, Change element)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, Change element
forall a. Change a
Leave)))
  <*> :: forall a b.
Focus element m (a -> b) -> Focus element m a -> Focus element m b
(<*>) = Focus element m (a -> b) -> Focus element m a -> Focus element m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance (Monad m) => Monad (Focus element m) where
  return :: forall a. a -> Focus element m a
return = a -> Focus element m a
forall a. a -> Focus element m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: forall a b.
Focus element m a -> (a -> Focus element m b) -> Focus element m b
(>>=) (Focus m (a, Change element)
lAbsent element -> m (a, Change element)
lPresent) a -> Focus element m b
rk =
    m (b, Change element)
-> (element -> m (b, Change element)) -> Focus element m b
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m (b, Change element)
absent element -> m (b, Change element)
present
    where
      absent :: m (b, Change element)
absent =
        do
          (a
lr, Change element
lChange) <- m (a, Change element)
lAbsent
          let Focus m (b, Change element)
rAbsent element -> m (b, Change element)
rPresent = a -> Focus element m b
rk a
lr
          case Change element
lChange of
            Change element
Leave -> m (b, Change element)
rAbsent
            Change element
Remove -> m (b, Change element)
rAbsent m (b, Change element)
-> (m (b, Change element) -> m (b, Change element))
-> m (b, Change element)
forall a b. a -> (a -> b) -> b
& ((b, Change element) -> (b, Change element))
-> m (b, Change element) -> m (b, Change element)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change element -> Change element -> Change element
forall a. Monoid a => a -> a -> a
mappend Change element
lChange))
            Set element
newElement -> element -> m (b, Change element)
rPresent element
newElement m (b, Change element)
-> (m (b, Change element) -> m (b, Change element))
-> m (b, Change element)
forall a b. a -> (a -> b) -> b
& ((b, Change element) -> (b, Change element))
-> m (b, Change element) -> m (b, Change element)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change element -> Change element -> Change element
forall a. Monoid a => a -> a -> a
mappend Change element
lChange))
      present :: element -> m (b, Change element)
present element
element =
        do
          (a
lr, Change element
lChange) <- element -> m (a, Change element)
lPresent element
element
          let Focus m (b, Change element)
rAbsent element -> m (b, Change element)
rPresent = a -> Focus element m b
rk a
lr
          case Change element
lChange of
            Change element
Leave -> element -> m (b, Change element)
rPresent element
element
            Change element
Remove -> m (b, Change element)
rAbsent m (b, Change element)
-> (m (b, Change element) -> m (b, Change element))
-> m (b, Change element)
forall a b. a -> (a -> b) -> b
& ((b, Change element) -> (b, Change element))
-> m (b, Change element) -> m (b, Change element)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change element -> Change element -> Change element
forall a. Monoid a => a -> a -> a
mappend Change element
lChange))
            Set element
newElement -> element -> m (b, Change element)
rPresent element
newElement m (b, Change element)
-> (m (b, Change element) -> m (b, Change element))
-> m (b, Change element)
forall a b. a -> (a -> b) -> b
& ((b, Change element) -> (b, Change element))
-> m (b, Change element) -> m (b, Change element)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change element -> Change element -> Change element
forall a. Monoid a => a -> a -> a
mappend Change element
lChange))

instance MonadTrans (Focus element) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> Focus element m a
lift m a
m = m (a, Change element)
-> (element -> m (a, Change element)) -> Focus element m a
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus ((a -> (a, Change element)) -> m a -> m (a, Change element)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Change element
forall a. Change a
Leave) m a
m) (m (a, Change element) -> element -> m (a, Change element)
forall a b. a -> b -> a
const ((a -> (a, Change element)) -> m a -> m (a, Change element)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Change element
forall a. Change a
Leave) m a
m))

-- |
-- What to do with the focused value.
--
-- The interpretation of the commands is up to the context APIs.
data Change a
  = -- | Produce no changes
    Leave
  | -- | Delete it
    Remove
  | -- | Set its value to the provided one
    Set a
  deriving ((forall a b. (a -> b) -> Change a -> Change b)
-> (forall a b. a -> Change b -> Change a) -> Functor Change
forall a b. a -> Change b -> Change a
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Change a -> Change b
fmap :: forall a b. (a -> b) -> Change a -> Change b
$c<$ :: forall a b. a -> Change b -> Change a
<$ :: forall a b. a -> Change b -> Change a
Functor, Change a -> Change a -> Bool
(Change a -> Change a -> Bool)
-> (Change a -> Change a -> Bool) -> Eq (Change a)
forall a. Eq a => Change a -> Change a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Change a -> Change a -> Bool
== :: Change a -> Change a -> Bool
$c/= :: forall a. Eq a => Change a -> Change a -> Bool
/= :: Change a -> Change a -> Bool
Eq, Eq (Change a)
Eq (Change a) =>
(Change a -> Change a -> Ordering)
-> (Change a -> Change a -> Bool)
-> (Change a -> Change a -> Bool)
-> (Change a -> Change a -> Bool)
-> (Change a -> Change a -> Bool)
-> (Change a -> Change a -> Change a)
-> (Change a -> Change a -> Change a)
-> Ord (Change a)
Change a -> Change a -> Bool
Change a -> Change a -> Ordering
Change a -> Change a -> Change a
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. Ord a => Eq (Change a)
forall a. Ord a => Change a -> Change a -> Bool
forall a. Ord a => Change a -> Change a -> Ordering
forall a. Ord a => Change a -> Change a -> Change a
$ccompare :: forall a. Ord a => Change a -> Change a -> Ordering
compare :: Change a -> Change a -> Ordering
$c< :: forall a. Ord a => Change a -> Change a -> Bool
< :: Change a -> Change a -> Bool
$c<= :: forall a. Ord a => Change a -> Change a -> Bool
<= :: Change a -> Change a -> Bool
$c> :: forall a. Ord a => Change a -> Change a -> Bool
> :: Change a -> Change a -> Bool
$c>= :: forall a. Ord a => Change a -> Change a -> Bool
>= :: Change a -> Change a -> Bool
$cmax :: forall a. Ord a => Change a -> Change a -> Change a
max :: Change a -> Change a -> Change a
$cmin :: forall a. Ord a => Change a -> Change a -> Change a
min :: Change a -> Change a -> Change a
Ord, Int -> Change a -> ShowS
[Change a] -> ShowS
Change a -> String
(Int -> Change a -> ShowS)
-> (Change a -> String) -> ([Change a] -> ShowS) -> Show (Change a)
forall a. Show a => Int -> Change a -> ShowS
forall a. Show a => [Change a] -> ShowS
forall a. Show a => Change a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Change a -> ShowS
showsPrec :: Int -> Change a -> ShowS
$cshow :: forall a. Show a => Change a -> String
show :: Change a -> String
$cshowList :: forall a. Show a => [Change a] -> ShowS
showList :: [Change a] -> ShowS
Show)

instance Semigroup (Change a) where
  <> :: Change a -> Change a -> Change a
(<>) Change a
l Change a
r =
    case Change a
r of
      Change a
Leave -> Change a
l
      Change a
_ -> Change a
r

instance Monoid (Change a) where
  mempty :: Change a
mempty = Change a
forall a. Change a
Leave

-- * Pure functions

-- ** Reading functions

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:member member>@.
{-# INLINE member #-}
member :: (Monad m) => Focus a m Bool
member :: forall (m :: * -> *) a. Monad m => Focus a m Bool
member = (Maybe a -> Bool) -> Focus a m (Maybe a) -> Focus a m Bool
forall a b. (a -> b) -> Focus a m a -> Focus a m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> a -> Bool
forall a b. a -> b -> a
const Bool
True)) Focus a m (Maybe a)
forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
lookup

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:lookup lookup>@.
{-# INLINE [1] lookup #-}
lookup :: (Monad m) => Focus a m (Maybe a)
lookup :: forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
lookup = (Maybe a, Change a)
-> (a -> (Maybe a, Change a)) -> Focus a m (Maybe a)
forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (Maybe a
forall a. Maybe a
Nothing, Change a
forall a. Change a
Leave) (\a
a -> (a -> Maybe a
forall a. a -> Maybe a
Just a
a, Change a
forall a. Change a
Leave))

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:findWithDefault findWithDefault>@
-- with a better name.
{-# INLINE [1] lookupWithDefault #-}
lookupWithDefault :: (Monad m) => a -> Focus a m a
lookupWithDefault :: forall (m :: * -> *) a. Monad m => a -> Focus a m a
lookupWithDefault a
a = (a, Change a) -> (a -> (a, Change a)) -> Focus a m a
forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (a
a, Change a
forall a. Change a
Leave) (\a
a -> (a
a, Change a
forall a. Change a
Leave))

-- ** Modifying functions

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:delete delete>@.
{-# INLINE [1] delete #-}
delete :: (Monad m) => Focus a m ()
delete :: forall (m :: * -> *) a. Monad m => Focus a m ()
delete = Change a -> (a -> Change a) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases Change a
forall a. Change a
Leave (Change a -> a -> Change a
forall a b. a -> b -> a
const Change a
forall a. Change a
Remove)

-- |
-- Lookup an element and delete it if it exists.
--
-- Same as @'lookup' <* 'delete'@.
{-# RULES
"lookup <* delete" [~1] lookup <* delete = lookupAndDelete
  #-}

{-# INLINE lookupAndDelete #-}
lookupAndDelete :: (Monad m) => Focus a m (Maybe a)
lookupAndDelete :: forall (m :: * -> *) a. Monad m => Focus a m (Maybe a)
lookupAndDelete = (Maybe a, Change a)
-> (a -> (Maybe a, Change a)) -> Focus a m (Maybe a)
forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (Maybe a
forall a. Maybe a
Nothing, Change a
forall a. Change a
Leave) (\a
element -> (a -> Maybe a
forall a. a -> Maybe a
Just a
element, Change a
forall a. Change a
Remove))

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:insert insert>@.
{-# INLINE insert #-}
insert :: (Monad m) => a -> Focus a m ()
insert :: forall (m :: * -> *) a. Monad m => a -> Focus a m ()
insert a
a = Change a -> (a -> Change a) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases (a -> Change a
forall a. a -> Change a
Set a
a) (Change a -> a -> Change a
forall a b. a -> b -> a
const (a -> Change a
forall a. a -> Change a
Set a
a))

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:insertWith insertWith>@
-- with a better name.
{-# INLINE insertOrMerge #-}
insertOrMerge :: (Monad m) => (a -> a -> a) -> a -> Focus a m ()
insertOrMerge :: forall (m :: * -> *) a.
Monad m =>
(a -> a -> a) -> a -> Focus a m ()
insertOrMerge a -> a -> a
merge a
value = Change a -> (a -> Change a) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases (a -> Change a
forall a. a -> Change a
Set a
value) (a -> Change a
forall a. a -> Change a
Set (a -> Change a) -> (a -> a) -> a -> Change a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> a -> a
merge a
value)

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:alter alter>@.
{-# INLINE alter #-}
alter :: (Monad m) => (Maybe a -> Maybe a) -> Focus a m ()
alter :: forall (m :: * -> *) a.
Monad m =>
(Maybe a -> Maybe a) -> Focus a m ()
alter Maybe a -> Maybe a
fn = Change a -> (a -> Change a) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases (Change a -> (a -> Change a) -> Maybe a -> Change a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Change a
forall a. Change a
Leave a -> Change a
forall a. a -> Change a
Set (Maybe a -> Maybe a
fn Maybe a
forall a. Maybe a
Nothing)) (Change a -> (a -> Change a) -> Maybe a -> Change a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Change a
forall a. Change a
Remove a -> Change a
forall a. a -> Change a
Set (Maybe a -> Change a) -> (a -> Maybe a) -> a -> Change a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe a -> Maybe a
fn (Maybe a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a
forall a. a -> Maybe a
Just)

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:adjust adjust>@.
{-# INLINE adjust #-}
adjust :: (Monad m) => (a -> a) -> Focus a m ()
adjust :: forall (m :: * -> *) a. Monad m => (a -> a) -> Focus a m ()
adjust a -> a
fn = Change a -> (a -> Change a) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases Change a
forall a. Change a
Leave (a -> Change a
forall a. a -> Change a
Set (a -> Change a) -> (a -> a) -> a -> Change a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> a
fn)

-- |
-- Reproduces the behaviour of
-- @Data.Map.<http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Map-Lazy.html#v:update update>@.
{-# INLINE update #-}
update :: (Monad m) => (a -> Maybe a) -> Focus a m ()
update :: forall (m :: * -> *) a. Monad m => (a -> Maybe a) -> Focus a m ()
update a -> Maybe a
fn = Change a -> (a -> Change a) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases Change a
forall a. Change a
Leave (Change a -> (a -> Change a) -> Maybe a -> Change a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Change a
forall a. Change a
Remove a -> Change a
forall a. a -> Change a
Set (Maybe a -> Change a) -> (a -> Maybe a) -> a -> Change a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a
fn)

-- |
-- Same as all of the following expressions:
--
-- @\f g -> fmap (fmap f) lookup <* adjust g@
-- @\f g -> liftStateFn (f &&& g)@
-- @\f g -> liftStateFn ((,) <$> f <*> g)@
accessAndAdjust :: (Monad m) => (s -> a) -> (s -> s) -> Focus s m (Maybe a)
accessAndAdjust :: forall (m :: * -> *) s a.
Monad m =>
(s -> a) -> (s -> s) -> Focus s m (Maybe a)
accessAndAdjust s -> a
f s -> s
g =
  (s -> (a, s)) -> Focus s m (Maybe a)
forall (m :: * -> *) s a.
Monad m =>
(s -> (a, s)) -> Focus s m (Maybe a)
liftStateFn (s -> a
f (s -> a) -> (s -> s) -> s -> (a, s)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& s -> s
g)

-- |
-- Lift a pure state monad.
liftState :: (Monad m) => State s a -> Focus s m (Maybe a)
liftState :: forall (m :: * -> *) s a.
Monad m =>
State s a -> Focus s m (Maybe a)
liftState (StateT s -> Identity (a, s)
fn) =
  (s -> (a, s)) -> Focus s m (Maybe a)
forall (m :: * -> *) s a.
Monad m =>
(s -> (a, s)) -> Focus s m (Maybe a)
liftStateFn (Identity (a, s) -> (a, s)
forall a. Identity a -> a
runIdentity (Identity (a, s) -> (a, s))
-> (s -> Identity (a, s)) -> s -> (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. s -> Identity (a, s)
fn)

-- |
-- Lift a pure state-monad-like function.
liftStateFn :: (Monad m) => (s -> (a, s)) -> Focus s m (Maybe a)
liftStateFn :: forall (m :: * -> *) s a.
Monad m =>
(s -> (a, s)) -> Focus s m (Maybe a)
liftStateFn s -> (a, s)
fn =
  m (Maybe a, Change s)
-> (s -> m (Maybe a, Change s)) -> Focus s m (Maybe a)
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus
    ((Maybe a, Change s) -> m (Maybe a, Change s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, Change s
forall a. Change a
Leave))
    (\s
s -> case s -> (a, s)
fn s
s of (a
a, s
s) -> (Maybe a, Change s) -> m (Maybe a, Change s)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a, s -> Change s
forall a. a -> Change a
Set s
s))

-- ** Construction utils

-- |
-- Lift pure functions which handle the cases of presence and absence of the element.
{-# INLINE cases #-}
cases :: (Monad m) => (b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases :: forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (b, Change a)
sendNone a -> (b, Change a)
sendSome = m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus ((b, Change a) -> m (b, Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b, Change a)
sendNone) ((b, Change a) -> m (b, Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, Change a) -> m (b, Change a))
-> (a -> (b, Change a)) -> a -> m (b, Change a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> (b, Change a)
sendSome)

-- |
-- Lift pure functions which handle the cases of presence and absence of the element and produce no result.
{-# INLINE unitCases #-}
unitCases :: (Monad m) => Change a -> (a -> Change a) -> Focus a m ()
unitCases :: forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases Change a
sendNone a -> Change a
sendSome = ((), Change a) -> (a -> ((), Change a)) -> Focus a m ()
forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases ((), Change a
sendNone) (\a
a -> ((), a -> Change a
sendSome a
a))

-- * Monadic functions

-- ** Reading functions

-- |
-- A monadic version of 'lookupWithDefault'.
{-# INLINE [1] lookupWithDefaultM #-}
lookupWithDefaultM :: (Monad m) => m a -> Focus a m a
lookupWithDefaultM :: forall (m :: * -> *) a. Monad m => m a -> Focus a m a
lookupWithDefaultM m a
aM = m (a, Change a) -> (a -> m (a, Change a)) -> Focus a m a
forall (m :: * -> *) b a.
m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
casesM ((a -> Change a -> (a, Change a))
-> m a -> m (Change a) -> m (a, Change a)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) m a
aM (Change a -> m (Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Change a
forall a. Change a
Leave)) (\a
a -> (a, Change a) -> m (a, Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Change a
forall a. Change a
Leave))

-- ** Modifying functions

-- |
-- A monadic version of 'insert'.
{-# INLINE insertM #-}
insertM :: (Monad m) => m a -> Focus a m ()
insertM :: forall (m :: * -> *) a. Monad m => m a -> Focus a m ()
insertM m a
aM = m (Change a) -> (a -> m (Change a)) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM ((a -> Change a) -> m a -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Change a
forall a. a -> Change a
Set m a
aM) (m (Change a) -> a -> m (Change a)
forall a b. a -> b -> a
const ((a -> Change a) -> m a -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Change a
forall a. a -> Change a
Set m a
aM))

-- |
-- A monadic version of 'insertOrMerge'.
{-# INLINE insertOrMergeM #-}
insertOrMergeM :: (Monad m) => (a -> a -> m a) -> m a -> Focus a m ()
insertOrMergeM :: forall (m :: * -> *) a.
Monad m =>
(a -> a -> m a) -> m a -> Focus a m ()
insertOrMergeM a -> a -> m a
merge m a
aM = m (Change a) -> (a -> m (Change a)) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM ((a -> Change a) -> m a -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Change a
forall a. a -> Change a
Set m a
aM) (\a
a' -> m a
aM m a -> (a -> m (Change a)) -> m (Change a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> (a -> Change a) -> m a -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Change a
forall a. a -> Change a
Set (a -> a -> m a
merge a
a a
a'))

-- |
-- A monadic version of 'alter'.
{-# INLINE alterM #-}
alterM :: (Monad m) => (Maybe a -> m (Maybe a)) -> Focus a m ()
alterM :: forall (m :: * -> *) a.
Monad m =>
(Maybe a -> m (Maybe a)) -> Focus a m ()
alterM Maybe a -> m (Maybe a)
fn = m (Change a) -> (a -> m (Change a)) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM ((Maybe a -> Change a) -> m (Maybe a) -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change a -> (a -> Change a) -> Maybe a -> Change a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Change a
forall a. Change a
Leave a -> Change a
forall a. a -> Change a
Set) (Maybe a -> m (Maybe a)
fn Maybe a
forall a. Maybe a
Nothing)) ((Maybe a -> Change a) -> m (Maybe a) -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change a -> (a -> Change a) -> Maybe a -> Change a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Change a
forall a. Change a
Remove a -> Change a
forall a. a -> Change a
Set) (m (Maybe a) -> m (Change a))
-> (a -> m (Maybe a)) -> a -> m (Change a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Maybe a -> m (Maybe a)
fn (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a
forall a. a -> Maybe a
Just)

-- |
-- A monadic version of 'adjust'.
{-# INLINE adjustM #-}
adjustM :: (Monad m) => (a -> m a) -> Focus a m ()
adjustM :: forall (m :: * -> *) a. Monad m => (a -> m a) -> Focus a m ()
adjustM a -> m a
fn = (a -> m (Maybe a)) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
(a -> m (Maybe a)) -> Focus a m ()
updateM ((a -> Maybe a) -> m a -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (m a -> m (Maybe a)) -> (a -> m a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m a
fn)

-- |
-- A monadic version of 'update'.
{-# INLINE updateM #-}
updateM :: (Monad m) => (a -> m (Maybe a)) -> Focus a m ()
updateM :: forall (m :: * -> *) a.
Monad m =>
(a -> m (Maybe a)) -> Focus a m ()
updateM a -> m (Maybe a)
fn = m (Change a) -> (a -> m (Change a)) -> Focus a m ()
forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM (Change a -> m (Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Change a
forall a. Change a
Leave) ((Maybe a -> Change a) -> m (Maybe a) -> m (Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Change a -> (a -> Change a) -> Maybe a -> Change a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Change a
forall a. Change a
Remove a -> Change a
forall a. a -> Change a
Set) (m (Maybe a) -> m (Change a))
-> (a -> m (Maybe a)) -> a -> m (Change a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m (Maybe a)
fn)

-- ** Construction utils

-- |
-- Lift monadic functions which handle the cases of presence and absence of the element.
{-# INLINE casesM #-}
casesM :: m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
casesM :: forall (m :: * -> *) b a.
m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
casesM m (b, Change a)
sendNone a -> m (b, Change a)
sendSome = m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m (b, Change a)
sendNone a -> m (b, Change a)
sendSome

-- |
-- Lift monadic functions which handle the cases of presence and absence of the element and produce no result.
{-# INLINE unitCasesM #-}
unitCasesM :: (Monad m) => m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM :: forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM m (Change a)
sendNone a -> m (Change a)
sendSome = m ((), Change a) -> (a -> m ((), Change a)) -> Focus a m ()
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus ((Change a -> ((), Change a)) -> m (Change a) -> m ((), Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((),) m (Change a)
sendNone) (\a
a -> (Change a -> ((), Change a)) -> m (Change a) -> m ((), Change a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((),) (a -> m (Change a)
sendSome a
a))

-- * Composition

-- |
-- Map the Focus input.
{-# INLINE mappingInput #-}
mappingInput :: (Monad m) => (a -> b) -> (b -> a) -> Focus a m x -> Focus b m x
mappingInput :: forall (m :: * -> *) a b x.
Monad m =>
(a -> b) -> (b -> a) -> Focus a m x -> Focus b m x
mappingInput a -> b
aToB b -> a
bToA (Focus m (x, Change a)
consealA a -> m (x, Change a)
revealA) = m (x, Change b) -> (b -> m (x, Change b)) -> Focus b m x
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m (x, Change b)
consealB b -> m (x, Change b)
revealB
  where
    consealB :: m (x, Change b)
consealB = do
      (x
x, Change a
aChange) <- m (x, Change a)
consealA
      (x, Change b) -> m (x, Change b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (x
x, (a -> b) -> Change a -> Change b
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
aToB Change a
aChange)
    revealB :: b -> m (x, Change b)
revealB b
b = do
      (x
x, Change a
aChange) <- a -> m (x, Change a)
revealA (b -> a
bToA b
b)
      (x, Change b) -> m (x, Change b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (x
x, (a -> b) -> Change a -> Change b
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
aToB Change a
aChange)

-- * Change-inspecting functions

-- |
-- Extends the output with the input.
{-# INLINE extractingInput #-}
extractingInput :: (Monad m) => Focus a m b -> Focus a m (b, Maybe a)
extractingInput :: forall (m :: * -> *) a b.
Monad m =>
Focus a m b -> Focus a m (b, Maybe a)
extractingInput (Focus m (b, Change a)
absent a -> m (b, Change a)
present) =
  m ((b, Maybe a), Change a)
-> (a -> m ((b, Maybe a), Change a)) -> Focus a m (b, Maybe a)
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m ((b, Maybe a), Change a)
newAbsent a -> m ((b, Maybe a), Change a)
newPresent
  where
    newAbsent :: m ((b, Maybe a), Change a)
newAbsent = do
      (b
b, Change a
change) <- m (b, Change a)
absent
      ((b, Maybe a), Change a) -> m ((b, Maybe a), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, Maybe a
forall a. Maybe a
Nothing), Change a
change)
    newPresent :: a -> m ((b, Maybe a), Change a)
newPresent a
element = do
      (b
b, Change a
change) <- a -> m (b, Change a)
present a
element
      ((b, Maybe a), Change a) -> m ((b, Maybe a), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, a -> Maybe a
forall a. a -> Maybe a
Just a
element), Change a
change)

-- |
-- Extends the output with the change performed.
{-# INLINE extractingChange #-}
extractingChange :: (Monad m) => Focus a m b -> Focus a m (b, Change a)
extractingChange :: forall (m :: * -> *) a b.
Monad m =>
Focus a m b -> Focus a m (b, Change a)
extractingChange (Focus m (b, Change a)
absent a -> m (b, Change a)
present) =
  m ((b, Change a), Change a)
-> (a -> m ((b, Change a), Change a)) -> Focus a m (b, Change a)
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m ((b, Change a), Change a)
newAbsent a -> m ((b, Change a), Change a)
newPresent
  where
    newAbsent :: m ((b, Change a), Change a)
newAbsent = do
      (b
b, Change a
change) <- m (b, Change a)
absent
      ((b, Change a), Change a) -> m ((b, Change a), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, Change a
change), Change a
change)
    newPresent :: a -> m ((b, Change a), Change a)
newPresent a
element = do
      (b
b, Change a
change) <- a -> m (b, Change a)
present a
element
      ((b, Change a), Change a) -> m ((b, Change a), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, Change a
change), Change a
change)

-- |
-- Extends the output with a projection on the change that was performed.
{-# INLINE projectingChange #-}
projectingChange :: (Monad m) => (Change a -> c) -> Focus a m b -> Focus a m (b, c)
projectingChange :: forall (m :: * -> *) a c b.
Monad m =>
(Change a -> c) -> Focus a m b -> Focus a m (b, c)
projectingChange Change a -> c
fn (Focus m (b, Change a)
absent a -> m (b, Change a)
present) =
  m ((b, c), Change a)
-> (a -> m ((b, c), Change a)) -> Focus a m (b, c)
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m ((b, c), Change a)
newAbsent a -> m ((b, c), Change a)
newPresent
  where
    newAbsent :: m ((b, c), Change a)
newAbsent = do
      (b
b, Change a
change) <- m (b, Change a)
absent
      ((b, c), Change a) -> m ((b, c), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, Change a -> c
fn Change a
change), Change a
change)
    newPresent :: a -> m ((b, c), Change a)
newPresent a
element = do
      (b
b, Change a
change) <- a -> m (b, Change a)
present a
element
      ((b, c), Change a) -> m ((b, c), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, Change a -> c
fn Change a
change), Change a
change)

-- |
-- Extends the output with a flag,
-- signaling whether a change, which is not 'Leave', has been introduced.
{-# INLINE testingIfModifies #-}
testingIfModifies :: (Monad m) => Focus a m b -> Focus a m (b, Bool)
testingIfModifies :: forall (m :: * -> *) a b.
Monad m =>
Focus a m b -> Focus a m (b, Bool)
testingIfModifies =
  (Change a -> Bool) -> Focus a m b -> Focus a m (b, Bool)
forall (m :: * -> *) a c b.
Monad m =>
(Change a -> c) -> Focus a m b -> Focus a m (b, c)
projectingChange ((Change a -> Bool) -> Focus a m b -> Focus a m (b, Bool))
-> (Change a -> Bool) -> Focus a m b -> Focus a m (b, Bool)
forall a b. (a -> b) -> a -> b
$ \case
    Change a
Leave -> Bool
False
    Change a
_ -> Bool
True

-- |
-- Extends the output with a flag,
-- signaling whether the 'Remove' change has been introduced.
{-# INLINE testingIfRemoves #-}
testingIfRemoves :: (Monad m) => Focus a m b -> Focus a m (b, Bool)
testingIfRemoves :: forall (m :: * -> *) a b.
Monad m =>
Focus a m b -> Focus a m (b, Bool)
testingIfRemoves =
  (Change a -> Bool) -> Focus a m b -> Focus a m (b, Bool)
forall (m :: * -> *) a c b.
Monad m =>
(Change a -> c) -> Focus a m b -> Focus a m (b, c)
projectingChange ((Change a -> Bool) -> Focus a m b -> Focus a m (b, Bool))
-> (Change a -> Bool) -> Focus a m b -> Focus a m (b, Bool)
forall a b. (a -> b) -> a -> b
$ \case
    Change a
Remove -> Bool
True
    Change a
_ -> Bool
False

-- |
-- Extends the output with a flag,
-- signaling whether an item will be inserted.
-- That is, it didn't exist before and a 'Set' change is introduced.
{-# INLINE testingIfInserts #-}
testingIfInserts :: (Monad m) => Focus a m b -> Focus a m (b, Bool)
testingIfInserts :: forall (m :: * -> *) a b.
Monad m =>
Focus a m b -> Focus a m (b, Bool)
testingIfInserts (Focus m (b, Change a)
absent a -> m (b, Change a)
present) =
  m ((b, Bool), Change a)
-> (a -> m ((b, Bool), Change a)) -> Focus a m (b, Bool)
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m ((b, Bool), Change a)
newAbsent a -> m ((b, Bool), Change a)
newPresent
  where
    newAbsent :: m ((b, Bool), Change a)
newAbsent = do
      (b
output, Change a
change) <- m (b, Change a)
absent
      let testResult :: Bool
testResult = case Change a
change of
            Set a
_ -> Bool
True
            Change a
_ -> Bool
False
       in ((b, Bool), Change a) -> m ((b, Bool), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
output, Bool
testResult), Change a
change)
    newPresent :: a -> m ((b, Bool), Change a)
newPresent a
element = do
      (b
output, Change a
change) <- a -> m (b, Change a)
present a
element
      ((b, Bool), Change a) -> m ((b, Bool), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
output, Bool
False), Change a
change)

-- |
-- Extend the output with a flag, signaling how the size will be affected by the change.
{-# INLINE testingSizeChange #-}
testingSizeChange ::
  (Monad m) =>
  -- | Decreased
  sizeChange ->
  -- | Didn't change
  sizeChange ->
  -- | Increased
  sizeChange ->
  Focus a m b ->
  Focus a m (b, sizeChange)
testingSizeChange :: forall (m :: * -> *) sizeChange a b.
Monad m =>
sizeChange
-> sizeChange
-> sizeChange
-> Focus a m b
-> Focus a m (b, sizeChange)
testingSizeChange sizeChange
dec sizeChange
none sizeChange
inc (Focus m (b, Change a)
absent a -> m (b, Change a)
present) =
  m ((b, sizeChange), Change a)
-> (a -> m ((b, sizeChange), Change a))
-> Focus a m (b, sizeChange)
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus m ((b, sizeChange), Change a)
newAbsent a -> m ((b, sizeChange), Change a)
newPresent
  where
    newAbsent :: m ((b, sizeChange), Change a)
newAbsent = do
      (b
output, Change a
change) <- m (b, Change a)
absent
      let sizeChange :: sizeChange
sizeChange = case Change a
change of
            Set a
_ -> sizeChange
inc
            Change a
_ -> sizeChange
none
       in ((b, sizeChange), Change a) -> m ((b, sizeChange), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
output, sizeChange
sizeChange), Change a
change)
    newPresent :: a -> m ((b, sizeChange), Change a)
newPresent a
element = do
      (b
output, Change a
change) <- a -> m (b, Change a)
present a
element
      let sizeChange :: sizeChange
sizeChange = case Change a
change of
            Change a
Remove -> sizeChange
dec
            Change a
_ -> sizeChange
none
       in ((b, sizeChange), Change a) -> m ((b, sizeChange), Change a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b
output, sizeChange
sizeChange), Change a
change)

-- * STM

-- |
-- Focus on the contents of a TVar.
{-# INLINE onTVarValue #-}
onTVarValue :: Focus a STM b -> Focus (TVar a) STM b
onTVarValue :: forall a b. Focus a STM b -> Focus (TVar a) STM b
onTVarValue (Focus STM (b, Change a)
concealA a -> STM (b, Change a)
presentA) = STM (b, Change (TVar a))
-> (TVar a -> STM (b, Change (TVar a))) -> Focus (TVar a) STM b
forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus STM (b, Change (TVar a))
concealTVar TVar a -> STM (b, Change (TVar a))
presentTVar
  where
    concealTVar :: STM (b, Change (TVar a))
concealTVar = STM (b, Change a)
concealA STM (b, Change a)
-> ((b, Change a) -> STM (b, Change (TVar a)))
-> STM (b, Change (TVar a))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Change a -> STM (Change (TVar a)))
-> (b, Change a) -> STM (b, Change (TVar a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (b, a) -> f (b, b)
traverse Change a -> STM (Change (TVar a))
forall {a}. Change a -> STM (Change (TVar a))
interpretAChange
      where
        interpretAChange :: Change a -> STM (Change (TVar a))
interpretAChange = \case
          Change a
Leave -> Change (TVar a) -> STM (Change (TVar a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Change (TVar a)
forall a. Change a
Leave
          Set !a
a -> TVar a -> Change (TVar a)
forall a. a -> Change a
Set (TVar a -> Change (TVar a))
-> STM (TVar a) -> STM (Change (TVar a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> STM (TVar a)
forall a. a -> STM (TVar a)
newTVar a
a
          Change a
Remove -> Change (TVar a) -> STM (Change (TVar a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Change (TVar a)
forall a. Change a
Leave
    presentTVar :: TVar a -> STM (b, Change (TVar a))
presentTVar TVar a
var = TVar a -> STM a
forall a. TVar a -> STM a
readTVar TVar a
var STM a -> (a -> STM (b, Change a)) -> STM (b, Change a)
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> STM (b, Change a)
presentA STM (b, Change a)
-> ((b, Change a) -> STM (b, Change (TVar a)))
-> STM (b, Change (TVar a))
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Change a -> STM (Change (TVar a)))
-> (b, Change a) -> STM (b, Change (TVar a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (b, a) -> f (b, b)
traverse Change a -> STM (Change (TVar a))
interpretAChange
      where
        interpretAChange :: Change a -> STM (Change (TVar a))
interpretAChange = \case
          Change a
Leave -> Change (TVar a) -> STM (Change (TVar a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Change (TVar a)
forall a. Change a
Leave
          Set !a
a -> TVar a -> a -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar a
var a
a STM () -> Change (TVar a) -> STM (Change (TVar a))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Change (TVar a)
forall a. Change a
Leave
          Change a
Remove -> Change (TVar a) -> STM (Change (TVar a))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Change (TVar a)
forall a. Change a
Remove