module Agda.Utils.Update
  ( ChangeT
  , runChangeT, mapChangeT
  , UpdaterT
  , runUpdaterT
  , Change
  , MonadChange(..)
  , runChange
  , Updater
  , sharing
  , runUpdater
  , dirty
  , ifDirty
  , Updater1(..)
  , Updater2(..)
  ) where

-- Control.Monad.Fail import is redundant since GHC 8.8.1
import Control.Monad.Fail (MonadFail)

import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Trans.Control
import Control.Monad.Writer.Strict ( MonadWriter(..), Writer, WriterT, mapWriterT, runWriterT )

import Data.Monoid ( Any(..) )

import Agda.Utils.Tuple

-- * Change monad.

-- | The class of change monads.
class Monad m => MonadChange m where
  tellDirty   :: m () -- ^ Mark computation as having changed something.
  listenDirty :: m a -> m (a, Bool)

-- | The @ChangeT@ monad transformer.
newtype ChangeT m a = ChangeT { forall (m :: * -> *) a. ChangeT m a -> WriterT Any m a
fromChangeT :: WriterT Any m a }
  deriving ((forall a b. (a -> b) -> ChangeT m a -> ChangeT m b)
-> (forall a b. a -> ChangeT m b -> ChangeT m a)
-> Functor (ChangeT m)
forall a b. a -> ChangeT m b -> ChangeT m a
forall a b. (a -> b) -> ChangeT m a -> ChangeT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ChangeT m b -> ChangeT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ChangeT m a -> ChangeT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ChangeT m a -> ChangeT m b
fmap :: forall a b. (a -> b) -> ChangeT m a -> ChangeT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ChangeT m b -> ChangeT m a
<$ :: forall a b. a -> ChangeT m b -> ChangeT m a
Functor, Functor (ChangeT m)
Functor (ChangeT m) =>
(forall a. a -> ChangeT m a)
-> (forall a b. ChangeT m (a -> b) -> ChangeT m a -> ChangeT m b)
-> (forall a b c.
    (a -> b -> c) -> ChangeT m a -> ChangeT m b -> ChangeT m c)
-> (forall a b. ChangeT m a -> ChangeT m b -> ChangeT m b)
-> (forall a b. ChangeT m a -> ChangeT m b -> ChangeT m a)
-> Applicative (ChangeT m)
forall a. a -> ChangeT m a
forall a b. ChangeT m a -> ChangeT m b -> ChangeT m a
forall a b. ChangeT m a -> ChangeT m b -> ChangeT m b
forall a b. ChangeT m (a -> b) -> ChangeT m a -> ChangeT m b
forall a b c.
(a -> b -> c) -> ChangeT m a -> ChangeT m b -> ChangeT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (ChangeT m)
forall (m :: * -> *) a. Applicative m => a -> ChangeT m a
forall (m :: * -> *) a b.
Applicative m =>
ChangeT m a -> ChangeT m b -> ChangeT m a
forall (m :: * -> *) a b.
Applicative m =>
ChangeT m a -> ChangeT m b -> ChangeT m b
forall (m :: * -> *) a b.
Applicative m =>
ChangeT m (a -> b) -> ChangeT m a -> ChangeT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ChangeT m a -> ChangeT m b -> ChangeT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ChangeT m a
pure :: forall a. a -> ChangeT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ChangeT m (a -> b) -> ChangeT m a -> ChangeT m b
<*> :: forall a b. ChangeT m (a -> b) -> ChangeT m a -> ChangeT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ChangeT m a -> ChangeT m b -> ChangeT m c
liftA2 :: forall a b c.
(a -> b -> c) -> ChangeT m a -> ChangeT m b -> ChangeT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ChangeT m a -> ChangeT m b -> ChangeT m b
*> :: forall a b. ChangeT m a -> ChangeT m b -> ChangeT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ChangeT m a -> ChangeT m b -> ChangeT m a
<* :: forall a b. ChangeT m a -> ChangeT m b -> ChangeT m a
Applicative, Applicative (ChangeT m)
Applicative (ChangeT m) =>
(forall a b. ChangeT m a -> (a -> ChangeT m b) -> ChangeT m b)
-> (forall a b. ChangeT m a -> ChangeT m b -> ChangeT m b)
-> (forall a. a -> ChangeT m a)
-> Monad (ChangeT m)
forall a. a -> ChangeT m a
forall a b. ChangeT m a -> ChangeT m b -> ChangeT m b
forall a b. ChangeT m a -> (a -> ChangeT m b) -> ChangeT m b
forall (m :: * -> *). Monad m => Applicative (ChangeT m)
forall (m :: * -> *) a. Monad m => a -> ChangeT m a
forall (m :: * -> *) a b.
Monad m =>
ChangeT m a -> ChangeT m b -> ChangeT m b
forall (m :: * -> *) a b.
Monad m =>
ChangeT m a -> (a -> ChangeT m b) -> ChangeT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ChangeT m a -> (a -> ChangeT m b) -> ChangeT m b
>>= :: forall a b. ChangeT m a -> (a -> ChangeT m b) -> ChangeT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ChangeT m a -> ChangeT m b -> ChangeT m b
>> :: forall a b. ChangeT m a -> ChangeT m b -> ChangeT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ChangeT m a
return :: forall a. a -> ChangeT m a
Monad, (forall (m :: * -> *). Monad m => Monad (ChangeT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> ChangeT m a)
-> MonadTrans ChangeT
forall (m :: * -> *). Monad m => Monad (ChangeT m)
forall (m :: * -> *) a. Monad m => m a -> ChangeT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> ChangeT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> ChangeT m a
MonadTrans, Monad (ChangeT m)
Monad (ChangeT m) =>
(forall a. String -> ChangeT m a) -> MonadFail (ChangeT m)
forall a. String -> ChangeT m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (ChangeT m)
forall (m :: * -> *) a. MonadFail m => String -> ChangeT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> ChangeT m a
fail :: forall a. String -> ChangeT m a
MonadFail, Monad (ChangeT m)
Monad (ChangeT m) =>
(forall a. IO a -> ChangeT m a) -> MonadIO (ChangeT m)
forall a. IO a -> ChangeT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (ChangeT m)
forall (m :: * -> *) a. MonadIO m => IO a -> ChangeT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> ChangeT m a
liftIO :: forall a. IO a -> ChangeT m a
MonadIO)

-- This instance cannot be derived in older ghcs like 8.0
-- because of the associated type synonym.
-- 8.4 can derive it, but needs UndecidableInstances.
instance MonadTransControl ChangeT where
  type StT ChangeT a = (a, Any) -- StT (WriterT Any) a  would require UndecidableInstances
  liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run ChangeT -> m a) -> ChangeT m a
