module Transient.Backtrack (registerUndo, onUndo, undo, retry, undoCut) where
import Transient.Base
import Transient.Internals(EventF(..),onNothing,runClosure,runContinuation)
import Data.Typeable
import Control.Applicative
import Control.Monad.State
import Unsafe.Coerce
import System.Mem.StableName
data Backtrack= forall a b.Backtrack{backtracking :: Bool
,backStack :: [EventF]}
deriving Typeable
undoCut :: TransientIO ()
undoCut= Transient $ do
delData $ Backtrack False []
return $ Just ()
onUndo :: TransientIO a -> TransientIO a -> TransientIO a
onUndo ac bac= registerUndo $ Transient $ do
Backtrack back _ <- getData `onNothing` return (Backtrack False [])
runTrans $ if back then bac else ac
registerUndo :: TransientIO a -> TransientIO a
registerUndo f = Transient $ do
cont@(EventF _ _ x _ _ _ _ _ _ _ _) <- get
md <- getData
ss <- case md of
Just (bss@(Backtrack b (bs@((EventF _ _ x' _ _ _ _ _ _ _ _):_)))) -> do
addrx <- addr x
addrx' <- addr x'
return $ if addrx == addrx' then bss else Backtrack b $ cont:bs
Nothing -> return $ Backtrack False [cont]
setData ss
runTrans f
where
addr x = liftIO $ return . hashStableName =<< (makeStableName $! x)
retry :: TransIO ()
retry= Transient $ do
Backtrack _ stack <- getData `onNothing` return (Backtrack False [])
setData $ Backtrack False stack
return $ Just ()
undo :: TransientIO a
undo= Transient $ do
bs <- getData `onNothing` return nullBack
goBackt bs
where
nullBack= Backtrack False []
goBackt (Backtrack _ [])= return Nothing
goBackt (Backtrack b (stack@(first@(EventF _ _ x fs _ _ _ _ _ _ _): bs)))= do
setData $ Backtrack True stack
mr <- runClosure first
Backtrack back _ <- getData `onNothing` return nullBack
case back of
True -> goBackt $ Backtrack True bs
False -> case mr of
Nothing -> return empty
Just x -> runContinuation first x