Hedi-0.1: Undo.hs

{-# 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)