liftWith Run ChangeT -> m a
f = WriterT Any m a -> ChangeT m a
forall (m :: * -> *) a. WriterT Any m a -> ChangeT m a
ChangeT (WriterT Any m a -> ChangeT m a) -> WriterT Any m a -> ChangeT m a
forall a b. (a -> b) -> a -> b
$ (Run (WriterT Any) -> m a) -> WriterT Any m a
forall (m :: * -> *) a.
Monad m =>
(Run (WriterT Any) -> m a) -> WriterT Any m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith ((Run (WriterT Any) -> m a) -> WriterT Any m a)
-> (Run (WriterT Any) -> m a) -> WriterT Any m a
forall a b. (a -> b) -> a -> b
$ \ Run (WriterT Any)
runWriterT -> Run ChangeT -> m a
f (Run ChangeT -> m a) -> Run ChangeT -> m a
forall a b. (a -> b) -> a -> b
$ WriterT Any n b -> n (b, Any)
WriterT Any n b -> n (StT (WriterT Any) b)
Run (WriterT Any)
runWriterT (WriterT Any n b -> n (b, Any))
-> (ChangeT n b -> WriterT Any n b) -> ChangeT n b -> n (b, Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeT n b -> WriterT Any n b
forall (m :: * -> *) a. ChangeT m a -> WriterT Any m a
fromChangeT
  -- Andreas, 2020-04-17: these point-free variants do not seem to type check:
  -- liftWith f = ChangeT $ liftWith $ f . (. fromChangeT)
  -- liftWith = ChangeT . liftWith . (. (. fromChangeT))
  restoreT :: forall (m :: * -> *) a. Monad m => m (StT ChangeT a) -> ChangeT m a
restoreT = WriterT Any m a -> ChangeT m a
forall (m :: * -> *) a. WriterT Any m a -> ChangeT m a
ChangeT (WriterT Any m a -> ChangeT m a)
-> (m (a, Any) -> WriterT Any m a) -> m (a, Any) -> ChangeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (a, Any) -> WriterT Any m a
m (StT (WriterT Any) a) -> WriterT Any m a
forall (m :: * -> *) a.
Monad m =>
m (StT (WriterT Any) a) -> WriterT Any m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT

instance Monad m => MonadChange (ChangeT m) where
  tellDirty :: ChangeT m ()
tellDirty     = WriterT Any m () -> ChangeT m ()
forall (m :: * -> *) a. WriterT Any m a -> ChangeT m a
ChangeT (WriterT Any m () -> ChangeT m ())
-> WriterT Any m () -> ChangeT m ()
forall a b. (a -> b) -> a -> b
$ Any -> WriterT Any m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Any -> WriterT Any m ()) -> Any -> WriterT Any m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True
  listenDirty :: forall a. ChangeT m a -> ChangeT m (a, Bool)
