content: {-# 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
  