New monads/MonadUndo
Jump to navigation
Jump to search
The printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
Here is a modified state monad transformer for keeping track of undo/redo states automatically.
{-# OPTIONS_GHC -fglasgow-exts #-}
module MonadUndo (
UndoT, evalUndoT, execUndoT,
Undo, evalUndo, execUndo,
MonadUndo, undo, redo, history, checkpoint,
History, current, undos, redos,
module Control.Monad.State
) where
import Control.Monad.State
import Control.Monad.Identity
data History s = History { current :: s, undos :: [s], redos :: [s] }
deriving (Eq, Show, Read)
blankHistory s = History { current = s, undos = [], redos = [] }
newtype Monad m => UndoT s m a = UndoT (StateT (History s) m a)
deriving (Functor, Monad, MonadTrans, MonadIO)
class (MonadState s m) => MonadUndo s m | m -> s where
undo :: m Bool -- undo the last state change, returns whether successful
redo :: m Bool -- redo the last undo
history :: m (History s) -- gets the current undo/redo history
checkpoint :: m () -- kill the history, leaving only the current state
instance (Monad m) => MonadState s (UndoT s m) where
get = UndoT $ do
ur <- get
return (current ur)
put x = UndoT $ do
ur <- get
put $ History { current = x, undos = current ur : undos ur
, redos = [] }
instance (Monad m) => MonadUndo s (UndoT s m) where
undo = UndoT $ do
ur <- get
case undos ur of
[] -> return False
(u:us) -> do put $ History { current = u, undos = us
, redos = current ur : redos ur }
return True
redo = UndoT $ do
ur <- get
case redos ur of
[] -> return False
(r:rs) -> do put $ History { current = r, undos = current ur : undos ur
, redos = rs }
return True
history = UndoT $ get
checkpoint = UndoT $ do
s <- liftM current get
put $ blankHistory s
evalUndoT (UndoT x) s = evalStateT x (blankHistory s)
execUndoT (UndoT x) s = liftM current $ execStateT x (blankHistory s)
newtype Undo s a = Undo (UndoT s Identity a)
deriving (Functor, Monad, MonadState s, MonadUndo s)
evalUndo (Undo x) s = runIdentity $ evalUndoT x s
execUndo (Undo x) s = runIdentity $ execUndoT x s