listenDirty ChangeT m a
m = WriterT Any m (a, Bool) -> ChangeT m (a, Bool)
forall (m :: * -> *) a. WriterT Any m a -> ChangeT m a
ChangeT (WriterT Any m (a, Bool) -> ChangeT m (a, Bool))
-> WriterT Any m (a, Bool) -> ChangeT m (a, Bool)
forall a b. (a -> b) -> a -> b
$ do
    (a
a, Any Bool
dirty) <- WriterT Any m a -> WriterT Any m (a, Any)
forall a. WriterT Any m a -> WriterT Any m (a, Any)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen (ChangeT m a -> WriterT Any m a
forall (m :: * -> *) a. ChangeT m a -> WriterT Any m a
fromChangeT ChangeT m a
m)
    (a, Bool) -> WriterT Any m (a, Bool)
forall a. a -> WriterT Any m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Bool
dirty)

-- | Run a 'ChangeT' computation, returning result plus change flag.
runChangeT :: Functor m => ChangeT m a -> m (a, Bool)
runChangeT :: forall (m :: * -> *) a. Functor m => ChangeT m a -> m (a, Bool)
runChangeT = ((a, Any) -> (a, Bool)) -> m (a, Any) -> m (a, Bool)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Any -> Bool) -> (a, Any) -> (a, Bool)
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd Any -> Bool
getAny) (m (a, Any) -> m (a, Bool))
-> (ChangeT m a -> m (a, Any)) -> ChangeT m a -> m (a, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT Any m a -> m (a, Any)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT Any m a -> m (a, Any))
-> (ChangeT m a -> WriterT Any m a) -> ChangeT m a -> m (a, Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeT m a -> WriterT Any m a
forall (m :: * -> *) a. ChangeT m a -> WriterT Any m a
fromChangeT

-- | Run a 'ChangeT' computation, but ignore change flag.
execChangeT :: Functor m => ChangeT m a -> m a -- A library function, so keep
execChangeT :: forall (m :: * -> *) a. Functor m => ChangeT m a -> m a
execChangeT = ((a, Bool) -> a) -> m (a, Bool) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Bool) -> a
forall a b. (a, b) -> a
fst (m (a, Bool) -> m a)
-> (ChangeT m a -> m (a, Bool)) -> ChangeT m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeT m a -> m (a, Bool)
forall (m :: * -> *) a. Functor m => ChangeT m a -> m (a, Bool)
runChangeT

-- | Map a 'ChangeT' computation (monad transformer action).
mapChangeT :: (m (a, Any) -> n (b, Any)) -> ChangeT m a -> ChangeT n b
mapChangeT :: forall (m :: * -> *) a (n :: * -> *) b.
(m (a, Any) -> n (b, Any)) -> ChangeT m a -> ChangeT n b
mapChangeT m (a, Any) -> n (b, Any)
f (ChangeT WriterT Any m a
m) = WriterT Any n b -> ChangeT n b
forall (m :: * -> *) a. WriterT Any m a -> ChangeT m a
ChangeT ((m (a, Any) -> n (b, Any)) -> WriterT Any m a -> WriterT Any n b
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT m (a, Any) -> n (b, Any)
f WriterT Any m a
m)

