{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE ExistentialQuantification #-}



-- | Transient implements an event handling mechanism ("backtracking") which

-- allows registration of one or more event handlers to be executed when an

-- event occurs. This common underlying mechanism called is used to handle

-- three different types of events:

--

-- * User initiated actions to run undo and retry actions on failures

-- * Finalization actions to run at the end of a task

-- * Exception handlers to run when exceptions are raised

--

-- Backtracking works seamlessly across thread boundaries.  The freedom to put

-- the undo, exception handling and finalization code where we want it allows

-- us to write modular and composable code.

--

-- Note that backtracking (undo, finalization or exception handling) does not

-- change or automatically roll back the user defined state in any way. It only

-- executes the user installed handlers. State changes are only caused via user

-- defined actions. Any state changes done within the backtracking actions are

-- accumulated on top of the user state as it was when backtracking started.

-- This example prints the final state as "world".

--

-- @

-- import Transient.Base (keep, setState, getState)

-- import Transient.Backtrack (onUndo, undo)

-- import Control.Monad.IO.Class (liftIO)

--

-- main = keep $ do

--     setState "hello"

--     oldState <- getState

--

--     liftIO (putStrLn "Register undo") \`onUndo` (do

--         curState <- getState

--         liftIO $ putStrLn $ "Final state: "  ++ curState

--         liftIO $ putStrLn $ "Old state: "    ++ oldState)

--

--     setState "world" >> undo >> return ()

-- @

--

-- See

-- <https://www.fpcomplete.com/user/agocorona/the-hardworking-programmer-ii-practical-backtracking-to-undo-actions this blog post>

-- for more details.



module Transient.Backtrack (



-- * Multi-track Undo

-- $multitrack

onBack, back, forward, backCut,



-- * Default Track Undo

-- $defaulttrack

onUndo, undo, retry, undoCut,



-- * Finalization Primitives

-- $finalization

onFinish, onFinish', finish, noFinish, initFinish

) where



import Transient.Internals



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



-- $defaulttrack

--

-- A default undo track with the track id of type @()@ is provided. APIs for

-- the default track are simpler as they do not require the track id argument.

--

-- @

-- import Control.Concurrent (threadDelay)

-- import Control.Monad.IO.Class (liftIO)

-- import Transient.Base (keep)

-- import Transient.Backtrack (onUndo, undo, retry)

--

-- main = keep $ do

--     step 1 >> tryAgain >> step 2 >> step 3 >> undo >> return ()

--     where

--         step n = liftIO (putStrLn ("Do Step: " ++ show n))

--                  \`onUndo`

--                  liftIO (putStrLn ("Undo Step: " ++ show n))

--

--         tryAgain = liftIO (putStrLn "Will retry on undo")

--                    \`onUndo`

--                    (retry >> liftIO (threadDelay 1000000 >> putStrLn "Retrying..."))

-- @



-- $multitrack

--

-- Transient allows you to pair an action with an undo action ('onBack'). As

-- actions are executed the corresponding undo actions are saved. At any point

-- an 'undo' can be triggered which executes all the undo actions registered

-- till now in reverse order. At any point, an undo action can decide to resume

-- forward execution by using 'forward'.

--

-- Multiple independent undo tracks can be defined for different use cases.  An

-- undo track is identified by a user defined data type. The data type of each

-- track must be distinct.

--

-- @

-- import Control.Concurrent (threadDelay)

-- import Control.Monad.IO.Class (liftIO)

-- import Transient.Base (keep)

-- import Transient.Backtrack (onBack, forward, back)

--

-- data Track = Track String deriving Show

--

-- main = keep $ do

--     step 1 >> goForward >> step 2 >> step 3 >> back (Track \"Failed") >> return ()

--     where

--           step n = liftIO (putStrLn $ "Execute Step: " ++ show n)

--                    \`onBack`

--                    \(Track r) -> liftIO (putStrLn $ show r ++ " Undo Step: " ++ show n)

--

--           goForward = liftIO (putStrLn "Turning point")

--                       \`onBack` \(Track r) ->

--                                     forward (Track r)

--                                     >> (liftIO $ threadDelay 1000000

--                                                 >> putStrLn "Going forward...")

-- @



-- $finalization

--

-- Several finish handlers can be installed (using 'onFinish') that are called

-- when the action is finalized using 'finish'. All the handlers installed

-- until the last 'initFinish' are invoked in reverse order; thread boundaries

-- do not matter.  The following example prints "3" and then "2".

--

-- @

-- import Control.Monad.IO.Class (liftIO)

-- import Transient.Base (keep)

-- import Transient.Backtrack (initFinish, onFinish, finish)

--

-- main = keep $ do

--         onFinish (\\_ -> liftIO $ putStrLn "1")

--         initFinish

--         onFinish (\\_ -> liftIO $ putStrLn "2")

--         onFinish (\\_ -> liftIO $ putStrLn "3")

--         finish Nothing

--         return ()

-- @



--

--data Backtrack b= Show b =>Backtrack{backtracking :: Maybe b

--                                    ,backStack :: [EventF] }

--                                    deriving Typeable

--

--

--

---- | assures that backtracking will not go further back

--backCut :: (Typeable reason, Show reason) => reason -> TransientIO ()

--backCut reason= Transient $ do

--     delData $ Backtrack (Just reason)  []

--     return $ Just ()

--

--undoCut ::  TransientIO ()

--undoCut = backCut ()

--

---- | the second parameter will be executed when backtracking

--{-# NOINLINE onBack #-}

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

--

--

---- | register an action that will be executed when backtracking

--{-# NOINLINE registerUndo #-}

--registerBack :: (Typeable b, Show b) => b -> TransientIO a -> TransientIO a

--registerBack witness f  = Transient $ do

--   cont@(EventF _ _ x _ _ _ _ _ _ _ _)  <- get   -- !!> "backregister"

--

--   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'         -- to avoid duplicate backtracking points

--                   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

--

---- | restart the flow forward from this point on

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

--

---- | execute backtracking. It execute the registered actions in reverse order.

----

---- If the backtracking flag is changed the flow proceed  forward from that point on.

----

---- If the backtrack stack is finished or undoCut executed, `undo` will stop.

--back :: (Typeable b, Show b) => b -> TransientIO a

--back reason = Transient $ do

--  bs <- getData  `onNothing`  backStateOf  reason           -- !!>"GOBACK"

--  goBackt  bs

--

--  where

--

--  goBackt (Backtrack _ [] )= return Nothing                      -- !!> "END"

--  goBackt (Backtrack b (stack@(first : bs)) )= do

--        (setData $ Backtrack (Just reason) stack)

--

--        mr <-  runClosure first                                  -- !> "RUNCLOSURE"

--

--        Backtrack back _ <- getData `onNothing`  backStateOf  reason

--                                                                 -- !> "END RUNCLOSURE"

--        case back of

--           Nothing -> case mr of

--                   Nothing ->  return empty                      -- !> "FORWARD END"

--                   Just x  ->  runContinuation first x           -- !> "FORWARD EXEC"

--           justreason -> goBackt $ Backtrack justreason bs       -- !> ("BACK AGAIN",back)

--

--backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a)

--backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) []

--

--undo ::  TransIO a

--undo= back ()

--

-------- finalization

--

--newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show)

--

---- | initialize the event variable for finalization.

---- all the following computations in different threads will share it

---- it also isolate this event from other branches that may have his own finish variable

--initFinish= backCut (FinishReason Nothing)

--

---- | set a computation to be called when the finish event happens

--onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO ()

--onFinish f= onFinish' (return ()) f

--

--

---- | set a computation to be called when the finish event happens this only apply for

--onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a

--onFinish' proc f= proc `onBack`   \(FinishReason reason) ->

--    f reason

--

--

---- | trigger the event, so this closes all the resources

--finish :: Maybe SomeException -> TransIO a

--finish reason= back (FinishReason reason)

--

--

---- | kill all the processes generated by the parameter when finish event occurs

--killOnFinish comp= do

--   chs <- liftIO $ newTVarIO []

--   onFinish $ const $ liftIO $ killChildren chs   -- !> "killOnFinish event"

--   r <- comp

--   modify $ \ s -> s{children= chs}

--   return r

--

---- | trigger finish when the stream of data ends

--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