module Transient.Backtrack (onUndo, undo, retry, undoCut,registerUndo,
onBack, back, forward, backCut,registerBack,
finish, onFinish, onFinish' ,initFinish , noFinish, killOnFinish ,checkFinalize , FinishReason
) where
import Transient.Base
import Transient.Internals(EventF(..),killChildren,onNothing,runClosure,runContinuation)
import Data.Typeable
import Control.Applicative
import Control.Monad.State
import Unsafe.Coerce
import System.Mem.StableName
import Control.Exception
import Control.Concurrent.STM hiding (retry)
import Data.Maybe
data Backtrack b= Show b =>Backtrack{backtracking :: Maybe b
,backStack :: [EventF] }
deriving Typeable
backCut :: (Typeable reason, Show reason) => reason -> TransientIO ()
backCut reason= Transient $ do
delData $ Backtrack (Just reason) []
return $ Just ()
undoCut :: TransientIO ()
undoCut = backCut ()
onBack :: (Typeable b, Show b) => TransientIO a -> ( b -> TransientIO a) -> TransientIO a
onBack ac bac= registerBack (typeof bac) $ Transient $ do
Backtrack mreason _ <- getData `onNothing` backStateOf (typeof bac)
runTrans $ case mreason of
Nothing -> ac
Just reason -> bac reason
where
typeof :: (b -> TransIO a) -> b
typeof = undefined
onUndo :: TransientIO a -> TransientIO a -> TransientIO a
onUndo x y= onBack x (\() -> y)
registerBack :: (Typeable b, Show b) => b -> TransientIO a -> TransientIO a
registerBack witness f = Transient $ do
cont@(EventF _ _ x _ _ _ _ _ _ _ _) <- get
md <- getData `asTypeOf` (Just <$> backStateOf witness)
case md of
Just (bss@(Backtrack b (bs@((EventF _ _ x' _ _ _ _ _ _ _ _):_)))) ->
when (isNothing b) $ do
addrx <- addr x
addrx' <- addr x'
setData $ if addrx == addrx' then bss else Backtrack mwit (cont:bs)
Nothing -> setData $ Backtrack mwit [cont]
runTrans f
where
mwit= Nothing `asTypeOf` (Just witness)
addr x = liftIO $ return . hashStableName =<< (makeStableName $! x)
registerUndo :: TransientIO a -> TransientIO a
registerUndo f= registerBack () f
forward :: (Typeable b, Show b) => b -> TransIO ()
forward reason= Transient $ do
Backtrack _ stack <- getData `onNothing` (backStateOf reason)
setData $ Backtrack(Nothing `asTypeOf` Just reason) stack
return $ Just ()
retry= forward ()
noFinish= forward (FinishReason Nothing)
back :: (Typeable b, Show b) => b -> TransientIO a
back reason = Transient $ do
bs <- getData `onNothing` backStateOf reason
goBackt bs
where
goBackt (Backtrack _ [] )= return Nothing
goBackt (Backtrack b (stack@(first : bs)) )= do
(setData $ Backtrack (Just reason) stack)
mr <- runClosure first
Backtrack back _ <- getData `onNothing` backStateOf reason
case back of
Nothing -> case mr of
Nothing -> return empty
Just x -> runContinuation first x
justreason -> goBackt $ Backtrack justreason bs
backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a)
backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
undo :: TransIO a
undo= back ()
newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show)
initFinish= backCut (FinishReason Nothing)
onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO ()
onFinish f= onFinish' (return ()) f
onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a
onFinish' proc f= proc `onBack` \(FinishReason reason) ->
f reason
finish :: Maybe SomeException -> TransIO a
finish reason= back (FinishReason reason)
killOnFinish comp= do
chs <- liftIO $ newTVarIO []
onFinish $ const $ liftIO $ killChildren chs
r <- comp
modify $ \ s -> s{children= chs}
return r
checkFinalize v=
case v of
SDone -> finish Nothing >> stop
SLast x -> return x
SError e -> liftIO ( print e) >> finish Nothing >> stop
SMore x -> return x