-- Don't actually track changes with the identity monad:

-- | A mock change monad.  Always assume change has happened.
instance MonadChange Identity where
  tellDirty :: Identity ()
tellDirty   = () -> Identity ()
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  listenDirty :: forall a. Identity a -> Identity (a, Bool)
listenDirty = (a -> (a, Bool)) -> Identity a -> Identity (a, Bool)
forall a b. (a -> b) -> Identity a -> Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Bool
True)

instance Monad m => MonadChange (IdentityT m) where
  tellDirty :: IdentityT m ()
tellDirty   = m () -> IdentityT m ()
forall {k} (f :: k -> *) (a :: k). f a -> IdentityT f a
IdentityT    (m () -> IdentityT m ()) -> m () -> IdentityT m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  listenDirty :: forall a. IdentityT m a -> IdentityT m (a, Bool)
listenDirty = (m a -> m (a, Bool)) -> IdentityT m a -> IdentityT m (a, Bool)
forall {k1} {k2} (m :: k1 -> *) (a :: k1) (n :: k2 -> *) (b :: k2).
(m a -> n b) -> IdentityT m a -> IdentityT n b
mapIdentityT ((m a -> m (a, Bool)) -> IdentityT m a -> IdentityT m (a, Bool))
-> (m a -> m (a, Bool)) -> IdentityT m a -> IdentityT m (a, Bool)
forall a b. (a -> b) -> a -> b
$ (a -> (a, Bool)) -> m a -> m (a, Bool)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Bool
True)

-- * Pure endo function and updater

type UpdaterT m a = a -> ChangeT m a

-- | Blindly run an updater.
runUpdaterT :: Functor m => UpdaterT m a -> a -> m (a, Bool)
runUpdaterT :: forall (m :: * -> *) a.
Functor m =>
UpdaterT m a -> a -> m (a, Bool)
runUpdaterT UpdaterT m a
f a
a = ChangeT m a -> m (a, Bool)
forall (m :: * -> *) a. Functor m => ChangeT m a -> m (a, Bool)
runChangeT (ChangeT m a -> m (a, Bool)) -> ChangeT m a -> m (a, Bool)
forall a b. (a -> b) -> a -> b
$ UpdaterT m a
f a
a

type EndoFun a = a -> a
type Change  a = ChangeT Identity a
type Updater a = UpdaterT Identity a

-- NB:: Defined but not used
fromChange :: Change a -> Writer Any a
fromChange :: forall a. Change a -> Writer Any a
fromChange = ChangeT Identity a -> WriterT Any Identity a
forall (m :: * -> *) a. ChangeT m a -> WriterT Any m a
fromChangeT

