# New monads/MonadUndo

### From HaskellWiki

< New monads(Difference between revisions)

CaleGibbard (Talk | contribs) |
CaleGibbard (Talk | contribs) |

## Latest revision as of 18:22, 5 August 2007

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