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 -> Focus element m a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: 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 result :: a
result = 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 (m :: * -> *) a. Monad m => a -> m a
return (a
result, Change element
forall a. Change a
Leave)) (\ element :: element
element -> (a, Change element) -> m (a, Change element)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, element -> Change element
forall a. a -> Change a
Set element
element))
  >>= :: Focus element m a -> (a -> Focus element m b) -> Focus element m b
(>>=) (Focus aAbsent :: m (a, Change element)
aAbsent bPresent :: element -> m (a, Change element)
bPresent) bKleisli :: a -> Focus element m b
bKleisli = let
    sendSome :: element -> m (b, Change element)
sendSome element :: element
element = do
      (aResult :: a
aResult, aChange :: Change element
aChange) <- element -> m (a, Change element)
bPresent element
element
      case a -> Focus element m b
bKleisli a
aResult of
        Focus bAbsent :: m (b, Change element)
bAbsent bOnElement :: element -> m (b, Change element)
bOnElement -> case Change element
aChange of
          Leave -> element -> m (b, Change element)
bOnElement element
element
          Remove -> m (b, Change element)
bAbsent
          Set newElement :: element
newElement -> element -> m (b, Change element)
bOnElement element
newElement
    sendNone :: m (b, Change element)
sendNone = do
      (aResult :: a
aResult, aChange :: Change element
aChange) <- m (a, Change element)
aAbsent
      case a -> Focus element m b
bKleisli a
aResult of
        Focus bAbsent :: m (b, Change element)
bAbsent bOnElement :: element -> m (b, Change element)
bOnElement -> case Change element
aChange of
          Set newElement :: element
newElement -> element -> m (b, Change element)
bOnElement element
newElement
          Leave -> m (b, Change element)
bAbsent
          Remove -> m (b, Change element)
bAbsent
    in 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)
sendNone element -> m (b, Change element)
sendSome

instance MonadTrans (Focus element) where
  lift :: m a -> Focus element m a
lift m :: 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)


-- * 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:lookup lookup>@.
-}
{-# 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 -> (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 = (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
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) (\ element :: 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
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 merge :: a -> a -> a
merge value :: 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 fn :: 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
Leave 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 fn :: 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 fn :: 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)

-- ** 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 sendNone :: (b, Change a)
sendNone sendSome :: 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 sendNone :: Change a
sendNone sendSome :: 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 -> ((), 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 aM :: 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 -> (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 aM :: 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 merge :: a -> a -> m a
merge aM :: 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
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 -> (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 fn :: 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
Leave 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 fn :: 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 fn :: 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
Leave 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 sendNone :: m (b, Change a)
sendNone sendSome :: 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 sendNone :: m (Change a)
sendNone sendSome :: 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
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 aToB :: a -> b
aToB bToA :: b -> a
bToA (Focus consealA :: m (x, Change a)
consealA revealA :: 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
x, aChange :: 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
b = do
    (x :: x
x, aChange :: 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 absent :: m (b, Change a)
absent present :: 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
b, change :: 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 element :: a
element = do
      (b :: b
b, change :: 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 absent :: m (b, Change a)
absent present :: 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
b, change :: 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 element :: a
element = do
      (b :: b
b, change :: 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 fn :: Change a -> c
fn (Focus absent :: m (b, Change a)
absent present :: 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
b, change :: 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 element :: a
element = do
      (b :: b
b, change :: 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
    Leave -> Bool
False
    _ -> 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
    Remove -> Bool
True
    _ -> 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 absent :: m (b, Change a)
absent present :: 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
      (output :: b
output, change :: Change a
change) <- m (b, Change a)
absent
      let testResult :: Bool
testResult = case Change a
change of
            Set _ -> Bool
True
            _ -> 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 element :: a
element = do
      (output :: b
output, change :: 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 dec :: sizeChange
dec none :: sizeChange
none inc :: sizeChange
inc (Focus absent :: m (b, Change a)
absent present :: 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
      (output :: b
output, change :: Change a
change) <- m (b, Change a)
absent
      let sizeChange :: sizeChange
sizeChange = case Change a
change of
            Set _ -> sizeChange
inc
            _ -> 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 element :: a
element = do
      (output :: b
output, change :: Change a
change) <- a -> m (b, Change a)
present a
element
      let sizeChange :: sizeChange
sizeChange = case Change a
change of
            Remove -> sizeChange
dec
            _ -> 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 concealA :: STM (b, Change a)
concealA presentA :: 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
      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
      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 var :: 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
      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
      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