-- | Run a 'Change' computation, returning result plus change flag.
{-# INLINE runChange #-}
runChange :: Change a -> (a, Bool)
runChange :: forall a. Change a -> (a, Bool)
runChange = Identity (a, Bool) -> (a, Bool)
forall a. Identity a -> a
runIdentity (Identity (a, Bool) -> (a, Bool))
-> (Change a -> Identity (a, Bool)) -> Change a -> (a, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Change a -> Identity (a, Bool)
forall (m :: * -> *) a. Functor m => ChangeT m a -> m (a, Bool)
runChangeT

-- | Blindly run an updater.
{-# INLINE runUpdater #-}
runUpdater :: Updater a -> a -> (a, Bool)
runUpdater :: forall a. Updater a -> a -> (a, Bool)
runUpdater Updater a
f a
a = Change a -> (a, Bool)
forall a. Change a -> (a, Bool)
runChange (Change a -> (a, Bool)) -> Change a -> (a, Bool)
forall a b. (a -> b) -> a -> b
$ Updater a
f a
a

-- | Mark a computation as dirty.
dirty :: Monad m => UpdaterT m a
dirty :: forall (m :: * -> *) a. Monad m => UpdaterT m a
dirty a
a = do
  ChangeT m ()
forall (m :: * -> *). MonadChange m => m ()
tellDirty
  a -> ChangeT m a
forall a. a -> ChangeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

{-# SPECIALIZE ifDirty :: Change a -> (a -> Change b) -> (a -> Change b) -> Change b #-}
{-# SPECIALIZE ifDirty :: Identity a -> (a -> Identity b) -> (a -> Identity b) -> Identity b #-}
ifDirty :: (Monad m, MonadChange m) => m a -> (a -> m b) -> (a -> m b) -> m b
ifDirty :: forall (m :: * -> *) a b.
(Monad m, MonadChange m) =>
m a -> (a -> m b) -> (a -> m b) -> m b
ifDirty m a
m a -> m b
f a -> m b
g = do
  (a
a, Bool
dirty) <- m a -> m (a, Bool)
forall a. m a -> m (a, Bool)
forall (m :: * -> *) a. MonadChange m => m a -> m (a, Bool)
listenDirty m a
m
  if Bool
dirty then a -> m b
f a
a else a -> m b
g a
a

-- * Proper updater (Q-combinators)

-- | Replace result of updating with original input if nothing has changed.
sharing :: Monad m => UpdaterT m a -> UpdaterT m a
sharing :: forall (m :: * -> *) a. Monad m => UpdaterT m a -> UpdaterT m a
sharing UpdaterT m a
f a
a = do
  (a
a', Bool
changed) <- ChangeT m a -> ChangeT m (a, Bool)
forall a. ChangeT m a -> ChangeT m (a, Bool)
forall (m :: * -> *) a. MonadChange m => m a -> m (a, Bool)
listenDirty (ChangeT m a -> ChangeT m (a, Bool))
-> ChangeT m a -> ChangeT m (a, Bool)
forall a b. (a -> b) -> a -> b
$ UpdaterT m a
f a
a
  UpdaterT m a
forall a. a -> ChangeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return UpdaterT m a -> UpdaterT m a
forall a b. (a -> b) -> a -> b
$ if Bool
changed then a
a' else a
a

-- | Eval an updater (using 'sharing').
evalUpdater :: Updater a -> EndoFun a
evalUpdater :: forall a. Updater a -> EndoFun a
evalUpdater Updater a
f a
a = (a, Bool) -> a
forall a b. (a, b) -> a
fst ((a, Bool) -> a) -> (a, Bool) -> a
forall a b. (a -> b) -> a -> b
$ Change a -> (a, Bool)
forall a. Change a -> (a, Bool)
runChange (Change a -> (a, Bool)) -> Change a -> (a, Bool)
forall a b. (a -> b) -> a -> b
$ Updater a -> Updater a
forall (m :: * -> *) a. Monad m => UpdaterT m a -> UpdaterT m a
sharing Updater a
f a
a

-- END REAL STUFF

-- * Updater transformer classes

-- ** Unary (functors)

-- | Like 'Functor', but preserving sharing.
class Traversable f => Updater1 f where
  updater1 :: Updater a -> Updater (f a)
  updates1 :: Updater a -> Updater (f a) -- ^ @= sharing . updater1@
  update1  :: Updater a -> EndoFun (f a)

  updater1   = (a -> ChangeT Identity a) -> f a -> ChangeT Identity (f a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> f a -> f (f b)
traverse
  updates1 Updater a
f = UpdaterT Identity (f a) -> UpdaterT Identity (f a)
forall (m :: * -> *) a. Monad m => UpdaterT m a -> UpdaterT m a
sharing (UpdaterT Identity (f a) -> UpdaterT Identity (f a))
-> UpdaterT Identity (f a) -> UpdaterT Identity (f a)
forall a b. (a -> b) -> a -> b
$ Updater a -> UpdaterT Identity (f a)
forall a. Updater a -> Updater (f a)
forall (f :: * -> *) a. Updater1 f => Updater a -> Updater (f a)
updater1 Updater a
f
  update1  Updater a
f = Updater (f a) -> EndoFun (f a)
forall a. Updater a -> EndoFun a
evalUpdater (Updater (f a) -> EndoFun (f a)) -> Updater (f a) -> EndoFun (f a)
forall a b. (a -> b) -> a -> b
$ Updater a -> Updater (f a)
forall a. Updater a -> Updater (f a)
forall (f :: * -> *) a. Updater1 f => Updater a -> Updater (f a)
updater1 Updater a
f

instance Updater1 Maybe where

instance Updater1 [] where
  updater1 :: forall a. Updater a -> Updater [a]
updater1 Updater a
f []       = [a] -> ChangeT Identity [a]
forall a. a -> ChangeT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  updater1 Updater a
f (a
x : [a]
xs) = (:) (a -> [a] -> [a])
-> ChangeT Identity a -> ChangeT Identity ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Updater a
f a
x ChangeT Identity ([a] -> [a])
-> ChangeT Identity [a] -> ChangeT Identity [a]
forall a b.
ChangeT Identity (a -> b)
-> ChangeT Identity a -> ChangeT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Updater a -> [a] -> ChangeT Identity [a]
forall a. Updater a -> Updater [a]
forall (f :: * -> *) a. Updater1 f => Updater a -> Updater (f a)
updates1 Updater a
f [a]
xs

-- ** Binary (bifunctors)

-- | Like 'Bifunctor', but preserving sharing.
class Updater2 f where
  updater2 :: Updater a -> Updater b -> Updater (f a b)
  updates2 :: Updater a -> Updater b -> Updater (f a b)
  update2  :: Updater a -> Updater b -> EndoFun (f a b)

  updates2 Updater a
f1 Updater b
f2 = UpdaterT Identity (f a b) -> UpdaterT Identity (f a b)
forall (m :: * -> *) a. Monad m => UpdaterT m a -> UpdaterT m a
sharing (UpdaterT Identity (f a b) -> UpdaterT Identity (f a b))
-> UpdaterT Identity (f a b) -> UpdaterT Identity (f a b)
forall a b. (a -> b) -> a -> b
$ Updater a -> Updater b -> UpdaterT Identity (f a b)
forall a b. Updater a -> Updater b -> Updater (f a b)
forall (f :: * -> * -> *) a b.
Updater2 f =>
Updater a -> Updater b -> Updater (f a b)
updater2 Updater a
f1 Updater b
f2
  update2  Updater a
f1 Updater b
f2 = Updater (f a b) -> EndoFun (f a b)
forall a. Updater a -> EndoFun a
evalUpdater (Updater (f a b) -> EndoFun (f a b))
-> Updater (f a b) -> EndoFun (f a b)
forall a b. (a -> b) -> a -> b
$ Updater a -> Updater b -> Updater (f a b)
forall a b. Updater a -> Updater b -> Updater (f a b)
forall (f :: * -> * -> *) a b.
Updater2 f =>
Updater a -> Updater b -> Updater (f a b)
updater2 Updater a
f1 Updater b
f2

instance Updater2 (,) where
  updater2 :: forall a b. Updater a -> Updater b -> Updater (a, b)
updater2 Updater a
f1 Updater b
f2 (a
a,b
b) = (,) (a -> b -> (a, b))
-> ChangeT Identity a -> ChangeT Identity (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Updater a -> Updater a
forall (m :: * -> *) a. Monad m => UpdaterT m a -> UpdaterT m a
sharing Updater a
f1 a
a ChangeT Identity (b -> (a, b))
-> ChangeT Identity b -> ChangeT Identity (a, b)
forall a b.
ChangeT Identity (a -> b)
-> ChangeT Identity a -> ChangeT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Updater b -> Updater b
forall (m :: * -> *) a. Monad m => UpdaterT m a -> UpdaterT m a
sharing Updater b
f2 b
b

instance Updater2 Either where
  updater2 :: forall a b. Updater a -> Updater b -> Updater (Either a b)
updater2 Updater a
f1 Updater b
f2 (Left a
a)  = a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b)
-> ChangeT Identity a -> ChangeT Identity (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Updater a
f1 a
a
  updater2 Updater a
f1 Updater b
f2 (Right b
b) = b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b)
-> ChangeT Identity b -> ChangeT Identity (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Updater b
f2 b
b


{-- BEGIN MOCK

-- * Mock updater

type Change = Identity

-- | Replace result of updating with original input if nothing has changed.
{-# INLINE sharing #-}
sharing :: Updater a -> Updater a
sharing f a = f a

-- | Run an updater.
{-# INLINE evalUpdater #-}
evalUpdater :: Updater a -> EndoFun a
evalUpdater f a = runIdentity (f a)

-- | Mark a computation as dirty.
{-# INLINE dirty #-}
dirty :: Updater a
dirty = Identity

{-# INLINE ifDirty #-}
ifDirty :: Identity a -> (a -> Identity b) -> (a -> Identity b) -> Identity b
ifDirty m f g = m >>= f

-- END MOCK -}