New monads/MonadUndo
< New monads
Jump to navigation
Jump to search
Revision as of 15:59, 7 October 2006 by BrettGiles (talk | contribs) (NewMonads/MonadUndo moved to New monads/MonadUndo)
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.
From NewMonads, copied from old wiki.
MonadUndo
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