module Focus where

import Focus.Prelude hiding (adjust, update, alter, insert, delete, 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 :: 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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, Change element
forall a. Change a
Leave)))
  <*> :: 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 :: a -> Focus element m a
return = a -> Focus element m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  >>= :: 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Change element -> Change element)
-> (b, Change element) -> (b, Change element)
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 :: 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 (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 (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 =
  Leave {-^ Produce no changes -} |
  Remove {-^ Delete it -} |
  Set a {-^ Set its value to the provided one -}
  deriving (a -> Change b -> Change a
(a -> b) -> Change a -> Change b
(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
<$ :: a -> Change b -> Change a
$c<$ :: forall a b. a -> Change b -> Change a
fmap :: (a -> b) -> Change a -> Change b
$cfmap :: forall a b. (a -> b) -> Change a -> Change b
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
/= :: Change a -> Change a -> Bool
$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
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
min :: Change a -> Change a -> Change a
$cmin :: forall a. Ord a => Change a -> Change a -> Change a
max :: Change a -> Change a -> Change a
$cmax :: forall a. Ord a => Change a -> Change a -> Change a
>= :: 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
$c< :: forall a. Ord a => Change a -> Change a -> Bool
compare :: Change a -> Change a -> Ordering
$ccompare :: forall a. Ord a => Change a -> Change a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (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
showList :: [Change a] -> ShowS
$cshowList :: forall a. Show a => [Change a] -> ShowS
show :: Change a -> String
$cshow :: forall a. Show a => Change a -> String
showsPrec :: Int -> Change a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> 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 :: Focus a m Bool
member = (Maybe a -> Bool) -> Focus a m (Maybe a) -> Focus a m Bool
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 :: 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 :: 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 :: 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 :: 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 :: 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 :: (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 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 :: (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 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 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 :: (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 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 :: (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 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 :: (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 (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 :: 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 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 :: (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 (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 (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 :: (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 (m :: * -> *) a. Monad m => a -> m a
return (b, Change a)
sendNone) ((b, Change a) -> m (b, Change 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 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 :: 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 :: 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.
Monad m =>
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 (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 (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 :: 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 (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 (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 :: (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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ a
a -> (a -> Change a) -> m a -> m (Change a)
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 :: (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 (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 (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 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 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 :: (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 (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 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 :: (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 (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 (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 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 :: Monad m => m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
casesM :: 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 :: 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 (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 (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 :: (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 (m :: * -> *) a. Monad m => a -> m a
return (x
x, (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 (m :: * -> *) a. Monad m => a -> m a
return (x
x, (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 :: 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 (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 (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 :: 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 (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 (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 :: (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 (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 (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 :: 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 :: 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 :: 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 (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 (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 => sizeChange {-^ Decreased -} -> sizeChange {-^ Didn't change -} -> sizeChange {-^ Increased -} -> Focus a m b -> Focus a m (b, sizeChange)
testingSizeChange :: 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 (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 (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 :: 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 (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)
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 (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 (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 (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 (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)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Change (TVar a)
forall a. Change a
Remove