{-# LANGUAGE NoMonomorphismRestriction,MultiParamTypeClasses,FlexibleContexts, FlexibleInstances,GeneralizedNewtypeDeriving,UndecidableInstances #-} -- | This code has been taken from <http://haskell.org> -- A Monad transformer UndoT on a state supporting undo , redo and hput to push the last state on history. -- Redo stack is blanked on hput module Undo where import Control.Monad.State -- | State stacks wrapping states in time data History s = History { current :: s, -- ^ last state putted undos :: [s], -- ^ the history of putted states (reversed) without the redos redos :: [s] -- ^ history of the undo } deriving Show -- | a state monad transformer with the state history type HStateT s m = StateT (History s) m -- | facility to write signatures context class (Monad m, MonadState (History s) (HStateT s m)) => HCtx m s instance (Monad m, MonadState (History s) (HStateT s m)) => HCtx m s -- | a wrapper around HStateT to derive his classes and add an instance newtype Monad m => UndoT s m a = UndoT (HStateT s m a) deriving (Functor, Monad, MonadTrans, MonadIO) -- | the MonadState instance for the wrapper instance (Monad m) => MonadState s (UndoT s m) where get = UndoT $ gets current put x = UndoT $ get >>= \(History _ us rs) -> put $ History x us rs -- | tries to get back one step the state undo :: HCtx m s => UndoT s m Bool -- ^ False if the undo stack was empty undo = UndoT $ do History c us rs <- get if null us then return False else put (History (head us) (tail us) (c : rs)) >> return True -- | tries to get back the undo operation redo :: HCtx m s => UndoT s m Bool -- ^ False if the redo stack was empty redo = UndoT $ do History c us rs <- get if null rs then return False else put (History (head rs) (c : us) (tail rs)) >> return True -- | push the old state in the undo stack and set the new state (alternative to put) hput :: HCtx m s => s -- ^ the new state to put -> UndoT s m () -- ^ monading hput x = UndoT $ do History c undos redos <- get put (History x (c:undos) []) -- | an History of one state blank :: s -> History s blank s = History s [] [] -- | run the UndoT monad transformer spitting out the computation result in the inner monad evalUndoT :: (Monad m) => UndoT s m a -- ^ a UndoT action -> s -- ^ the initial state -> m a -- ^ the result evalUndoT (UndoT x) s = evalStateT x (blank s) -- | run the UndoT monad transformer spitting out the final state in the inner monad execUndoT :: (Monad m) => UndoT s m a -- ^ a UndoT action -> s -- ^ the initial state -> m s -- ^ the final state execUndoT (UndoT x) s = liftM current $ execStateT x (blank s)