Ответ 1
В зависимости от вашего прецедента, возможно, стоит подумать над тем, что я бы назвал "разграниченным отмене":
{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans.Maybe
undo :: (MonadState s m, MonadPlus m) => m a -> m a -> m a
undo dflt k = do
s <- get
k `mplus` (put s >> dflt)
undoMaybe :: (MonadState s m) => m a -> MaybeT m a -> m a
undoMaybe dflt k = do
s <- get
r <- runMaybeT k
maybe (put s >> dflt) return r
undoMaybe_ :: (MonadState s m) => MaybeT m () -> m ()
undoMaybe_ = undoMaybe (return ())
Выполнение undo x k
означает "выполнить k
, а если оно не выполнено, отмените состояние и выполните x
вместо". Функция undoMaybe
работает аналогично, но допускает отказ только вложенного блока. Ваш пример может быть выражен как:
type TestM a = StateT a IO ()
inc :: (MonadState Int m) => m ()
inc = modify (+ 1)
-- just for showing what going on
traceState :: (MonadIO m, MonadState s m, Show s) => m a -> m a
traceState m = get >>= liftIO . print >> m
inc' :: (MonadIO m, MonadState Int m) => m ()
inc' = traceState inc
-- inc 5 times, undo, and redo inc
manip' :: TestM Int
manip' = replicateM 4 inc' >> undoMaybe_ (inc' >> traceState mzero) >> inc'
main :: IO ()
main = do
v1 <- execStateT (replicateM_ 5 (traceState inc)) 2
putStrLn ""
v3 <- execStateT manip' 2
print (v1,v3)
Главное преимущество заключается в том, что вы никогда не сможете переполнить стек. Недостатком является то, что вы не можете получить доступ к стеку, и отмена всегда ограничена.
Можно также создать монадный трансформатор Undo
, где выше Undo
становится mplus
. Всякий раз, когда неудачное вычисление восстанавливается с помощью mplus
, состояние также восстанавливается.
newtype Undo m a = Undo (m a)
deriving (Functor, Applicative, Monad)
instance MonadTrans Undo where
lift = Undo
instance (MonadState s m) => MonadState s (Undo m) where
get = lift get
put = lift . put
state = lift . state
instance (MonadPlus m, MonadState s m) => MonadPlus (Undo m) where
mzero = lift mzero
x `mplus` y = do
s <- get
x `mplus` (put s >> y)