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 = forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus (forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, forall a. Change a
Leave)) (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, forall a. Change a
Leave)))
  <*> :: forall a 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 = 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 =
    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 forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Monoid a => a -> a -> a
mappend Change element
lChange))
            Set element
newElement -> element -> m (b, Change element)
rPresent element
newElement forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Monoid a => a -> a -> a
mappend Change element
lChange))
            Set element
newElement -> element -> m (b, Change element)
rPresent element
newElement forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,forall a. Change a
Leave) m a
m) (forall a b. a -> b -> a
const (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,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 -> 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
<$ :: forall a b. a -> Change b -> Change a
$c<$ :: forall a b. a -> Change b -> Change a
fmap :: forall a b. (a -> b) -> Change a -> Change b
$cfmap :: forall a b. (a -> b) -> Change a -> Change b
Functor, Change a -> Change a -> Bool
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, Change a -> Change a -> Bool
Change a -> Change a -> Ordering
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
Ord, Int -> Change a -> ShowS
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 = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a b. a -> b -> a
const Bool
True)) 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 = forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (forall a. Maybe a
Nothing, forall a. Change a
Leave) (\a
a -> (forall a. a -> Maybe a
Just a
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 = forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (a
a, forall a. Change a
Leave) (\a
a -> (a
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 = forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases forall a. Change a
Leave (forall a b. a -> b -> a
const 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 = forall (m :: * -> *) b a.
Monad m =>
(b, Change a) -> (a -> (b, Change a)) -> Focus a m b
cases (forall a. Maybe a
Nothing, forall a. Change a
Leave) (\a
element -> (forall a. a -> Maybe a
Just a
element, 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 = forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases (forall a. a -> Change a
Set a
a) (forall a b. a -> b -> a
const (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 = forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases (forall a. a -> Change a
Set a
value) (forall a. a -> Change a
Set 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 = forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Change a
Leave forall a. a -> Change a
Set (Maybe a -> Maybe a
fn forall a. Maybe a
Nothing)) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Change a
Remove forall a. a -> Change a
Set 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 = forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases forall a. Change a
Leave (forall a. a -> Change a
Set 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 = forall (m :: * -> *) a.
Monad m =>
Change a -> (a -> Change a) -> Focus a m ()
unitCases forall a. Change a
Leave (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Change a
Remove forall a. a -> Change a
Set 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 =
  forall (m :: * -> *) s a.
Monad m =>
(s -> (a, s)) -> Focus s m (Maybe a)
liftStateFn (s -> a
f 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) =
  forall (m :: * -> *) s a.
Monad m =>
(s -> (a, s)) -> Focus s m (Maybe a)
liftStateFn (forall a. Identity a -> a
runIdentity 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 =
  forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus
    (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, forall a. Change a
Leave))
    (\s
s -> case s -> (a, s)
fn s
s of (a
a, s
s) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just a
a, 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 = forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus (forall (m :: * -> *) a. Monad m => a -> m a
return (b, Change a)
sendNone) (forall (m :: * -> *) a. Monad m => a -> m a
return 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 = 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 = forall (m :: * -> *) b a.
m (b, Change a) -> (a -> m (b, Change a)) -> Focus a m b
casesM (forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) m a
aM (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Change a
Leave)) (\a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
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 = forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Change a
Set m a
aM) (forall a b. a -> b -> a
const (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Change a
Set m a
aM) (\a
a' -> m a
aM forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 = forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Change a
Leave forall a. a -> Change a
Set) (Maybe a -> m (Maybe a)
fn forall a. Maybe a
Nothing)) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Change a
Remove forall a. a -> Change a
Set) 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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. 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 = forall (m :: * -> *) a.
Monad m =>
(a -> m (Maybe a)) -> Focus a m ()
updateM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just 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 = forall (m :: * -> *) a.
Monad m =>
m (Change a) -> (a -> m (Change a)) -> Focus a m ()
unitCasesM (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Change a
Leave) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Change a
Remove forall a. a -> Change a
Set) 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 = 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 = forall element (m :: * -> *) result.
m (result, Change element)
-> (element -> m (result, Change element))
-> Focus element m result
Focus (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((),) m (Change a)
sendNone) (\a
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 :: 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) = 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
      forall (m :: * -> *) a. Monad m => a -> m a
return (x
x, 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)
      forall (m :: * -> *) a. Monad m => a -> m a
return (x
x, 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) =
  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
      forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, 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
      forall (m :: * -> *) a. Monad m => a -> m a
return ((b
b, 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) =
  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
      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
      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) =
  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
      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
      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 =
  forall (m :: * -> *) a c b.
Monad m =>
(Change a -> c) -> Focus a m b -> Focus a m (b, c)
projectingChange 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 =
  forall (m :: * -> *) a c b.
Monad m =>
(Change a -> c) -> Focus a m b -> Focus a m (b, c)
projectingChange 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) =
  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 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
      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) =
  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 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 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) = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a}. Change a -> STM (Change (TVar a))
interpretAChange
      where
        interpretAChange :: Change a -> STM (Change (TVar a))
interpretAChange = \case
          Change a
Leave -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Change a
Leave
          Set !a
a -> forall a. a -> Change a
Set forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> STM (TVar a)
newTVar a
a
          Change a
Remove -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Change a
Leave
    presentTVar :: TVar a -> STM (b, Change (TVar a))
presentTVar TVar a
var = forall a. TVar a -> STM a
readTVar TVar a
var forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> STM (b, Change a)
presentA forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Change a
Leave
          Set !a
a -> forall a. TVar a -> a -> STM ()
writeTVar TVar a
var a
a forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Change a
Leave
          Change a
Remove -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Change a
Remove