{-# LANGUAGE NoMonomorphismRestriction,MultiParamTypeClasses,FlexibleContexts,
FlexibleInstances,GeneralizedNewtypeDeriving,UndecidableInstances #-}
-- | This code has been taken from
-- 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)