# Difference between revisions of "New monads/MonadUndo"

From HaskellWiki

CaleGibbard (talk | contribs) |
CaleGibbard (talk | contribs) |
||

Line 1: | Line 1: | ||

− | |||

[[Category:Code]] | [[Category:Code]] | ||

## Revision as of 23:10, 13 November 2006

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