Как я могу добавить функциональность "отменить" для монадов штата?

Скажите, что у меня есть государственная монада, и я хочу сделать некоторые манипуляции в государстве и, возможно, захочу отменить изменения в будущем. Как вообще я могу сделать это прилично?

Чтобы дать конкретный пример, допустим, что состояние - это просто Int, а манипуляция просто увеличить число на единицу.

type TestM a = StateT a IO ()

inc :: TestM Int
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

recordDo :: TestM a -> TestM [a]
recordDo m = do
    x <- gets head
    y <- liftIO $ execStateT m x
    modify (y:)

inc' :: TestM [Int]
inc' = recordDo inc

undo' :: TestM [Int]
undo' = modify tail

-- inc 5 times, undo, and redo inc
manip' :: TestM [Int]
manip' = mapM_ traceState (replicate 5 inc' ++ [undo',inc'])

main :: IO ()
main = do
    v1 <- execStateT (replicateM_ 5 (traceState inc)) 2
    v2 <- execStateT (replicateM_ 5 (traceState inc')) [2]
    v3 <- execStateT manip' [2]
    print (v1,v2,v3)

Как и ожидалось, вот результат:

2
3
4
5
6
[2]
[3,2]
[4,3,2]
[5,4,3,2]
[6,5,4,3,2]
[2]
[3,2]
[4,3,2]
[5,4,3,2]
[6,5,4,3,2]
[7,6,5,4,3,2]
[6,5,4,3,2]
(7,[7,6,5,4,3,2],[7,6,5,4,3,2])

Недостаток моего подхода:

tail и head являются небезопасными
Мне нужно явно использовать что-то вроде recordDo, но я думаю, это неизбежно, потому что в противном случае будет какая-то проблема несогласованности. Например, увеличение числа на два может выполняться либо с помощью inc' >> inc', либо recordDo (inc >> inc), и эти два подхода оказывают различное влияние на стек.

Итак, я ищу либо некоторые способы сделать его более приличным, либо то, что делает работу "обратимого состояния" лучше.

Ответ 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)