-- | Computations that track a dirty bit.
module Mikan.Utils.Update
  ( MonadChange(..)
    -- * The ChangeT monad transformer
  , ChangeT, Change
  , runChangeT, runChange
  , mapChangeT
    -- ** Updaters
  , UpdaterT, Updater
  , runUpdaterT
  , evalUpdater
  , dirty
  , sharing
  )
  where

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 Mikan.Utils.Tuple

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

  -- | Check to see if a computation changed anything.
  listenDirty :: m a -> m (a, Bool)

-- | 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)

-- | Always assume change has happened.
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)

--------------------------------------------------------------------------------
-- The ChangeT monad transformer

-- | The @ChangeT@ monad transformer, which tracks a single dirty bit.
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)

type Change a = ChangeT Identity a

-- 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
  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, Any 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)
    return (a, dirty)

{-# INLINE runChangeT #-}
-- | Run a t'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 c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second 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

{-# INLINE runChange #-}
-- | Run a 'Change' computation, returning result plus change flag.
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

{-# INLINE mapChangeT #-}
-- | Map a t'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)

--------------------------------------------------------------------------------
-- Updaters

type UpdaterT m a = a -> ChangeT m a

type Updater a = UpdaterT Identity a

{-# INLINE runUpdaterT #-}
-- | 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

-- | 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

{-# INLINE dirty #-}
-- | 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

{-# INLINE sharing #-}
-- | 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', 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
  return $ if changed then a' else a

{-# INLINE evalUpdater #-}
-- | Evaluate an updater using 'sharing'.
evalUpdater :: Updater a -> a -> a
evalUpdater :: forall a. Updater a -> a -> 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