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.
This page contains a non-standard copyright. All contributions to HaskellWiki are considered to be released under a simple permissive license (see HaskellWiki:Copyrights for details). Please either remove the material or change the copyright.
|
From New monads, copied from old wiki.
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
) 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