transient 0.5.4 → 0.5.5

raw patch · 6 files changed

+2102/−1571 lines, 6 filesdep ~basedep ~bytestringdep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, bytestring, containers, directory, time, transformers

API changes (from Hackage documentation)

Files

• src/Transient/Backtrack.hs +130/−7
• src/Transient/Base.hs +261/−14
• src/Transient/Indeterminism.hs +26/−28
• src/Transient/Internals.hs +1619/−1456
• src/Transient/Logged.hs +47/−44
• transient.cabal +19/−22

@@ -1,16 +1,60 @@ {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE ExistentialQuantification #-}
 
--- | <https://www.fpcomplete.com/user/agocorona/the-hardworking-programmer-ii-practical-backtracking-to-undo-actions>
+-- | 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 (onUndo, undo, retry, undoCut,registerUndo,
+module Transient.Backtrack (
 
--- * generalized versions of backtracking with an extra parameter that gives the reason for going back.
--- Different kinds of backtracking with different reasons can be managed in the same program
-onBack, back, forward, backCut,registerBack,
+-- * Multi-track Undo
+-- $multitrack
+onBack, back, forward, backCut,
 
--- * finalization primitives
-finish, onFinish, onFinish' ,initFinish , noFinish,checkFinalize , FinishReason
+-- * Default Track Undo
+-- $defaulttrack
+onUndo, undo, retry, undoCut,
+
+-- * Finalization Primitives
+-- $finalization
+onFinish, onFinish', finish, noFinish, initFinish
 ) where
 
 import Transient.Internals
@@ -23,6 +67,85 @@ 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] }

@@ -3,43 +3,263 @@ --
 -- Module      :  Base
 -- Copyright   :
--- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
+-- License     :  MIT
 --
 -- Maintainer  :  agocorona@gmail.com
 -- Stability   :
 -- Portability :
 --
--- | See http://github.com/agocorona/transient
+-- | Transient provides high level concurrency allowing you to do concurrent
+-- processing without requiring any knowledge of threads or synchronization.
+-- From the programmer's perspective, the programming model is single threaded.
+-- Concurrent tasks are created and composed seamlessly resulting in highly
+-- modular and composable concurrent programs.  Transient has diverse
+-- applications from simple concurrent applications to massively parallel and
+-- distributed map-reduce problems.  If you are considering Apache Spark or
+-- Cloud Haskell then transient might be a simpler yet better solution for you
+-- (see
+-- <https://github.com/transient-haskell/transient-universe transient-universe>).
+-- Transient makes it easy to write composable event driven reactive UI
+-- applications. For example, <https://hackage.haskell.org/package/axiom Axiom>
+-- is a transient based unified client and server side framework that provides
+-- a better programming model and composability compared to frameworks like
+-- ReactJS.
+--
+-- = Overview
+--
+-- The 'TransientIO' monad allows you to:
+--
+-- * Split a problem into concurrent task sets
+-- * Compose concurrent task sets using non-determinism
+-- * Collect and combine results of concurrent tasks
+--
+-- You can think of 'TransientIO' as a concurrent list transformer monad with
+-- many other features added on top e.g. backtracking, logging and recovery to
+-- move computations across machines for distributed processing.
+--
+-- == Non-determinism
+--
+-- In its non-concurrent form, the 'TransientIO' monad behaves exactly like a
+-- <http://hackage.haskell.org/package/list-transformer list transformer monad>.
+-- It is like a list whose elements are generated using IO effects. It composes
+-- in the same way as a list monad. Let's see an example:
+--
+-- @
+-- import Control.Concurrent (threadDelay)
+-- import Control.Monad.IO.Class (liftIO)
+-- import System.Random (randomIO)
+-- import Transient.Base (keep, threads, waitEvents)
+--
+-- main = keep $ threads 0 $ do
+--     x <- waitEvents (randomIO :: IO Int)
+--     liftIO $ threadDelay 1000000
+--     liftIO $ putStrLn $ show x
+-- @
+--
+-- 'keep' runs the 'TransientIO' monad. The 'threads' primitive limits the
+-- number of threads to force non-concurrent operation.  The 'waitEvents'
+-- primitive generates values (list elements) in a loop using the 'randomIO' IO
+-- action.  The above code behaves like a list monad as if we are drawing
+-- elements from a list generated by 'waitEvents'.  The sequence of actions
+-- following 'waitEvents' is executed for each element of the list. We see a
+-- random value printed on the screen every second. As you can see this
+-- behavior is identical to a list transformer monad.
+--
+-- == Concurrency
+--
+-- 'TransientIO' monad is a concurrent list transformer i.e. each element of
+-- the generated list can be processed concurrently.  In the previous example
+-- if we change the number of threads to 10 we can see concurrency in action:
+--
+-- @
+-- ...
+-- main = keep $ threads 10 $ do
+-- ...
+-- @
+--
+-- Now each element of the list is processed concurrently in a separate thread,
+-- up to 10 threads are used. Therefore we see 10 results printed every second
+-- instead of 1 in the previous version.
+--
+-- In the above examples the list elements are generated using a synchronous IO
+-- action.  These elements can also be asynchronous events, for example an
+-- interactive user input.  In transient, the elements of the list are known as
+-- tasks.  The tasks terminology is general and intuitive in the context of
+-- transient as tasks can be triggered by asynchronous events and multiple of
+-- them can run simultaneously in an unordered fashion.
+--
+-- == Composing Tasks
+--
+-- The type @TransientIO a@ represents a /task set/ with each task in
+-- the set returning a value of type @a@.  A task set could be /finite/ or
+-- /infinite/; multiple tasks could run simultaneously.  The absence of a task,
+-- a void task set or failure is denoted by a special value 'empty' in an
+-- 'Alternative' composition, or the 'stop' primitive in a monadic composition.
+-- In the transient programming model the programmer thinks in terms of tasks
+-- and composes tasks. Whether the tasks run synchronously or concurrently does
+-- not matter; concurrency is hidden from the programmer for the most part. In
+-- the previous example the code written for a single threaded list transformer
+-- works concurrently as well.
+--
+-- We have already seen that the 'Monad' instance provides a way to compose the
+-- tasks in a sequential, non-deterministic and concurrent manner.  When a void
+-- task set is encountered, the monad stops processing any further computations
+-- as we have nothing to do.  The following example does not generate any
+-- output after "stop here":
+--
+-- @
+-- main = keep $ threads 0 $ do
+--     x <- waitEvents (randomIO :: IO Int)
+--     liftIO $ threadDelay 1000000
+--     liftIO $ putStrLn $ "stop here"
+--     stop
+--     liftIO $ putStrLn $ show x
+-- @
+--
+-- When a task creation primitive creates a task concurrently in a new thread
+-- (e.g.  'waitEvents'), it returns a void task set in the current thread
+-- making it stop further processing. However, processing resumes from the same
+-- point onwards with the same state in the new task threads as and when they
+-- are created; as if the current thread along with its state has branched into
+-- multiple threads, one for each new task. In the following example you can
+-- see that the thread id changes after the 'waitEvents' call:
+--
+-- @
+-- main = keep $ threads 1 $ do
+--     mainThread <- liftIO myThreadId
+--     liftIO $ putStrLn $ "Main thread: " ++ show mainThread
+--     x <- waitEvents (randomIO :: IO Int)
+--
+--     liftIO $ threadDelay 1000000
+--     evThread <- liftIO myThreadId
+--     liftIO $ putStrLn $ "Event thread: " ++ show evThread
+-- @
+--
+-- Note that if we use @threads 0@ then the new task thread is the same as the
+-- main thread because 'waitEvents' falls back to synchronous non-concurrent
+-- mode, and therefore returns a non void task set.
+--
+-- In an 'Alternative' composition, when a computation results in 'empty'
+-- the next alternative is tried. When a task creation primitive creates a
+-- concurrent task, it returns 'empty' allowing tasks to run concurrently when
+-- composed with the '<|>' combinator. The following example combines two
+-- single concurrent tasks generated by 'async':
+--
+-- @
+-- main = keep $ do
+--     x <- event 1 \<|\> event 2
+--     liftIO $ putStrLn $ show x
+--     where event n = async (return n :: IO Int)
+-- @
+--
+-- Note that availability of threads can impact the behavior of an application.
+-- An infinite task set generator (e.g. 'waitEvents' or 'sample') running
+-- synchronously (due to lack of threads) can block all other computations in
+-- an 'Alternative' composition.  The following example does not trigger the
+-- 'async' task unless we increase the number of threads to make 'waitEvents'
+-- asynchronous:
+--
+-- @
+-- main = keep $ threads 0 $ do
+--     x <- waitEvents (randomIO :: IO Int) \<|\> async (return 0 :: IO Int)
+--     liftIO $ threadDelay 1000000
+--     liftIO $ putStrLn $ show x
+-- @
+--
+-- == Parallel Map Reduce
+--
+-- The following example uses 'choose' to send the items in a list to parallel
+-- tasks for squaring and then folds the results of those tasks using 'collect'.
+--
+-- @
+-- import Control.Monad.IO.Class (liftIO)
+-- import Data.List (sum)
+-- import Transient.Base (keep)
+-- import Transient.Indeterminism (choose, collect)
+--
+-- main = keep $ do
+--     collect 100 squares >>= liftIO . putStrLn . show . sum
+--     where
+--         squares = do
+--             x <- choose [1..100]
+--             return (x * x)
+-- @
+--
+-- == State Isolation
+--
+-- State is inherited but never shared.  A transient application is written as
+-- a composition of task sets.  New concurrent tasks can be triggered from
+-- inside a task.  A new task inherits the state of the monad at the point
+-- where it got started. However, the state of a task is always completely
+-- isolated from other tasks irrespective of whether it is started in a new
+-- thread or not.  The state is referentially transparent i.e. any changes to
+-- the state creates a new copy of the state.  Therefore a programmer does not
+-- have to worry about synchronization or unintended side effects.
+--
+-- The monad starts with an empty state. At any point you can add ('setData'),
+-- retrieve ('getSData') or delete ('delData') a data item to or from the
+-- current state.  Creation of a task /branches/ the computation, inheriting
+-- the previous state, and collapsing (e.g. 'collect') discards the state of
+-- the tasks being collapsed. If you want to use the state in the results you
+-- will have to pass it as part of the results of the tasks.
+--
+-- = Reactive Applications
+--
+-- A popular model to handle asynchronous events in imperative languages is the
+-- callback model.  The control flow of the program is driven by events and
+-- callbacks; callbacks are event handlers that are hooked into the event
+-- generation code and are invoked every time an event happens. This model
+-- makes the overall control flow hard to understand resulting into a "callback
+-- hell" because the logic is distributed across various isolated callback
+-- handlers, and many different event threads work on the same global state.
+--
+-- Transient provides a better programming model for reactive applications.  In
+-- contrast to the callback model, transient transparently moves the relevant
+-- state to the respective event threads and composes the results to arrive at
+-- the new state. The programmer is not aware of the threads, there is no
+-- shared state to worry about, and a seamless sequential flow enabling easy
+-- reasoning and composable application components.
+-- <https://hackage.haskell.org/package/axiom Axiom> is a client and server
+-- side web UI and reactive application framework built using the transient
+-- programming model.
+--
+-- = Further Reading
+--
+-- * <https://github.com/transient-haskell/transient/wiki/Transient-tutorial Tutorial>
+-- * <https://github.com/transient-haskell/transient-examples Examples>
+--
 -----------------------------------------------------------------------------
 
 module Transient.Base(
 -- * The Monad
 TransIO(..), TransientIO
+
+-- * Task Composition Operators
+, (**>), (<**), (<***), (<|)
+
 -- * Running the monad
-,keep, keep', stop
+,keep, keep', stop, exit
 
--- * input
-,option, input, exit
+-- * Asynchronous console IO
+,option, input
 
--- * Asynchronous operations
-,async,waitEvents, spawn, parallel, sample
-,react
+-- * Task Creation
+-- $taskgen
+, StreamData(..)
+,parallel, async, waitEvents, sample, spawn, react
 
 -- * State management
-,setState, setData, getState, getSData,getData,delState,delData, modifyData,modifyState,try
+,setData, getSData, getData, delData, modifyData, try, setState, getState, delState, modifyState
 
 -- * Thread management
 , threads,addThreads, freeThreads, hookedThreads,oneThread, killChilds
 
--- * Additional operators
-, (**>), (<**),(<***), (<|)
-
--- * exceptions
+-- * Exceptions
+-- $exceptions
 
 ,onException, cutExceptions, continue
 
 -- * Utilities
-, StreamData(..)
 ,genId
 )
 
@@ -47,3 +267,30 @@ 
 
 import    Transient.Internals
+
+-- $taskgen
+--
+-- These primitives are used to create asynchronous and concurrent tasks from
+-- an IO action.
+--
+
+-- $exceptions
+--
+-- Exception handlers are implemented using the backtracking mechanism.
+-- (see 'Transient.Backtrack.back'). Several exception handlers can be
+-- installed using 'onException'; handlers are run in reverse order when an
+-- exception is raised. The following example prints "3" and then "2".
+--
+-- @
+-- {-\# LANGUAGE ScopedTypeVariables #-}
+-- import Transient.Base (keep, onException, cutExceptions)
+-- import Control.Monad.IO.Class (liftIO)
+-- import Control.Exception (ErrorCall)
+--
+-- main = keep $ do
+--     onException $ \\(e:: ErrorCall) -> liftIO $ putStrLn "1"
+--     cutExceptions
+--     onException $ \\(e:: ErrorCall) -> liftIO $ putStrLn "2"
+--     onException $ \\(e:: ErrorCall) -> liftIO $ putStrLn "3"
+--     liftIO $ error "Raised ErrorCall exception" >> return ()
+-- @

@@ -2,7 +2,7 @@ --
 -- Module      :  Transient.Indeterminism
 -- Copyright   :
--- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
+-- License     :  MIT
 --
 -- Maintainer  :  agocorona@gmail.com
 -- Stability   :
@@ -29,8 +29,9 @@ import Control.Exception
 
 
--- | slurp a list of values and process them in parallel . To limit the number of processing
--- threads, use `threads`
+-- | Converts a list of pure values into a transient task set. You can use the
+-- 'threads' primitive to control the parallelism.
+--
 choose  :: Show a =>  [a] -> TransIO a
 choose []= empty
 choose   xs = do
@@ -42,12 +43,15 @@             x:_  -> x `seq` return $ SMore x
     checkFinalize r
 
--- | alternative definition with more parallelism, as the composition of n `async` sentences
+-- | Same as 'choose' except that the 'threads' combinator cannot be used,
+-- instead the parent thread's limit applies.
+--
 choose' :: [a] -> TransIO a
 choose' xs = foldl (<|>) empty $ map (async . return) xs
 
 
--- | group the output of a possible multithreaded process in groups of n elements.
+-- | Collect the results of a task set in groups of @n@ elements.
+--
 group :: Int -> TransIO a -> TransIO [a]
 group num proc =  do
     v <- liftIO $ newIORef (0,[])
@@ -63,7 +67,9 @@       Nothing -> stop
       Just xs -> return xs
 
--- | group result for a time interval, measured with `diffUTCTime`
+-- | Collect the results of a task set, grouping all results received within
+-- every time interval specified by the first parameter as `diffUTCTime`.
+--
 groupByTime :: Integer -> TransIO a -> TransIO [a]
 
 groupByTime time proc =  do
@@ -82,33 +88,25 @@ 
 
 
--- collect the results of a search done in parallel, usually initiated by
--- `choose` .
+-- XXX Collect might return before collecting @n@ results if the runtime
+-- detects that there is absolutely no possibility of more tasks to be
+-- collected (using 'BlockedIndefinitelyOnMVar'). This is inconsistent with the
+-- behavior of group. We should perhaps return 'stop' in the failure case to
+-- keep it consistent with group.
 --
--- execute a process and get at least the first n solutions (they could be more).
--- if he find the number of solutions requested, it kill the non-free threads of the process and return
+-- | Collect the results of the first @n@ tasks.  Synchronizes concurrent tasks
+-- to collect the results safely and kills all the non-free threads before
+-- returning the results.  Results are returned in the thread where 'collect'
+-- is called.
+--
 collect ::  Int -> TransIO a -> TransIO [a]
 collect n = collect' n 0
 
--- | search with a timeout
--- After the  timeout, it stop unconditionally and return the current results.
--- It also stops as soon as there are enough results specified in the first parameter.
--- The results are returned by the original thread
---
--- >     timeout t proc=do
--- >       r <- collect' 1 t proc
--- >       case r of
--- >          []  ->  empty
--- >          r:_ -> return r
---
--- >     timeout 10000 empty <|> liftIO (print "timeout")
---
--- That executes the alternative and will print "timeout".
--- This would not be produced if collect would not return the results to the original thread
+-- | Like 'collect' but with a timeout. When the timeout is zero it behaves
+-- exactly like 'collect'. If the timeout (second parameter) is non-zero,
+-- collection stops after the timeout and the results collected till now are
+-- returned.
 --
--- `search` is executed in different threads and his state is lost, so don't rely in state
--- to pass information
-
 collect' :: Int -> Int -> TransIO a -> TransIO [a]
 collect' n t search= do
 

@@ -1,1459 +1,1622 @@-{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------
---
--- Module      :  Base
--- Copyright   :
--- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
---
--- Maintainer  :  agocorona@gmail.com
--- Stability   :
--- Portability :
---
--- | See http://github.com/agocorona/transient
--- everithing in this module is exported in order to allow extensibility.
------------------------------------------------------------------------------
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts          #-}
-{-# LANGUAGE FlexibleInstances         #-}
-{-# LANGUAGE MultiParamTypeClasses     #-}
-{-# LANGUAGE DeriveDataTypeable        #-}
-{-# LANGUAGE UndecidableInstances      #-}
-{-# LANGUAGE Rank2Types                #-}
-
-module Transient.Internals where
-
-
-
-import           Control.Applicative
-import           Control.Monad.State
-import           Data.Dynamic
-import qualified Data.Map               as M
-import           Data.Monoid
-import           Debug.Trace
-import           System.IO.Unsafe
-import           Unsafe.Coerce
-import           Control.Exception hiding (try,onException)
-import qualified Control.Exception  (try)
-import           Control.Concurrent
-import           GHC.Conc(unsafeIOToSTM)
-import           Control.Concurrent.STM hiding (retry)
-import qualified Control.Concurrent.STM  as STM (retry)
-import           System.Mem.StableName
-import           Data.Maybe
-
-import           Data.List
-import           Data.IORef
-import           System.Environment
-import           System.IO
-import           System.Exit
-
-import qualified Data.ByteString.Char8 as BS
-
-
-
--- {-# INLINE (!>) #-}
---(!>) :: Show a => b -> a -> b
---(!>) x y=  trace (show y) x
---infixr 0 !>
-
--- (!>) x y= x
-
-
-
-
-data TransIO  x = Transient  {runTrans :: StateT EventF IO (Maybe x)}
-type SData= ()
-
-type EventId= Int
-
-type TransientIO= TransIO
-
-data LifeCycle= Alive | Parent | Listener | Dead deriving (Eq,Show)
-
-data EventF  = forall a b . EventF{meffects     :: ()
-                                  ,event       :: Maybe SData
-                                  ,xcomp       :: TransIO a
-                                  ,fcomp       :: [b -> TransIO b]
-                                  ,mfData      :: M.Map TypeRep SData
-                                  ,mfSequence  :: Int
-                                  ,threadId    :: ThreadId
-                                  ,freeTh      :: Bool
-                                  ,parent      :: Maybe EventF
-                                  ,children    :: MVar[EventF]
-                                  ,maxThread   :: Maybe (IORef Int)
-                                  ,labelth     :: IORef (LifeCycle,BS.ByteString)
-                                  }
-                                  deriving Typeable
-
-
-
-
-type Effects= forall a b c.TransIO a -> TransIO a -> (a -> TransIO b)
-     -> StateIO (StateIO (Maybe c) -> StateIO (Maybe c), Maybe a)
-
-
-
-
-instance MonadState EventF TransIO where
-  get  = Transient $ get >>= return . Just
-  put x= Transient $ put x >> return (Just ())
-  state f =  Transient $ do
-      s <- get
-      let ~(a, s') = f s
-      put s'
-      return $ Just a
-
-type StateIO= StateT EventF IO
-
--- | Run a "non transient" computation within the underlying state monad, so it is guaranteed
--- that the computation neither can stop neither can trigger additional events/threads
-noTrans x= Transient $ x >>= return . Just
-
--- | Run the transient computation with a blank state
-runTransient :: TransIO x -> IO (Maybe x, EventF)
-runTransient t= do
-  th <- myThreadId
-  label <- newIORef $ (Alive,BS.pack "top")
-  childs <- newMVar []
-  let eventf0=  EventF () Nothing empty [] M.empty 0
-          th False  Nothing  childs Nothing  label
-
-  runStateT (runTrans t) eventf0
-
--- | Run the transient computation with an state
-runTransState st x = runStateT (runTrans x) st
-
--- | Get the continuation context: closure, continuation, state, child threads etc
-getCont :: TransIO EventF
-getCont = Transient $ Just <$> get
-
--- | Run the closure and the continuation using the state data of the calling thread
-runCont :: EventF -> StateIO (Maybe a)
-runCont (EventF _ _ x fs _ _  _ _  _ _ _ _)= runTrans $ do
-      r <- unsafeCoerce x
-      compose fs r
-
--- | Run the closure and the continuation using his own state data
-runCont' cont= runStateT (runCont cont) cont
-
--- | Warning: radiactive untyped stuff. handle with care
-getContinuations :: StateIO [a -> TransIO b]
-getContinuations= do
-  EventF _ _ _ fs _ _ _ _ _ _ _ _  <- get
-  return $ unsafeCoerce fs
-
-{-
-runCont cont= do
-     mr <- runClosure cont
-     case mr of
-         Nothing -> return Nothing
-         Just r -> runContinuation cont r
--}
-
-
--- | Compose a list of continuations
-compose []= const empty
-compose (f: fs)= \x -> f x >>= compose fs
-
-
-
--- | Run the closure  (the 'x'  in 'x >>= f') of the current bind operation.
-runClosure :: EventF -> StateIO (Maybe a)
-runClosure (EventF _ _ x _ _ _ _ _ _ _ _ _) =  unsafeCoerce $ runTrans x
-
-
--- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state
-runContinuation ::  EventF -> a -> StateIO (Maybe b)
-runContinuation (EventF _ _ _ fs _ _ _ _  _ _ _ _) =
-   runTrans . (unsafeCoerce $ compose $  fs)
-
-
-setContinuation :: TransIO a -> (a -> TransIO b) -> [c -> TransIO c] -> StateIO ()
-setContinuation  b c fs =  do
-    (EventF eff ev _ _ d e f g h i j k) <- get
-    put $ EventF eff ev b ( unsafeCoerce c: fs) d e f g h i j k
-
-withContinuation  c mx= do
-    EventF eff ev f1 fs d e f g h i j k<- get
-    put $ EventF eff ev mx ( unsafeCoerce c: fs) d e f g h i j k
-    r <- mx
-    restoreStack fs
-    return r
-
--- | run a chain of continuations. It is up to the programmer to assure by construction that
---  each continuation type-check with the next, that the parameter type match the input of the first
--- continuation.
--- Normally this makes sense if it stop the current flow with `stop` after the invocation
-runContinuations :: [a -> TransIO b] -> c -> TransIO d
-runContinuations fs x= (compose $ unsafeCoerce fs)  x
-
-instance   Functor TransIO where
-  fmap f mx=  --   Transient $ fmap (fmap f) $ runTrans mx
-    do
-     x <- mx
-     return $ f x
-
-
-
-
-instance Applicative TransIO where
-  pure a  = Transient . return $ Just a
-
-  f <*> g = Transient $ do
-         rf <- liftIO $ newIORef (Nothing,[])
-         rg <- liftIO $ newIORef (Nothing,[])   -- !> "NEWIOREF"
-
-         fs  <- getContinuations
-
-         let
-
-             hasWait (_:Wait:_)= True
-             hasWait _ = False
-
-             appf k = Transient $  do
-                   Log rec _ full <- getData `onNothing` return (Log False [] [])
-                   (liftIO $ writeIORef rf  (Just k,full))
---                                !> ( show $ unsafePerformIO myThreadId) ++"APPF"
-                   (x, full2)<- liftIO $ readIORef rg
-                   when (hasWait  full ) $
-                       -- !> (hasWait full,"full",full, "\nfull2",full2)) $
-                        let full'= head full: full2
-                        in (setData $ Log rec full' full')     -- !> ("result1",full')
-
-                   return $ Just k <*> x
-
-             appg x = Transient $  do
-                   Log rec _ full <- getData `onNothing` return (Log False [] [])
-                   liftIO $ writeIORef rg (Just x, full)
---                      !> ( show $ unsafePerformIO myThreadId)++ "APPG"
-                   (k,full1) <- liftIO $ readIORef rf
-                   when (hasWait  full) $
-                       -- !> ("full", full, "\nfull1",full1)) $
-                        let full'= head full: full1
-                        in (setData $ Log rec full' full')   -- !> ("result2",full')
-
-                   return $ k <*> Just x
-
-         setContinuation f appf fs
-
-
-         k <- runTrans f
-                  -- !> ( show $ unsafePerformIO myThreadId)++ "RUN f"
-         was <- getData `onNothing` return NoRemote
-         when (was == WasParallel) $  setData NoRemote
-
-         Log recovery _ full <- getData `onNothing` return (Log False [] [])
-
-
-
-         if was== WasRemote  || (not recovery && was == NoRemote  && isNothing k )
---               !>  ("was,recovery,isNothing=",was,recovery, isNothing k)
-         -- if the first operand was a remote request
-         -- (so this node is not master and hasn't to execute the whole expression)
-         -- or it was not an asyncronous term (a normal term without async or parallel
-         -- like primitives) and is nothing
-           then  do
-             restoreStack fs
-             return Nothing
-           else do
-             when (isJust k) $ liftIO $ writeIORef rf  (k,full)
-                -- when necessary since it maybe WasParallel and Nothing
-
-             setContinuation g appg fs
-
-             x <- runTrans g
---                      !> ( show $ unsafePerformIO myThreadId) ++ "RUN g"
-             Log recovery _ full' <- getData `onNothing` return (Log False [] [])
-             liftIO $ writeIORef rg  (x,full')
-             restoreStack fs
-             k'' <- if was== WasParallel
-                      then do
-                        (k',_) <- liftIO $ readIORef rf -- since k may have been updated by a parallel f
-                        return k'
-                      else return k
-             return $ k'' <*> x
-
-restoreStack fs=
-       modify $ \(EventF eff _ f _ a b c d parent children g1 la) ->
-               EventF eff Nothing f fs a b c d parent children g1 la
-
-readWithErr line=
-     let [(v,left)] = readsPrec 0 line
-     in (v   `seq` return [(v,left)])
-                    `catch` (\(e::SomeException) ->
-                      error ("read error trying to read type: \"" ++ show( typeOf v) ++ "\" in:  "++" <"++ show line++"> "))
-
-
-readsPrec' _= unsafePerformIO . readWithErr
-
-
-class (Show a, Read a, Typeable a) => Loggable a where
-
-
-instance (Show a, Read a,Typeable a) => Loggable a where
-
--- | Dynamic serializable data for logging
-data IDynamic= IDyns String | forall a.Loggable a => IDynamic a
-
-instance Show IDynamic where
-  show (IDynamic x)= show $ show x
-  show (IDyns s)= show s
-
-instance Read IDynamic where
-  readsPrec n str= map (\(x,s) -> (IDyns x,s)) $ readsPrec' n str
-
-
-type Recover= Bool
-type CurrentPointer= [LogElem]
-type LogEntries= [LogElem]
-data LogElem=   Wait | Exec | Var IDynamic deriving (Read,Show)
-data Log= Log Recover  CurrentPointer LogEntries deriving (Typeable, Show)
-
-
-instance Alternative TransIO where
-    empty = Transient $ return  Nothing
-    (<|>) = mplus
-
-
-data RemoteStatus=   WasRemote | WasParallel | NoRemote deriving (Typeable, Eq, Show)
-
-instance MonadPlus TransIO where
-    mzero= empty
-    mplus  x y=  Transient $ do
-         mx <- runTrans x                       --  !> "RUNTRANS11111"
-         was <- getData `onNothing` return NoRemote
-         if was== WasRemote                     -- !> was
-           then return Nothing
-           else
-                 case mx of
-                     Nothing -> runTrans y       -- !> "RUNTRANS22222"
-                     justx -> return justx
-
-
-
-
--- | A sinonym of empty that can be used in a monadic expression. it stop the
--- computation and execute the next alternative computation (composed with `<|>`)
-stop :: Alternative m => m stopped
-stop= empty
-
-
---instance (Num a,Eq a,Fractional a) =>Fractional (TransIO a)where
---     mf / mg = (/) <$> mf <*> mg
---     fromRational (x:%y) =  fromInteger x % fromInteger y
-
-
-instance (Num a,Eq a) => Num (TransIO a) where
-     fromInteger = return . fromInteger
-     mf + mg = (+) <$> mf <*> mg
-     mf * mg = (*) <$> mf <*> mg
-     negate f = f >>= return . negate
-     abs f =  f >>= return . abs
-     signum f =  f >>= return . signum
-
-
-class AdditionalOperators m where
-
-    -- | Executes the second operand even if the frist return empty.
-    -- A normal imperative (monadic) sequence uses the operator (>>) which in the
-    -- Transient monad does not execute the next operand if the previous one return empty.
-    (**>) :: m a -> m b -> m b
-
-    -- | Forces the execution of the second operand even if the first stop. It does not execute
-    -- the second operand as result of internal events occuring in the first operand.
-    -- Return the first result
-    (<**) :: m a -> m b -> m a
-
-    atEnd' ::m a -> m b -> m a
-    atEnd' = (<**)
-
-    -- | Forces the execution of the second operand even if the first stop. Return the first result. The second
-    -- operand is executed also when internal events happens in the first operand and it returns something
-    (<***) :: m a -> m b -> m a
-
-    atEnd :: m a -> m b -> m a
-    atEnd= (<***)
-
-
-instance AdditionalOperators TransIO where
-
---    (**>) :: TransIO a -> TransIO b -> TransIO b
-    (**>) x y=  Transient $ do
-              runTrans x
-              runTrans y
-
---    (<***) :: TransIO a -> TransIO b -> TransIO a
-    (<***) ma mb= Transient $ do
-                  fs  <- getContinuations
-                  setContinuation ma (\x -> mb >> return x)  fs
-                  a <- runTrans ma
-                  runTrans mb
-                  restoreStack fs
-                  return  a
-
-
-
---    (<**) :: TransIO a -> TransIO b -> TransIO a
-    (<**) ma mb= Transient $ do
-                  a <- runTrans ma    -- !> "ma"
-                  runTrans  mb        -- !> "mb"
-                  return a
-
-infixr 1  <***  ,  <**, **>
-
-
-
--- | When the first operand is an asynchronous operation, the second operand is executed once (one single time)
--- when the first completes his first asyncronous operation.
---
--- This is useful for spawning asynchronous or distributed tasks that are singletons and that should start
--- when the first one is set up.
---
--- for example a streaming where the event receivers are acivated before the senders.
-
-(<|) :: TransIO a -> TransIO b -> TransIO a
-(<|)  ma mb =  Transient $ do
-          fs  <- getContinuations
-          ref <- liftIO $ newIORef False
-          setContinuation ma (cont ref )  fs
-          r <- runTrans ma
-          restoreStack fs
-          return  r
-    where
-    cont ref x= Transient $ do
-          n <- liftIO $ readIORef ref
-          if  n == True
-            then  return $ Just x
-            else do liftIO $ writeIORef ref True
-                    runTrans mb
-                    return $ Just x
-
-instance Monoid a => Monoid (TransIO a) where
-  mappend x y = mappend <$> x <*> y
-  mempty= return mempty
-
--- | Set the current closure and continuation for the current statement
-setEventCont ::   TransIO a -> (a -> TransIO b) -> StateIO EventF
-setEventCont x f  = do
-
-   st@(EventF eff e _ fs d n  r applic  ch rc bs la)  <- get  -- !> "SET"
-   let cont=  EventF eff e x ( unsafeCoerce f : fs) d n  r applic  ch rc bs la
-   put cont
-   return cont
-
--- | Reset the closure and continuation. remove inner binds than the previous computations may have stacked
--- in the list of continuations.
---resetEventCont :: Maybe a -> EventF -> StateIO (TransIO b -> TransIO b)
-resetEventCont mx _=do
-   st@(EventF eff e _ fs d n  r nr  ch rc bs la)  <- get     -- !> "reset"
-   let f= \mx ->  case mx of
-                       Nothing -> empty
-                       Just x  -> (unsafeCoerce $ head fs)  x
-   put $ EventF eff e (f mx) ( tailsafe fs) d n  r nr  ch rc bs la
-   return  id
-
-tailsafe []=[]
-tailsafe (x:xs)= xs
-
---refEventCont= unsafePerformIO $ newIORef baseEffects
-
--- effects not used
--- {-# INLINE baseEffects #-}
---baseEffects :: Effects
---
---baseEffects x  x' f' = do
---            c <- setEventCont x'  f'
---            mk <- runTrans x
---            t <- resetEventCont mk c
---            return (t,mk)
-
-instance Monad TransIO where
-
-      return  = pure
-
-      x >>= f  = Transient $ do
-            c <- setEventCont x  f
-            mk <- runTrans x
-            resetEventCont mk c
-            case mk of
-                 Just k  ->  runTrans (f k)
-
-                 Nothing ->  return Nothing
-
---instance MonadTrans (Transient ) where
---  lift mx = Transient $ mx >>= return . Just
-
-instance MonadIO TransIO where
-
-  liftIO mx=do
-    ex <- liftIO' $ (mx >>= return . Right) `catch` (\(e :: SomeException) -> return $ Left e)
-    case ex of
-      Left e -> back e  -- finish $ Just e
-      Right x -> return x
-    where
-    liftIO' x = Transient $ liftIO x >>= return . Just --     let x= liftIO io in x `seq` lift x
-
-
--- * Threads
-
-waitQSemB sem= atomicModifyIORef sem $ \n -> if n > 0 then(n-1,True) else (n,False)
-signalQSemB sem= atomicModifyIORef sem  $ \n ->  (n + 1,())
-
--- | Set the maximun number of threads for a procedure. It is useful to limit the
--- parallelization of transient code that uses `parallel` `spawn` and `waitEvents`
-threads :: Int -> TransIO a -> TransIO a
-threads n proc=  do
-   msem <- gets maxThread
-   sem <- liftIO $ newIORef n
-   modify $ \s -> s{maxThread= Just sem}
-   r <- proc <** (modify $ \s -> s{maxThread = msem}) -- restore it
-   return r
-
--- | Delete all the previous child threads generated by the expression taken as parameter and continue execution
--- of the current thread.
-oneThread :: TransIO a -> TransIO a
-oneThread comp= do
-   st <-  get
-   chs <- liftIO $ newMVar []
-   label <-  liftIO $ newIORef (Alive, BS.pack "oneThread")
-
-   let st' = st{parent=Just st,children=   chs, labelth= label}
-   liftIO $ hangThread st st'
-   put st'
-   x <- comp
-   th<- liftIO  myThreadId                              -- !> ("FATHER:", threadId st)
-   chs <- liftIO $ readMVar chs -- children st'
-
-   liftIO $ mapM_ (killChildren1  th  )  chs
-   return x
-   where
-   killChildren1 :: ThreadId  ->  EventF -> IO ()
-   killChildren1 th state = do
-       ths' <- modifyMVar (children state) $ \ths -> do
-                    let (inn, ths')=  partition (\st -> threadId st == th) ths
-                    return (inn, ths')
-
-
-       mapM_ (killChildren1  th ) ths'
-       mapM_ (killThread . threadId) ths'
---                                            !> ("KILLEVENT1 ", map threadId ths' )
-
-
-
-
--- | Add a label to the current passing threads so it can be printed by debugging calls like `showThreads`
-labelState l=  do
-     st <- get
-     liftIO $ atomicModifyIORef (labelth st) $ \(status,_) -> ((status,BS.pack l),())
-
-printBlock= unsafePerformIO $ newMVar ()
-
-
--- Show the tree of threads hanging from the state
-showThreads :: MonadIO m => EventF -> m ()
-showThreads st= liftIO $ withMVar printBlock $ const $ do
-
-   mythread <-  myThreadId
---                                       !> "showThreads"
-
-   putStrLn "---------Threads-----------"
-   let showTree n ch=  do
-         liftIO $ do
-            putStr $ take n $ repeat  ' '
-            (state,label) <- readIORef $ labelth ch
-            if BS.null label
-              then putStr . show $ threadId ch
-              else do BS.putStr label ; putStr . drop 8 . show $ threadId ch
-                      when (state== Dead) $ putStr " dead"
-            putStrLn $ if mythread== threadId ch then  " <--" else ""
-
-         chs <-  readMVar $ children ch
-         mapM_ (showTree $ n+2) $ reverse chs
-
-   showTree 0 st
-
-
-
--- | Return the state of the thread that initiated the transient computation
-topState :: TransIO EventF
-topState = do
-      st <- get
-      return $ toplevel st
-  where
-  toplevel st= do
-      case parent st of
-        Nothing ->  st
-        Just p -> toplevel p
-
--- | Return the state variable of the type desired with which a thread, identified by his number in the treee was initiated
-showState :: (Typeable a, MonadIO m, Alternative m) => String -> EventF  -> m  (Maybe a)
-showState th top = resp
-  where
-  resp=  do
-     let thstring= drop 9 . show $ threadId top
-     if thstring == th  then getstate top else do
-       sts <-  liftIO $ readMVar $ children top
-       foldl (<|>)  empty $ map (showState th) sts
-       where
-       getstate st=
-            case M.lookup ( typeOf $ typeResp resp ) $ mfData st of
-              Just x  -> return . Just $ unsafeCoerce x
-              Nothing -> return Nothing
-       typeResp :: m (Maybe x) -> x
-       typeResp= undefined
-
-
--- | Add n threads to the limit of threads. If there is no limit, it set it
-addThreads' :: Int -> TransIO ()
-addThreads' n= noTrans $ do
-   msem <- gets maxThread
-   case msem of
-    Just sem -> liftIO $ modifyIORef sem $ \n' -> n + n'
-    Nothing  -> do
-        sem <- liftIO (newIORef n)
-        modify $ \ s -> s{maxThread= Just sem}
-   return  ()
-
--- | Assure that at least there are n threads available
-addThreads n= noTrans $ do
-   msem <- gets maxThread
-   case msem of
-     Nothing -> return ()
-     Just sem ->  liftIO $ modifyIORef sem $ \n' -> if n' > n then n' else  n
-   return  ()
---getNonUsedThreads :: TransIO (Maybe Int)
---getNonUsedThreads= Transient $ do
---   msem <- gets maxThread
---   case msem of
---    Just sem -> liftIO $ Just <$> readIORef sem
---    Nothing -> return Nothing
-
-
--- | The threads generated in the process passed as parameter will not be killed by `kill*`
---  primitives.
---
--- Since there is no thread control, the application run slightly faster.
-freeThreads :: TransIO a -> TransIO a
-freeThreads proc= Transient $ do
-     st <- get
-     put st{freeTh= True}
-     r <- runTrans proc
-     modify $ \s -> s{freeTh= freeTh st}
-     return r
-
--- | The threads will be killed when the parent thread dies. That is the default.
--- This can be invoked to revert the effect of `freeThreads`
-hookedThreads :: TransIO a -> TransIO a
-hookedThreads proc= Transient $ do
-     st <- get
-     put st{freeTh= False}
-     r <- runTrans proc
-     modify $ \st -> st{freeTh= freeTh st}
-     return r
-
--- | kill all the child threads of the current thread
-killChilds :: TransIO()
-killChilds= noTrans $  do
-   cont <- get
-
-   liftIO $ do
-      killChildren $ children cont
-      writeIORef (labelth cont) (Alive,mempty)     -- !> (threadId cont,"relabeled")
-   return ()
-
--- | Kill the  current thread and the childs
-killBranch= noTrans $ do
-        st <- get
-        liftIO $ killBranch' st
-
--- | Kill the childs and the thread of an state
-killBranch' cont= liftIO $ do
-
-        killChildren $ children cont
-        let thisth= threadId cont
-        let mparent= parent cont
-        when (isJust mparent) $ modifyMVar_ (children $ fromJust mparent)
-                              $ \sts  -> return $ filter (\st -> threadId st /= thisth) sts
-        killThread $ thisth
-
-
--- * extensible state: session data management
-
--- | Get the state data for the desired type if there is any.
-getData ::  (MonadState EventF m,Typeable a) =>  m (Maybe a)
-getData =  resp where
- resp= gets mfData >>= \list  ->
-    case M.lookup ( typeOf $ typeResp resp ) list  of
-      Just x  -> return . Just $ unsafeCoerce x
-      Nothing -> return Nothing
- typeResp :: m (Maybe x) -> x
- typeResp= undefined
-
-
--- | getData specialized for the Transient monad. if Nothing, the
--- monadic computation does not continue.
---
--- If there is no such data, `getSData`  silently stop the computation.
--- That may or may not be the desired behaviour.
--- To make sure that this does not get unnoticed, use this construction:
---
--- >  getSData <|> error "no data"
---
--- To have the same semantics and guarantees than `get`, use a default value:
---
--- > getInt= getSData <|> return (0 :: Int)
---
--- The default value (0 in this case) has the same role than the initial value in a state monad.
--- The difference is that you can define as many `get` as you need for all your data types.
---
--- To distingish two data with the same types, use newtype definitions.
-getSData ::  Typeable a => TransIO  a
-getSData= Transient getData
-
--- | Synonym for `getSData`
-getState ::  Typeable a => TransIO  a
-getState= getSData
-
--- | Set session data for this type. retrieved with getData or getSData
--- Note that this is data in a state monad, that means that the update only affect downstream
--- in the monad execution. it is not a global state neither a per user or per thread state
--- it is a monadic state like the one of a state monad.
-setData ::  (MonadState EventF m, Typeable a) => a -> m ()
-setData  x=
-  let t= typeOf x in  modify $ \st -> st{mfData= M.insert  t (unsafeCoerce x) (mfData st)}
-
-
--- | Modify state data. It accept a function that get the current state (if exist) as parameter.
--- The state will be deleted or changed depending on function result
-modifyData :: (MonadState EventF m, Typeable a)  => (Maybe a -> Maybe a) -> m ()
-modifyData f=  modify $ \st -> st{mfData=
-       let  t= typeOf $ typeResp f
-       in M.alter alterf  t  (mfData st)}
-   where
-   typeResp :: (Maybe a -> b) -> a
-   typeResp= undefined
-   alterf mx =
-      let x' = case mx of
-                  Just x  -> Just $ unsafeCoerce x
-                  Nothing -> Nothing
-      in   unsafeCoerce $ f x'
-
--- | Synonym for modifyData
-modifyState :: (MonadState EventF m, Typeable a)  => (Maybe a -> Maybe a) -> m ()
-modifyState= modifyData
-
--- | Synonym for `setData`
-setState  ::  (MonadState EventF m, Typeable a) => a -> m ()
-setState= setData
-
-delData :: ( MonadState EventF m,Typeable a) => a -> m ()
-delData x=  modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
-
-delState :: ( MonadState EventF m,Typeable a) => a -> m ()
-delState= delData
-
--- | Executes the computation and reset the state if it fails.
-try :: TransIO a -> TransIO a
-try mx= do
-    sd <- gets mfData
-    mx <|> (modify (\ s ->s{mfData= sd}) >> empty)
-
--- | Executes the computation and reset the state either if it fails or not
-sandbox :: TransIO a -> TransIO a
-sandbox mx= do
-    sd <- gets mfData
-    mx <*** modify (\s ->s{mfData= sd})
-
--- | Generator of identifiers that are unique withing the current monadic sequence
--- They are not unique in the whole program.
-genId :: MonadState EventF m =>  m Int
-genId= do
-      st <- get
-      let n= mfSequence st
-      put st{mfSequence= n+1}
-      return n
-
-getPrevId :: MonadState EventF m =>  m Int
-getPrevId= do
-      n <- gets mfSequence
-      return n
-
-instance Read SomeException where
-   readsPrec n str=
-      let [(s , r)]= read str in [(SomeException $ ErrorCall s,r)]
-
--- | Async calls
-
-data StreamData a=  SMore a | SLast a | SDone | SError SomeException deriving (Typeable, Show,Read)
-
-
--- | Variant of `parallel` that repeatedly executes the IO computation without end
---
-waitEvents ::   IO b -> TransIO b
-waitEvents io= do
-   mr <- parallel (SMore <$> io)
-   case mr of
-     SMore x -> return x
-     SError e -> back  e
-
--- | Variant of `parallel` that execute the IO computation once
-async  ::  IO b -> TransIO b
-async io= do
-   mr <- parallel  (SLast <$> io)
-   case mr of
-     SLast x -> return x
-     SError e -> back e
-
--- | in an alternative computation it executes an async operations synchronously.
--- This means that the alternatives do not execute until the async operation finishes.
--- Do not use in Applicatives.
-sync :: TransIO a -> TransIO a
-sync x= do
-  setData WasRemote
-  r <- x
-  delData WasRemote
-  return r
-
--- | `spawn= freeThreads . waitEvents`
-spawn= freeThreads . waitEvents
-
--- | Executes an IO action each certain interval of time and return his value if it changes
-sample :: Eq a => IO a -> Int -> TransIO a
-sample action interval= do
-       v <-  liftIO action
-       prev <- liftIO $ newIORef v
-       waitEvents (loop action prev) <|> async (return v)
-       where
-       loop action prev= loop'
-        where
-        loop'= do
-            threadDelay interval
-            v <- action
-            v' <- readIORef prev
-            if v /= v' then writeIORef prev v >> return v else  loop'
-
-
---serial  ::    IO (StreamData b) -> TransIO (StreamData b)
---serial  ioaction= Transient $   do
---    cont <- get                    -- !> "PARALLEL"
---    case event cont of
---         j@(Just _) -> do
---                    put cont{event=Nothing}
---                    return $ unsafeCoerce j
---         Nothing -> do
---                    liftIO $ loop cont ioaction
---                    return Nothing
---
---   where loop cont ioaction= do
---            let iocont dat= do
---                    runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
---                    return ()
---            mdat <- ioaction `catch` \(e :: SomeException) -> return $ SError e
---            case mdat of
---                 se@(SError _) ->  iocont se
---                 SDone ->          iocont SDone
---                 last@(SLast _) -> iocont last
---
---                 more@(SMore _) -> do
---                      iocont more
---                      loop cont ioaction
-
-
--- |  Return empty to the current thread and execute the IO action in a new thread.
--- When the IO action returns, the transient computation continues with this value as the result
--- The IO action may be re-executed or not depending on the result. So parallel can spawn any
--- number of threads/results.
---
--- If the maximum number of threads, set with `threads` has been reached  `parallel` perform
--- the work sequentially, in the current thread.
--- So `parallel` means that 'it can be parallelized if there are thread available'
---
--- if there is a limitation of threads, when a thread finish, the counter of threads available
--- is increased so another `parallel` can make use of it.
---
--- The behaviour of `parallel` depend on `StreamData`; If `SMore`, `parallel` will excute again the
--- IO action. With `SLast`, `SDone` and `SError`, `parallel` will not repeat the IO action anymore.
-parallel  ::    IO (StreamData b) -> TransIO (StreamData b)
-parallel  ioaction= Transient $ do
-    cont <- get                    -- !> "PARALLEL"
-    case event cont of
-         j@(Just _) -> do
-            put cont{event=Nothing}
-            return $ unsafeCoerce j
-         Nothing -> do
-            liftIO $ atomicModifyIORef (labelth cont) $ \(_,lab) -> ((Parent,lab),())
-            liftIO $ loop  cont ioaction
-            was <- getData `onNothing` return NoRemote
-            when (was /= WasRemote) $ setData WasParallel
-
-
---            th <- liftIO myThreadId
---            return () !> ("finish",th)
-            return Nothing
-
-
--- Execute the IO action and the continuation
-loop ::  EventF -> IO (StreamData t) -> IO ()
-loop  parentc  rec  = forkMaybe parentc $ \cont ->  do
-
-      -- execute the IO computation and then the closure-continuation
-  liftIO $ atomicModifyIORef (labelth cont) $ const ((Listener,BS.pack "wait"),())
-  let loop'=   do
-         mdat <- rec `catch` \(e :: SomeException) -> return $ SError e
-         case mdat of
-             se@(SError _)  -> setworker cont >> iocont  se    cont
-             SDone          -> setworker cont >> iocont  SDone cont
-             last@(SLast _) -> setworker cont >> iocont  last  cont
-
-             more@(SMore _) -> do
-                  forkMaybe cont $ iocont  more
-                  loop'
-
-         where
-         setworker cont= liftIO $ atomicModifyIORef (labelth cont) $ const ((Alive,BS.pack "work"),())
-
-         iocont  dat cont = do
-
-              let cont'= cont{event= Just $ unsafeCoerce dat}
-              runStateT (runCont cont')  cont'
-              return ()
-
-
-  loop'
-  return ()
-  where
-
-  forkMaybe parent  proc = do
-     case maxThread parent  of
-       Nothing -> forkIt parent  proc
-       Just sem  -> do
-             dofork <- waitQSemB sem
-             if dofork then  forkIt parent proc else proc parent
-
-
-  forkIt parent  proc= do
-     chs <- liftIO $ newMVar []
-
-     label <- newIORef (Alive, BS.pack "work")
-     let cont = parent{parent=Just parent,children=   chs, labelth= label}
-
-     forkFinally1 (do
-         th <- myThreadId
-         let cont'= cont{threadId=th}
-         when(not $ freeTh parent )$ hangThread parent   cont'
-                                    -- !>  ("thread created: ",th,"in",threadId parent )
-
-         proc cont')
-         $ \me -> do
-
---             case me of -- !> "THREAD END" of
---              Left  e -> do
-----                 when (fromException e /= Just ThreadKilled)$
---                 liftIO $ print e
---                 killChildren $ children cont
-----                                   !> "KILL RECEIVED" ++ (show $ unsafePerformIO myThreadId)
---
---              Right _ ->
-
-
-
-             case maxThread cont of
-               Just sem -> signalQSemB sem      -- !> "freed thread"
-               Nothing -> when(not $ freeTh parent  )  $ do -- if was not a free thread
-
-                 th <- myThreadId
-                 (can,label) <- atomicModifyIORef (labelth cont) $ \(l@(status,label)) ->
-                    ((if status== Alive then Dead else status, label),l)
-
-
-                 when (can/= Parent ) $ free th parent
-     return ()
-
-
-  forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
-  forkFinally1 action and_then =
-       mask $ \restore ->  forkIO $ Control.Exception.try (restore action) >>= and_then
-
-free th env= do
---       return ()                                       !> ("freeing",th,"in",threadId env)
-       let sibling=  children env
-
-       (sbs',found) <- modifyMVar sibling $ \sbs -> do
-                   let (sbs', found) = drop [] th  sbs
-                   return (sbs',(sbs',found))
-
-
-
-       if found
-         then do
-
---                                             !> ("new list for",threadId env,map threadId sbs')
-           (typ,_) <- readIORef $ labelth env
-           if (null sbs' && typ /= Listener && isJust (parent env))
-            -- free the parent
-            then free (threadId env) ( fromJust $ parent env)
-            else return ()
-
---               return env
-         else return () -- putMVar sibling sbs
-                                                     -- !>  (th,"orphan")
-
-       where
-       drop processed th []= (processed,False)
-       drop processed th (ev:evts)| th ==  threadId ev= (processed ++ evts, True)
-                                  | otherwise= drop (ev:processed) th evts
-
-
-
-hangThread parentProc child =  do
-
-       let headpths= children parentProc
-
-       modifyMVar_ headpths $ \ths -> return (child:ths)
---       ths <- takeMVar headpths
---       putMVar headpths (child:ths)
-
-
-           --  !> ("hang", threadId child, threadId parentProc,map threadId ths,unsafePerformIO $ readIORef $ labelth parentProc)
-
--- | kill  all the child threads associated with the continuation context
-killChildren childs  = do
-
-
-           ths <- modifyMVar childs $ \ths -> return ([],ths)
---           ths <- takeMVar childs
---           putMVar childs []
-
-           mapM_ (killChildren . children) ths
-
-
-           mapM_ (killThread . threadId) ths  -- !> ("KILL", map threadId ths )
-
-
-
-
-
--- | De-invert an event handler.
---
--- The first parameter is the setter of the event handler  to be
--- deinverted. Usually it is the primitive provided by a framework to set an event handler
---
--- the second parameter is the value to return to the event handler. Usually it is `return()`
---
--- it configures the event handler by calling the setter of the event
--- handler with the current continuation
-react
-  :: Typeable eventdata
-  => ((eventdata ->  IO response) -> IO ())
-  -> IO  response
-  -> TransIO eventdata
-react setHandler iob= Transient $ do
-        cont    <- get
-        case event cont of
-          Nothing -> do
-            liftIO $ setHandler $ \dat ->do
-              runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
-              iob
-            was <- getData `onNothing` return NoRemote
-            when (was /= WasRemote) $ setData WasParallel
-            return Nothing
-
-          j@(Just _) -> do
-            put cont{event=Nothing}
-            return $ unsafeCoerce j
-
--- | continue the computation in another thread and return `empty` to the computation in the curren thread.
---
--- Useful for executing alternative computations
-
-abduce = Transient $ do
-   st <-  get
-   case  event st of
-          Just _ -> do
-               put st{event=Nothing}
-               return $ Just ()
-          Nothing -> do
-               chs <- liftIO $ newMVar []
-
-               label <-  liftIO $ newIORef (Alive, BS.pack "abduce")
-               liftIO $ forkIO $ do
-                   th <- myThreadId
-                   let st' = st{event= Just (),parent=Just st,children=   chs, threadId=th,labelth= label}
-                   liftIO $ hangThread st st'
-
-                   runCont' st'
-                   return()
-               return Nothing
-
-
--- * non-blocking keyboard input
-
-getLineRef= unsafePerformIO $ newTVarIO Nothing
-
-
-roption= unsafePerformIO $ newMVar []
-
--- | Install a event receiver that wait for a string and trigger the continuation when this string arrives.
-option :: (Typeable b, Show b, Read b, Eq b) =>
-     b -> String -> TransIO b
-option ret message= do
-    let sret= show ret
-
-    liftIO $ putStrLn $ "Enter  "++sret++"\tto: " ++ message
-    liftIO $ modifyMVar_ roption $ \msgs-> return $ sret:msgs
-    waitEvents  $ getLine' (==ret)
-    liftIO $ putStr "\noption: " >> putStrLn (show ret)
-    return ret
-
-
--- | Validates an input entered in the keyboard in non blocking mode. non blocking means that
--- the user can enter also anything else to activate other option
--- unlike `option`, wich watch continuously, input only wait for one valid response
-input :: (Typeable a, Read a,Show a) => (a -> Bool) -> String -> TransIO a
-input cond prompt= Transient . liftIO $do
-   putStr prompt >> hFlush stdout
-   atomically $ do
-       mr <- readTVar getLineRef
-       case mr of
-         Nothing -> STM.retry
-         Just r ->
-            case reads1 r  of
-            (s,_):_ -> if cond s  --  !> show (cond s)
-                     then do
-                       unsafeIOToSTM $ print s
-                       writeTVar  getLineRef Nothing -- !>"match"
-                       return $ Just s
-
-                     else return Nothing
-            _ -> return Nothing
-
--- | Non blocking `getLine` with a validator
-getLine' cond=    do
-     atomically $ do
-       mr <- readTVar getLineRef
-       case mr of
-         Nothing -> STM.retry
-         Just r ->
-            case reads1 r of --  !> ("received " ++  show r ++ show (unsafePerformIO myThreadId)) of
-            (s,_):_ -> if cond s -- !> show (cond s)
-                     then do
-                       writeTVar  getLineRef Nothing -- !>"match"
-                       return s
-
-                     else STM.retry
-            _ -> STM.retry
-
-reads1 s=x where
-      x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec' 0 s
-      typeOfr :: [(a,String)] ->  a
-      typeOfr  = undefined
-
-
-inputLoop= do
-           r<- getLine
-           atomically $ writeTVar getLineRef Nothing
-           processLine r
-           inputLoop
-
-processLine r= do
-
-   let rs = breakSlash [] r
-
-   liftIO $ mapM_ (\ r ->
-                 atomically $ do
---                    threadDelay 1000000
-                    t <- readTVar getLineRef
-                    when (isJust  t) STM.retry
-                    writeTVar  getLineRef $ Just r ) rs
-
-
-    where
-    breakSlash :: [String] -> String -> [String]
-    breakSlash [] ""= [""]
-    breakSlash s ""= s
-    breakSlash res ('\"':s)=
-      let (r,rest) = span(/= '\"') s
-      in breakSlash (res++[r]) $ tail1 rest
-
-    breakSlash res s=
-      let (r,rest) = span(/= '/') s
-      in breakSlash (res++[r]) $ tail1 rest
-
-    tail1 []=[]
-    tail1 x= tail x
-
-
-
-
--- | Wait for the execution of `exit` and return the result or the exhaustion of thread activity
-
-stay rexit=  takeMVar rexit
- `catch` \(e :: BlockedIndefinitelyOnMVar) -> return Nothing
-
-newtype Exit a= Exit a deriving Typeable
-
--- | Keep the main thread running, initiate the non blocking keyboard input and execute
--- the transient computation.
---
--- It also read a slash-separated list of string that are read by
--- `option` and `input` as if they were entered by the keyboard
---
--- >  foo  -p  options/to/be/read/by/option/and/input
-keep :: Typeable a => TransIO a -> IO (Maybe a)
-keep mx = do
-
-   liftIO $ hSetBuffering stdout LineBuffering
-   rexit <- newEmptyMVar
-   forkIO $ do
---       liftIO $ putMVar rexit  $ Right Nothing
-       runTransient $ do
-           st <- get
-
-           setData $ Exit rexit
-           (async (return ()) >> labelState "input" >> liftIO inputLoop)
-
-            <|> do
-                   option "ps" "show threads"
-                   liftIO $ showThreads st
-                   empty
-            <|> do
-                   option "log" "inspect the log of a thread"
-                   th <- input (const True)  "thread number>"
-                   ml <- liftIO $ showState th st
-                   liftIO $ print $ fmap (\(Log _ _ log) -> reverse log) ml
-                   empty
-            <|> do
-                   option "end" "exit"
-                   killChilds
-                   liftIO $ putMVar rexit Nothing
-                   empty
-            <|> mx
-       return ()
-   threadDelay 10000
-   execCommandLine
-   stay rexit
-
-   where
-   type1 :: TransIO a -> Either String (Maybe a)
-   type1= undefined
-
--- | Same than `keep` but do not initiate the asynchronous keyboard input.
--- Useful for debugging or for creating background tasks, as well as to embed the Transient monad
--- inside another computation. It returns either the value returned by `exit`.
--- or Nothing, when there is no more threads running
-keep' :: Typeable a => TransIO a -> IO  (Maybe a)
-keep' mx  = do
-   liftIO $ hSetBuffering stdout LineBuffering
-   rexit <- newEmptyMVar
-   forkIO $ do
-           runTransient $ do
-              setData $ Exit rexit
-              mx
-
-           return ()
-   threadDelay 10000
-   forkIO $ execCommandLine
-   stay rexit
-
-
-execCommandLine= do
-   args <- getArgs
-   let mindex =  findIndex (\o ->  o == "-p" || o == "--path" ) args
-   when (isJust mindex) $ do
-        let i= fromJust mindex +1
-        when (length  args >= i) $ do
-          let path= args !! i
-          putStr "Executing: " >> print  path
-          processLine  path
-
--- | Force the finalization of the main thread and thus, all the Transient block (and the application
--- if there is no more code)
-exit :: Typeable a => a -> TransIO a
-exit x= do
-  Exit rexit <- getSData <|> error "exit: not the type expected"  `asTypeOf` type1 x
-  liftIO $  putMVar  rexit  $ Just x
-  stop
-  where
-  type1 :: a -> TransIO (Exit (MVar (Maybe a)))
-  type1= undefined
-
-
-
--- | Alternative operator for maybe values. Used  in infix mode
-onNothing :: Monad m => m (Maybe b) -> m b -> m b
-onNothing iox iox'= do
-       mx <- iox
-       case mx of
-           Just x -> return x
-           Nothing -> iox'
-
-
-
-
-
-----------------------------------backtracking ------------------------
-
-
-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
-
--- | backtracking is stopped. the exection continues 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, the backtracking 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)
-
-        case mr of
-           Nothing -> return empty                                      -- !> "END EXECUTION"
-           Just x -> case back of
-                 Nothing -> 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)
-
-
-
--- | trigger finish when the stream of data ends
-checkFinalize v=
-   case v of
-      SDone ->  stop
-      SLast x ->  return x
-      SError e -> back  e
-      SMore x -> return x
-
------- exceptions ---
--- | When a exception is produced anywhere after this statement, the handler is executed.
--- | handlers are executed Last in first out.
-onException :: Exception e => (e -> TransIO ()) -> TransIO ()
-onException exc= return () `onException'` exc
-
-
-onException' :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a
-onException' mx f= onAnyException mx $ \e ->
-    case fromException e of
-       Nothing -> empty
-       Just e'  -> f e'
-  where
-  onAnyException :: TransIO a -> (SomeException ->TransIO a) -> TransIO a
-  onAnyException mx f=  mx `onBack` f
-
--- | stop the backtracking mechanism from executing further handlers
-cutExceptions= backCut (undefined :: SomeException)
-
--- | Resume to normal execution at this point
+-----------------------------------------------------------------------------
+--
+-- Module      :  Base
+-- Copyright   :
+-- License     :  MIT
+--
+-- Maintainer  :  agocorona@gmail.com
+-- Stability   :
+-- Portability :
+--
+-- | See http://github.com/agocorona/transient
+-- Everything in this module is exported in order to allow extensibility.
+-----------------------------------------------------------------------------
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts          #-}
+{-# LANGUAGE FlexibleInstances         #-}
+{-# LANGUAGE MultiParamTypeClasses     #-}
+{-# LANGUAGE DeriveDataTypeable        #-}
+{-# LANGUAGE UndecidableInstances      #-}
+{-# LANGUAGE Rank2Types                #-}
+{-# LANGUAGE RecordWildCards           #-}
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE InstanceSigs              #-}
+{-# LANGUAGE ConstraintKinds           #-}
+
+module Transient.Internals where
+
+import           Control.Applicative
+import           Control.Monad.State
+import           Data.Dynamic
+import qualified Data.Map               as M
+import           System.IO.Unsafe
+import           Unsafe.Coerce
+import           Control.Exception hiding (try,onException)
+import qualified Control.Exception  (try)
+import           Control.Concurrent
+import           GHC.Conc(unsafeIOToSTM)
+import           Control.Concurrent.STM hiding (retry)
+import qualified Control.Concurrent.STM  as STM (retry)
+import           System.Mem.StableName
+import           Data.Maybe
+
+import           Data.List
+import           Data.IORef
+import           System.Environment
+import           System.IO
+
+import qualified Data.ByteString.Char8 as BS
+
+#ifdef DEBUG
+
+import           Data.Monoid
+import           Debug.Trace
+import           System.Exit
+
+{-# INLINE (!>) #-}
+(!>) :: Show a => b -> a -> b
+(!>) x y = trace (show y) x
+infixr 0 !>
+
+#else
+
+{-# INLINE (!>) #-}
+(!>) :: a -> b -> a
+(!>) = const
+
+#endif
+
+type StateIO = StateT EventF IO
+
+newtype TransIO a = Transient { runTrans :: StateIO (Maybe a) }
+
+type SData = ()
+
+type EventId = Int
+
+type TransientIO = TransIO
+
+data LifeCycle = Alive | Parent | Listener | Dead
+  deriving (Eq, Show)
+
+-- | EventF describes the context of a TransientIO computation:
+data EventF = forall a b. EventF
+  { meffects     :: ()
+
+  , event       :: Maybe SData
+    -- ^ Not yet consumed result (event) from the last asynchronous run of the
+    -- computation
+
+  , xcomp       :: TransIO a
+  , fcomp       :: [b -> TransIO b]
+    -- ^ List of continuations
+
+  , mfData      :: M.Map TypeRep SData
+    -- ^ State data accessed with get or put operations
+
+  , mfSequence  :: Int
+  , threadId    :: ThreadId
+  , freeTh      :: Bool
+    -- ^ When 'True', threads are not killed using kill primitives
+
+  , parent      :: Maybe EventF
+    -- ^ The parent of this thread
+
+  , children    :: MVar [EventF]
+    -- ^ Forked child threads, used only when 'freeTh' is 'False'
+
+  , maxThread   :: Maybe (IORef Int)
+    -- ^ Maximum number of threads that are allowed to be created
+
+  , labelth     :: IORef (LifeCycle, BS.ByteString)
+    -- ^ Label the thread with its lifecycle state and a label string
+  } deriving Typeable
+
+type Effects =
+  forall a b c. TransIO a -> TransIO a -> (a -> TransIO b)
+    -> StateIO (StateIO (Maybe c) -> StateIO (Maybe c), Maybe a)
+
+instance MonadState EventF TransIO where
+  get     = Transient $ get   >>= return . Just
+  put x   = Transient $ put x >>  return (Just ())
+  state f =  Transient $ do
+    s <- get
+    let ~(a, s') = f s
+    put s'
+    return $ Just a
+
+-- | Run a "non transient" computation within the underlying state monad, so it is
+-- guaranteed that the computation neither can stop neither can trigger additional
+-- events/threads.
+noTrans :: StateIO x -> TransIO x
+noTrans x = Transient $ x >>= return . Just
+
+emptyEventF :: ThreadId -> IORef (LifeCycle, BS.ByteString) -> MVar [EventF] -> EventF
+emptyEventF th label childs =
+  EventF { meffects   = mempty
+         , event      = mempty
+         , xcomp      = empty
+         , fcomp      = []
+         , mfData     = mempty
+         , mfSequence = 0
+         , threadId   = th
+         , freeTh     = False
+         , parent     = Nothing
+         , children   = childs
+         , maxThread  = Nothing
+         , labelth    = label }
+
+-- | Run a transient computation with a default initial state
+runTransient :: TransIO a -> IO (Maybe a, EventF)
+runTransient t = do
+  th     <- myThreadId
+  label  <- newIORef $ (Alive, BS.pack "top")
+  childs <- newMVar []
+  runStateT (runTrans t) $ emptyEventF th label childs
+
+-- | Run a transient computation with a given initial state
+runTransState :: EventF -> TransIO x -> IO (Maybe x, EventF)
+runTransState st x = runStateT (runTrans x) st
+
+-- | Get the continuation context: closure, continuation, state, child threads etc
+getCont :: TransIO EventF
+getCont = Transient $ Just <$> get
+
+-- | Run the closure and the continuation using the state data of the calling thread
+runCont :: EventF -> StateIO (Maybe a)
+runCont EventF { xcomp = x, fcomp = fs } = runTrans $ do
+  r <- unsafeCoerce x
+  compose fs r
+
+-- | Run the closure and the continuation using its own state data.
+runCont' :: EventF -> IO (Maybe a, EventF)
+runCont' cont = runStateT (runCont cont) cont
+
+-- | Warning: Radically untyped stuff. handle with care
+getContinuations :: StateIO [a -> TransIO b]
+getContinuations = do
+  EventF { fcomp = fs } <- get
+  return $ unsafeCoerce fs
+
+{-
+runCont cont = do
+  mr <- runClosure cont
+  case mr of
+    Nothing -> return Nothing
+    Just r -> runContinuation cont r
+-}
+
+-- | Compose a list of continuations.
+compose :: [a -> TransIO a] -> (a -> TransIO b)
+compose []     = const empty
+compose (f:fs) = \x -> f x >>= compose fs
+
+-- | Run the closure  (the 'x' in 'x >>= f') of the current bind operation.
+runClosure :: EventF -> StateIO (Maybe a)
+runClosure EventF { xcomp = x } = unsafeCoerce (runTrans x)
+
+-- | Run the continuation (the 'f' in 'x >>= f') of the current bind operation with the current state.
+runContinuation ::  EventF -> a -> StateIO (Maybe b)
+runContinuation EventF { fcomp = fs } =
+  runTrans . (unsafeCoerce $ compose $  fs)
+
+-- | Save a closure and a continuation ('x' and 'f' in 'x >>= f').
+setContinuation :: TransIO a -> (a -> TransIO b) -> [c -> TransIO c] -> StateIO ()
+setContinuation  b c fs = do
+  modify $ \EventF{..} -> EventF { xcomp = b
+                                  , fcomp = unsafeCoerce c : fs
+                                  , .. }
+
+-- | Save a closure and continuation, run the closure, restore the old continuation.
+-- | NOTE: The old closure is discarded.
+withContinuation :: b -> TransIO a -> TransIO a
+withContinuation c mx = do
+  EventF { fcomp = fs, .. } <- get
+  put $ EventF { xcomp = mx
+               , fcomp = unsafeCoerce c : fs
+               , .. }
+  r <- mx
+  restoreStack fs
+  return r
+
+-- | Restore the continuations to the provided ones.
+-- | NOTE: Events are also cleared out.
+restoreStack :: MonadState EventF m => [a -> TransIO a] -> m ()
+restoreStack fs = modify $ \EventF {..} -> EventF { event = Nothing, fcomp = fs, .. }
+
+-- | Run a chain of continuations.
+-- WARNING: It is up to the programmer to assure that each continuation typechecks
+-- with the next, and that the parameter type match the input of the first
+-- continuation.
+-- NOTE: Normally this makes sense to stop the current flow with `stop` after the
+-- invocation.
+runContinuations :: [a -> TransIO b] -> c -> TransIO d
+runContinuations fs x = compose (unsafeCoerce fs)  x
+
+-- Instances for Transient Monad
+
+instance Functor TransIO where
+  fmap f mx = do
+    x <- mx
+    return $ f x
+
+instance Applicative TransIO where
+  pure a  = Transient . return $ Just a
+
+  f <*> g = Transient $ do
+         rf <- liftIO $ newIORef (Nothing,[])
+         rg <- liftIO $ newIORef (Nothing,[])
+#ifdef DEBUG
+                 !> "NEWIOREF"
+#endif
+
+         fs <- getContinuations
+
+         let hasWait (_:Wait:_) = True
+             hasWait _          = False
+
+             appf k = Transient $  do
+                   Log rec _ full <- getData `onNothing` return (Log False [] [])
+                   (liftIO $ writeIORef rf  (Just k,full))
+#ifdef DEBUG
+                               !> ( show $ unsafePerformIO myThreadId) ++"APPF"
+#endif
+                   (x, full2)<- liftIO $ readIORef rg
+                   when (hasWait  full ) $
+#ifdef DEBUG
+                       (!> (hasWait full,"full",full, "\nfull2",full2)) $
+#endif
+                        let full'= head full: full2
+                        in (setData $ Log rec full' full')
+#ifdef DEBUG
+                           !> ("result1",full')
+#endif
+                   return $ Just k <*> x
+
+             appg x = Transient $  do
+                   Log rec _ full <- getData `onNothing` return (Log False [] [])
+                   liftIO $ writeIORef rg (Just x, full)
+#ifdef DEBUG
+                     !> ( show $ unsafePerformIO myThreadId) ++ "APPG"
+#endif
+                   (k,full1) <- liftIO $ readIORef rf
+                   when (hasWait  full) $
+#ifdef DEBUG
+                       (!> ("full", full, "\nfull1",full1)) $
+#endif
+                        let full'= head full: full1
+                        in (setData $ Log rec full' full')
+#ifdef DEBUG
+                           !> ("result2",full')
+#endif
+                   return $ k <*> Just x
+
+         setContinuation f appf fs
+
+         k <- runTrans f
+#ifdef DEBUG
+                  !> ( show $ unsafePerformIO myThreadId)++ "RUN f"
+#endif
+         was <- getData `onNothing` return NoRemote
+         when (was == WasParallel) $  setData NoRemote
+
+         Log recovery _ full <- getData `onNothing` return (Log False [] [])
+
+
+
+         if was== WasRemote  || (not recovery && was == NoRemote  && isNothing k )
+#ifdef DEBUG
+              !>  ("was,recovery,isNothing=",was,recovery, isNothing k)
+#endif
+         -- if the first operand was a remote request
+         -- (so this node is not master and hasn't to execute the whole expression)
+         -- or it was not an asyncronous term (a normal term without async or parallel
+         -- like primitives) and is nothing
+           then  do
+             restoreStack fs
+             return Nothing
+           else do
+             when (isJust k) $ liftIO $ writeIORef rf  (k,full)
+                -- when necessary since it maybe WasParallel and Nothing
+
+             setContinuation g appg fs
+
+             x <- runTrans g
+#ifdef DEBUG
+                     !> ( show $ unsafePerformIO myThreadId) ++ "RUN g"
+#endif
+             Log recovery _ full' <- getData `onNothing` return (Log False [] [])
+             liftIO $ writeIORef rg  (x,full')
+             restoreStack fs
+             k'' <- if was== WasParallel
+                      then do
+                        (k',_) <- liftIO $ readIORef rf -- since k may have been updated by a parallel f
+                        return k'
+                      else return k
+             return $ k'' <*> x
+
+instance Monad TransIO where
+  return   = pure
+  x >>= f  = Transient $ do
+    c  <- setEventCont x f
+    mk <- runTrans x
+    resetEventCont mk c
+    case mk of
+      Just k  -> runTrans (f k)
+      Nothing -> return Nothing
+
+instance MonadIO TransIO where
+  liftIO mx = do
+    ex <- liftIO' $ (mx >>= return . Right) `catch`
+                    (\(e :: SomeException) -> return $ Left e)
+    case ex of
+      Left  e -> back e  -- finish $ Just e
+      Right x -> return x
+    where liftIO' x = Transient $ liftIO x >>= return . Just
+              --     let x= liftIO io in x `seq` lift x
+
+instance Monoid a => Monoid (TransIO a) where
+  mappend x y = mappend <$> x <*> y
+  mempty      = return mempty
+
+instance Alternative TransIO where
+    empty = Transient $ return  Nothing
+    (<|>) = mplus
+
+instance MonadPlus TransIO where
+  mzero     = empty
+  mplus x y = Transient $ do
+    mx <- runTrans x
+#ifdef DEBUG
+            !> "RUNTRANS11111"
+#endif
+    was <- getData `onNothing` return NoRemote
+    if was == WasRemote
+#ifdef DEBUG
+        !> was
+#endif
+      then return Nothing
+      else case mx of
+            Nothing -> runTrans y
+#ifdef DEBUG
+                          !> "RUNTRANS22222"
+#endif
+            justx -> return justx
+
+readWithErr :: (Typeable a, Read a) => String -> IO [(a, String)]
+readWithErr line =
+  (v `seq` return [(v, left)])
+     `catch` (\(e :: SomeException) ->
+                error $ "read error trying to read type: \"" ++ show (typeOf v)
+                     ++ "\" in:  " ++ " <" ++ show line ++ "> ")
+  where [(v, left)] = readsPrec 0 line
+
+readsPrec' _ = unsafePerformIO . readWithErr
+
+-- | Constraint type synonym for a value that can be logged.
+type Loggable a = (Show a, Read a, Typeable a)
+
+-- | Dynamic serializable data for logging.
+data IDynamic =
+    IDyns String
+  | forall a. Loggable a => IDynamic a
+
+instance Show IDynamic where
+  show (IDynamic x) = show (show x)
+  show (IDyns    s) = show s
+
+instance Read IDynamic where
+  readsPrec n str = map (\(x,s) -> (IDyns x,s)) $ readsPrec' n str
+
+type Recover        = Bool
+type CurrentPointer = [LogElem]
+type LogEntries     = [LogElem]
+
+data LogElem        =  Wait | Exec | Var IDynamic
+  deriving (Read, Show)
+
+data Log            = Log Recover CurrentPointer LogEntries
+  deriving (Typeable, Show)
+
+data RemoteStatus   = WasRemote | WasParallel | NoRemote
+  deriving (Typeable, Eq, Show)
+
+-- | A synonym of 'empty' that can be used in a monadic expression. It stops
+-- the computation, which allows the next computation in an 'Alternative'
+-- ('<|>') composition to run.
+stop :: Alternative m => m stopped
+stop = empty
+
+--instance (Num a,Eq a,Fractional a) =>Fractional (TransIO a)where
+--     mf / mg = (/) <$> mf <*> mg
+--     fromRational (x:%y) =  fromInteger x % fromInteger y
+
+
+instance (Num a, Eq a) => Num (TransIO a) where
+  fromInteger = return . fromInteger
+  mf + mg     = (+) <$> mf <*> mg
+  mf * mg     = (*) <$> mf <*> mg
+  negate f    = f >>= return . negate
+  abs f       = f >>= return . abs
+  signum f    = f >>= return . signum
+
+class AdditionalOperators m where
+
+  -- | Run @m a@ discarding its result before running @m b@.
+  (**>)  :: m a -> m b -> m b
+
+  -- | Run @m b@ discarding its result, after the whole task set @m a@ is
+  -- done.
+  (<**)  :: m a -> m b -> m a
+
+  atEnd' :: m a -> m b -> m a
+  atEnd' = (<**)
+
+  -- | Run @m b@ discarding its result, once after each task in @m a@, and
+  -- once again after the whole task set is done.
+  (<***) :: m a -> m b -> m a
+
+  atEnd  :: m a -> m b -> m a
+  atEnd  = (<***)
+
+instance AdditionalOperators TransIO where
+
+  (**>) :: TransIO a -> TransIO b -> TransIO b
+  (**>) x y =
+    Transient $ do
+      runTrans x
+      runTrans y
+
+  (<***) :: TransIO a -> TransIO b -> TransIO a
+  (<***) ma mb =
+    Transient $ do
+      fs  <- getContinuations
+      setContinuation ma (\x -> mb >> return x)  fs
+      a <- runTrans ma
+      runTrans mb
+      restoreStack fs
+      return  a
+
+  (<**) :: TransIO a -> TransIO b -> TransIO a
+  (<**) ma mb =
+    Transient $ do
+      a <- runTrans ma
+#ifdef DEBUG
+             !> "ma"
+#endif
+
+      runTrans  mb
+#ifdef DEBUG
+        !> "mb"
+#endif
+      return a
+
+infixr 1 <***, <**, **>
+
+-- | Run @b@ once, discarding its result when the first task in task set @a@
+-- has finished. Useful to start a singleton task after the first task has been
+-- setup.
+(<|) :: TransIO a -> TransIO b -> TransIO a
+(<|) ma mb = Transient $ do
+  fs  <- getContinuations
+  ref <- liftIO $ newIORef False
+  setContinuation ma (cont ref)  fs
+  r   <- runTrans ma
+  restoreStack fs
+  return  r
+  where cont ref x = Transient $ do
+          n <- liftIO $ readIORef ref
+          if n == True
+            then return $ Just x
+            else do liftIO $ writeIORef ref True
+                    runTrans mb
+                    return $ Just x
+
+-- | Set the current closure and continuation for the current statement
+setEventCont :: TransIO a -> (a -> TransIO b) -> StateIO EventF
+setEventCont x f  = do
+  EventF { fcomp = fs, .. } <- get
+#ifdef DEBUG
+                   !> "SET"
+#endif
+  let cont = EventF { xcomp = x
+                    , fcomp = unsafeCoerce f : fs
+                    , .. }
+  put cont
+  return cont
+
+-- | Reset the closure and continuation. Remove inner binds than the previous
+-- computations may have stacked in the list of continuations.
+-- resetEventCont :: Maybe a -> EventF -> StateIO (TransIO b -> TransIO b)
+resetEventCont mx _ = do
+  EventF { fcomp = fs, .. } <- get
+#ifdef DEBUG
+                   !> "reset"
+#endif
+  let f mx = case mx of
+        Nothing -> empty
+        Just x  -> unsafeCoerce (head fs) x
+  put $ EventF { xcomp = f mx
+               , fcomp = tailsafe fs
+               , .. }
+  return  id
+
+-- | Total variant of `tail` that returns an empty list when given an empty list.
+tailsafe :: [a] -> [a]
+tailsafe []     = []
+tailsafe (x:xs) = xs
+
+--refEventCont= unsafePerformIO $ newIORef baseEffects
+
+-- effects not used
+-- {-# INLINE baseEffects #-}
+--baseEffects :: Effects
+--
+--baseEffects x  x' f' = do
+--            c <- setEventCont x'  f'
+--            mk <- runTrans x
+--            t <- resetEventCont mk c
+--            return (t,mk)
+
+
+--instance MonadTrans (Transient ) where
+--  lift mx = Transient $ mx >>= return . Just
+
+-- * Threads
+
+waitQSemB   sem = atomicModifyIORef sem $ \n ->
+                    if n > 0 then(n - 1, True) else (n, False)
+signalQSemB sem = atomicModifyIORef sem $ \n -> (n + 1, ())
+
+-- | Sets the maximum number of threads that can be created for the given task
+-- set.  When set to 0, new tasks start synchronously in the current thread.
+-- New threads are created by 'parallel', and APIs that use parallel.
+threads :: Int -> TransIO a -> TransIO a
+threads n process = do
+   msem <- gets maxThread
+   sem <- liftIO $ newIORef n
+   modify $ \s -> s { maxThread = Just sem }
+   r <- process <** (modify $ \s -> s { maxThread = msem }) -- restore it
+   return r
+
+-- | Terminate all the child threads in the given task set and continue
+-- execution in the current thread. Useful to reap the children when a task is
+-- done.
+--
+oneThread :: TransIO a -> TransIO a
+oneThread comp = do
+  st    <-  get
+  chs   <- liftIO $ newMVar []
+  label <- liftIO $ newIORef (Alive, BS.pack "oneThread")
+  let st' = st { parent   = Just st
+              , children = chs
+              , labelth  = label }
+  liftIO $ hangThread st st'
+  put st'
+  x   <- comp
+  th  <- liftIO myThreadId
+#ifdef DEBUG
+          !> ("FATHER:", threadId st)
+#endif
+  chs <- liftIO $ readMVar chs -- children st'
+  liftIO $ mapM_ (killChildren1 th) chs
+  return x
+  where killChildren1 :: ThreadId  ->  EventF -> IO ()
+        killChildren1 th state = do
+          ths' <- modifyMVar (children state) $ \ths -> do
+                    let (inn, ths')=  partition (\st -> threadId st == th) ths
+                    return (inn, ths')
+          mapM_ (killChildren1  th) ths'
+          mapM_ (killThread . threadId) ths'
+#ifdef DEBUG
+            !> ("KILLEVENT1 ", map threadId ths' )
+#endif
+
+-- | Add a label to the current passing threads so it can be printed by debugging calls like `showThreads`
+labelState :: String -> TransIO ()
+labelState l =  do
+  st <- get
+  liftIO $ atomicModifyIORef (labelth st) $ \(status,_) -> ((status, BS.pack l), ())
+
+printBlock :: MVar ()
+printBlock = unsafePerformIO $ newMVar ()
+
+-- | Show the tree of threads hanging from the state.
+showThreads :: MonadIO m => EventF -> m ()
+showThreads st = liftIO $ withMVar printBlock $ const $ do
+  mythread <- myThreadId
+#ifdef DEBUG
+                !> "showThreads"
+#endif
+  putStrLn "---------Threads-----------"
+  let showTree n ch = do
+        liftIO $ do
+          putStr $ take n $ repeat ' '
+          (state, label) <- readIORef $ labelth ch
+          if BS.null label
+            then putStr . show $ threadId ch
+            else do BS.putStr label; putStr . drop 8 . show $ threadId ch
+                    when (state == Dead) $ putStr " dead"
+          putStrLn $ if mythread == threadId ch then " <--" else ""
+        chs <- readMVar $ children ch
+        mapM_ (showTree $ n + 2) $ reverse chs
+  showTree 0 st
+
+-- | Return the state of the thread that initiated the transient computation
+topState :: TransIO EventF
+topState = do
+  st <- get
+  return $ toplevel st
+  where toplevel st = case parent st of
+                        Nothing -> st
+                        Just p  -> toplevel p
+
+-- | Return the state variable of the type desired with which a thread, identified by his number in the treee was initiated
+showState :: (Typeable a, MonadIO m, Alternative m) => String -> EventF -> m  (Maybe a)
+showState th top = resp
+  where resp = do
+          let thstring = drop 9 . show $ threadId top
+          if thstring == th
+          then getstate top
+          else do
+            sts <- liftIO $ readMVar $ children top
+            foldl (<|>) empty $ map (showState th) sts
+        getstate st =
+            case M.lookup (typeOf $ typeResp resp) $ mfData st of
+              Just x  -> return . Just $ unsafeCoerce x
+              Nothing -> return Nothing
+        typeResp :: m (Maybe x) -> x
+        typeResp = undefined
+
+-- | Add n threads to the limit of threads. If there is no limit, the limit is set.
+addThreads' :: Int -> TransIO ()
+addThreads' n= noTrans $ do
+  msem <- gets maxThread
+  case msem of
+    Just sem -> liftIO $ modifyIORef sem $ \n' -> n + n'
+    Nothing  -> do
+      sem <- liftIO (newIORef n)
+      modify $ \ s -> s { maxThread = Just sem }
+
+-- | Ensure that at least n threads are available for the current task set.
+addThreads :: Int -> TransIO ()
+addThreads n = noTrans $ do
+  msem <- gets maxThread
+  case msem of
+    Nothing  -> return ()
+    Just sem -> liftIO $ modifyIORef sem $ \n' -> if n' > n then n' else  n
+
+--getNonUsedThreads :: TransIO (Maybe Int)
+--getNonUsedThreads= Transient $ do
+--   msem <- gets maxThread
+--   case msem of
+--    Just sem -> liftIO $ Just <$> readIORef sem
+--    Nothing -> return Nothing
+
+-- | Disable tracking and therefore the ability to terminate the child threads.
+-- By default, child threads are terminated automatically when the parent
+-- thread dies, or they can be terminated using the kill primitives. Disabling
+-- it may improve performance a bit, however, all threads must be well-behaved
+-- to exit on their own to avoid a leak.
+freeThreads :: TransIO a -> TransIO a
+freeThreads process = Transient $ do
+  st <- get
+  put st { freeTh = True }
+  r  <- runTrans process
+  modify $ \s -> s { freeTh = freeTh st }
+  return r
+
+-- | Enable tracking and therefore the ability to terminate the child threads.
+-- This is the default but can be used to re-enable tracking if it was
+-- previously disabled with 'freeThreads'.
+hookedThreads :: TransIO a -> TransIO a
+hookedThreads process = Transient $ do
+  st <- get
+  put st {freeTh = False}
+  r  <- runTrans process
+  modify $ \st -> st { freeTh = freeTh st }
+  return r
+
+-- | Kill all the child threads of the current thread.
+killChilds :: TransIO ()
+killChilds = noTrans $ do
+  cont <- get
+  liftIO $ do
+    killChildren $ children cont
+    writeIORef (labelth cont) (Alive, mempty)
+#ifdef DEBUG
+      !> (threadId cont,"relabeled")
+#endif
+  return ()
+
+-- | Kill the current thread and the childs.
+killBranch :: TransIO ()
+killBranch = noTrans $ do
+  st <- get
+  liftIO $ killBranch' st
+
+-- | Kill the childs and the thread of an state
+killBranch' :: EventF -> IO ()
+killBranch' cont = do
+  killChildren $ children cont
+  let thisth  = threadId  cont
+      mparent = parent    cont
+  when (isJust mparent) $
+    modifyMVar_ (children $ fromJust mparent) $ \sts ->
+      return $ filter (\st -> threadId st /= thisth) sts
+  killThread $ thisth
+
+-- * Extensible State: Session Data Management
+
+-- | Same as 'getSData' but with a more general type. If the data is found, a
+-- 'Just' value is returned. Otherwise, a 'Nothing' value is returned.
+getData :: (MonadState EventF m, Typeable a) => m (Maybe a)
+getData = resp
+  where resp = do
+          list <- gets mfData
+          case M.lookup (typeOf $ typeResp resp) list of
+            Just x  -> return . Just $ unsafeCoerce x
+            Nothing -> return Nothing
+        typeResp :: m (Maybe x) -> x
+        typeResp = undefined
+
+-- | Retrieve a previously stored data item of the given data type from the
+-- monad state. The data type to retrieve is implicitly determined from the
+-- requested type context.
+-- If the data item is not found, an 'empty' value (a void event) is returned.
+-- Remember that an empty value stops the monad computation. If you want to
+-- print an error message or a default value in that case, you can use an
+-- 'Alternative' composition. For example:
+--
+-- > getSData <|> error "no data"
+-- > getInt = getSData <|> return (0 :: Int)
+getSData :: Typeable a => TransIO a
+getSData = Transient getData
+
+-- | Same as `getSData`
+getState :: Typeable a => TransIO a
+getState = getSData
+
+-- | 'setData' stores a data item in the monad state which can be retrieved
+-- later using 'getData' or 'getSData'. Stored data items are keyed by their
+-- data type, and therefore only one item of a given type can be stored. A
+-- newtype wrapper can be used to distinguish two data items of the same type.
+--
+-- @
+-- import Control.Monad.IO.Class (liftIO)
+-- import Transient.Base
+-- import Data.Typeable
+--
+-- data Person = Person
+--    { name :: String
+--    , age :: Int
+--    } deriving Typeable
+--
+-- main = keep $ do
+--      setData $ Person "Alberto"  55
+--      Person name age <- getSData
+--      liftIO $ print (name, age)
+-- @
+setData :: (MonadState EventF m, Typeable a) => a -> m ()
+setData x = modify $ \st -> st { mfData = M.insert t (unsafeCoerce x) (mfData st) }
+  where t = typeOf x
+
+-- | Accepts a function that takes the current value of the stored data type
+-- and returns the modified value. If the function returns 'Nothing' the value
+-- is deleted otherwise updated.
+modifyData :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m ()
+modifyData f = modify $ \st -> st { mfData = M.alter alterf t (mfData st) }
+  where typeResp :: (Maybe a -> b) -> a
+        typeResp   = undefined
+        t          = typeOf (typeResp f)
+        alterf mx  = unsafeCoerce $ f x'
+          where x' = case mx of
+                       Just x  -> Just $ unsafeCoerce x
+                       Nothing -> Nothing
+
+-- | Same as modifyData
+modifyState :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m ()
+modifyState = modifyData
+
+-- | Same as 'setData'
+setState :: (MonadState EventF m, Typeable a) => a -> m ()
+setState = setData
+
+-- | Delete the data item of the given type from the monad state.
+delData :: (MonadState EventF m, Typeable a) => a -> m ()
+delData x = modify $ \st -> st { mfData = M.delete (typeOf x) (mfData st) }
+
+-- | Same as 'delData'
+delState :: (MonadState EventF m, Typeable a) => a -> m ()
+delState = delData
+
+-- | Run an action, if the result is a void action undo any state changes
+-- that it might have caused.
+try :: TransIO a -> TransIO a
+try mx = do
+  sd <- gets mfData
+  mx <|> (modify (\s -> s { mfData = sd }) >> empty)
+
+-- | Executes the computation and reset the state either if it fails or not
+sandbox :: TransIO a -> TransIO a
+sandbox mx = do
+  sd <- gets mfData
+  mx <*** modify (\s ->s { mfData = sd})
+
+-- | Generator of identifiers that are unique within the current monadic
+-- sequence They are not unique in the whole program.
+genId :: MonadState EventF m => m Int
+genId = do
+  st <- get
+  let n = mfSequence st
+  put st { mfSequence = n + 1 }
+  return n
+
+getPrevId :: MonadState EventF m => m Int
+getPrevId = gets mfSequence
+
+instance Read SomeException where
+  readsPrec n str = [(SomeException $ ErrorCall s, r)]
+    where [(s , r)] = read str
+
+-- | 'StreamData' represents a task in a task stream being generated.
+data StreamData a =
+      SMore a               -- ^ More tasks to come
+    | SLast a               -- ^ This is the last task
+    | SDone                 -- ^ No more tasks, we are done
+    | SError SomeException  -- ^ An error occurred
+    deriving (Typeable, Show,Read)
+
+-- | An task stream generator that produces an infinite stream of tasks by
+-- running an IO computation in a loop. A task is triggered carrying the output
+-- of the computation. See 'parallel' for notes on the return value.
+waitEvents :: IO a -> TransIO a
+waitEvents io = do
+  mr <- parallel (SMore <$> io)
+  case mr of
+    SMore  x -> return x
+    SError e -> back   e
+
+-- | Run an IO computation asynchronously and generate a single task carrying
+-- the result of the computation when it completes. See 'parallel' for notes on
+-- the return value.
+async :: IO a -> TransIO a
+async io = do
+  mr <- parallel (SLast <$> io)
+  case mr of
+    SLast  x -> return x
+    SError e -> back   e
+
+-- | Force an async computation to run synchronously. It can be useful in an
+-- 'Alternative' composition to run the alternative only after finishing a
+-- computation.  Note that in Applicatives it might result in an undesired
+-- serialization.
+sync :: TransIO a -> TransIO a
+sync x = do
+  setData WasRemote
+  r <- x
+  delData WasRemote
+  return r
+
+-- | @spawn = freeThreads . waitEvents@
+spawn :: IO a -> TransIO a
+spawn = freeThreads . waitEvents
+
+-- | An task stream generator that produces an infinite stream of tasks by
+-- running an IO computation periodically at the specified time interval. The
+-- task carries the result of the computation.  A new task is generated only if
+-- the output of the computation is different from the previous one.  See
+-- 'parallel' for notes on the return value.
+sample :: Eq a => IO a -> Int -> TransIO a
+sample action interval = do
+  v    <- liftIO action
+  prev <- liftIO $ newIORef v
+  waitEvents (loop action prev) <|> async (return v)
+  where loop action prev = loop'
+          where loop' = do
+                  threadDelay interval
+                  v  <- action
+                  v' <- readIORef prev
+                  if v /= v' then writeIORef prev v >> return v else loop'
+
+--serial  ::    IO (StreamData b) -> TransIO (StreamData b)
+--serial  ioaction= Transient $   do
+--    cont <- get                    -- !> "PARALLEL"
+--    case event cont of
+--         j@(Just _) -> do
+--                    put cont{event=Nothing}
+--                    return $ unsafeCoerce j
+--         Nothing -> do
+--                    liftIO $ loop cont ioaction
+--                    return Nothing
+--
+--   where loop cont ioaction= do
+--            let iocont dat= do
+--                    runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
+--                    return ()
+--            mdat <- ioaction `catch` \(e :: SomeException) -> return $ SError e
+--            case mdat of
+--                 se@(SError _) ->  iocont se
+--                 SDone ->          iocont SDone
+--                 last@(SLast _) -> iocont last
+--
+--                 more@(SMore _) -> do
+--                      iocont more
+--                      loop cont ioaction
+
+-- | Run an IO action one or more times to generate a stream of tasks. The IO
+-- action returns a 'StreamData'. When it returns an 'SMore' or 'SLast' a new
+-- task is triggered with the result value. If the return value is 'SMore', the
+-- action is run again to generate the next task, otherwise task creation
+-- stops.
+--
+-- Unless the maximum number of threads (set with 'threads') has been reached,
+-- the task is generated in a new thread and the current thread returns a void
+-- task.
+parallel :: IO (StreamData b) -> TransIO (StreamData b)
+parallel ioaction = Transient $ do
+  cont <- get
+#ifdef DEBUG
+            !> "PARALLEL"
+#endif
+  case event cont of
+    j@(Just _) -> do
+      put cont { event = Nothing }
+      return $ unsafeCoerce j
+    Nothing    -> do
+      liftIO $ atomicModifyIORef (labelth cont) $ \(_, lab) -> ((Parent, lab), ())
+      liftIO $ loop cont ioaction
+      was <- getData `onNothing` return NoRemote
+      when (was /= WasRemote) $ setData WasParallel
+--            th <- liftIO myThreadId
+--            return () !> ("finish",th)
+      return Nothing
+
+-- | Execute the IO action and the continuation
+loop ::  EventF -> IO (StreamData t) -> IO ()
+loop parentc rec = forkMaybe parentc $ \cont -> do
+  -- Execute the IO computation and then the closure-continuation
+  liftIO $ atomicModifyIORef (labelth cont) $ const ((Listener,BS.pack "wait"),())
+  let loop'=   do
+         mdat <- rec `catch` \(e :: SomeException) -> return $ SError e
+         case mdat of
+             se@(SError _)  -> setworker cont >> iocont  se    cont
+             SDone          -> setworker cont >> iocont  SDone cont
+             last@(SLast _) -> setworker cont >> iocont  last  cont
+
+             more@(SMore _) -> do
+                  forkMaybe cont $ iocont  more
+                  loop'
+
+         where
+         setworker cont= liftIO $ atomicModifyIORef (labelth cont) $ const ((Alive,BS.pack "work"),())
+
+         iocont  dat cont = do
+
+              let cont'= cont{event= Just $ unsafeCoerce dat}
+              runStateT (runCont cont')  cont'
+              return ()
+
+
+  loop'
+  return ()
+  where
+
+  forkMaybe parent  proc = do
+     case maxThread parent  of
+       Nothing -> forkIt parent  proc
+       Just sem  -> do
+             dofork <- waitQSemB sem
+             if dofork then  forkIt parent proc else proc parent
+
+
+  forkIt parent  proc= do
+     chs <- liftIO $ newMVar []
+
+     label <- newIORef (Alive, BS.pack "work")
+     let cont = parent{parent=Just parent,children=   chs, labelth= label}
+
+     forkFinally1 (do
+         th <- myThreadId
+         let cont'= cont{threadId=th}
+         when(not $ freeTh parent )$ hangThread parent   cont'
+                                    -- !>  ("thread created: ",th,"in",threadId parent )
+
+         proc cont')
+         $ \me -> do
+
+--             case me of -- !> "THREAD END" of
+--              Left  e -> do
+----                 when (fromException e /= Just ThreadKilled)$
+--                 liftIO $ print e
+--                 killChildren $ children cont
+----                                   !> "KILL RECEIVED" ++ (show $ unsafePerformIO myThreadId)
+--
+--              Right _ ->
+
+
+
+             case maxThread cont of
+               Just sem -> signalQSemB sem      -- !> "freed thread"
+               Nothing -> when(not $ freeTh parent  )  $ do -- if was not a free thread
+
+                 th <- myThreadId
+                 (can,label) <- atomicModifyIORef (labelth cont) $ \(l@(status,label)) ->
+                    ((if status== Alive then Dead else status, label),l)
+
+
+                 when (can/= Parent ) $ free th parent
+     return ()
+
+
+  forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
+  forkFinally1 action and_then =
+       mask $ \restore ->  forkIO $ Control.Exception.try (restore action) >>= and_then
+
+free th env= do
+--       return ()                                       !> ("freeing",th,"in",threadId env)
+       let sibling=  children env
+
+       (sbs',found) <- modifyMVar sibling $ \sbs -> do
+                   let (sbs', found) = drop [] th  sbs
+                   return (sbs',(sbs',found))
+
+
+
+       if found
+         then do
+
+--                                             !> ("new list for",threadId env,map threadId sbs')
+           (typ,_) <- readIORef $ labelth env
+           if (null sbs' && typ /= Listener && isJust (parent env))
+            -- free the parent
+            then free (threadId env) ( fromJust $ parent env)
+            else return ()
+
+--               return env
+         else return () -- putMVar sibling sbs
+                                                     -- !>  (th,"orphan")
+
+       where
+       drop processed th []= (processed,False)
+       drop processed th (ev:evts)| th ==  threadId ev= (processed ++ evts, True)
+                                  | otherwise= drop (ev:processed) th evts
+
+
+
+hangThread parentProc child =  do
+
+       let headpths= children parentProc
+
+       modifyMVar_ headpths $ \ths -> return (child:ths)
+--       ths <- takeMVar headpths
+--       putMVar headpths (child:ths)
+
+
+           --  !> ("hang", threadId child, threadId parentProc,map threadId ths,unsafePerformIO $ readIORef $ labelth parentProc)
+
+-- | kill  all the child threads associated with the continuation context
+killChildren childs  = do
+
+
+           ths <- modifyMVar childs $ \ths -> return ([],ths)
+--           ths <- takeMVar childs
+--           putMVar childs []
+
+           mapM_ (killChildren . children) ths
+
+
+           mapM_ (killThread . threadId) ths  -- !> ("KILL", map threadId ths )
+
+
+
+
+
+-- | Make a transient task generator from an asynchronous callback handler.
+--
+-- The first parameter is a callback. The second parameter is a value to be
+-- returned to the callback; if the callback expects no return value it
+-- can just be a @return ()@. The callback expects a setter function taking the
+-- @eventdata@ as an argument and returning a value to the callback; this
+-- function is supplied by 'react'.
+--
+-- Callbacks from foreign code can be wrapped into such a handler and hooked
+-- into the transient monad using 'react'. Every time the callback is called it
+-- generates a new task for the transient monad.
+--
+react
+  :: Typeable eventdata
+  => ((eventdata ->  IO response) -> IO ())
+  -> IO  response
+  -> TransIO eventdata
+react setHandler iob= Transient $ do
+        cont    <- get
+        case event cont of
+          Nothing -> do
+            liftIO $ setHandler $ \dat ->do
+              runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
+              iob
+            was <- getData `onNothing` return NoRemote
+            when (was /= WasRemote) $ setData WasParallel
+            return Nothing
+
+          j@(Just _) -> do
+            put cont{event=Nothing}
+            return $ unsafeCoerce j
+
+-- | Runs a computation asynchronously without generating any events. Returns
+-- 'empty' in an 'Alternative' composition.
+
+abduce = Transient $ do
+   st <-  get
+   case  event st of
+          Just _ -> do
+               put st{event=Nothing}
+               return $ Just ()
+          Nothing -> do
+               chs <- liftIO $ newMVar []
+
+               label <-  liftIO $ newIORef (Alive, BS.pack "abduce")
+               liftIO $ forkIO $ do
+                   th <- myThreadId
+                   let st' = st{event= Just (),parent=Just st,children=   chs, threadId=th,labelth= label}
+                   liftIO $ hangThread st st'
+
+                   runCont' st'
+                   return()
+               return Nothing
+
+
+-- * non-blocking keyboard input
+
+getLineRef= unsafePerformIO $ newTVarIO Nothing
+
+
+roption= unsafePerformIO $ newMVar []
+
+-- | Waits on stdin in a loop and triggers a new task every time the input data
+-- matches the first parameter.  The value contained by the task is the matched
+-- value i.e. the first argument  itself. The second parameter is a label for
+-- the option. The label is displayed on the console when the option is
+-- activated.
+--
+-- Note that if two independent invocations of 'option' are expecting the same
+-- input, only one of them gets it and triggers a task. It cannot be
+-- predicted which one gets it.
+--
+option :: (Typeable b, Show b, Read b, Eq b) =>
+     b -> String -> TransIO b
+option ret message= do
+    let sret= show ret
+
+    liftIO $ putStrLn $ "Enter  "++sret++"\tto: " ++ message
+    liftIO $ modifyMVar_ roption $ \msgs-> return $ sret:msgs
+    waitEvents  $ getLine' (==ret)
+    liftIO $ putStr "\noption: " >> putStrLn (show ret)
+    return ret
+
+
+-- | Waits on stdin and triggers a task when a console input matches the
+-- predicate specified in the first argument.  The second parameter is a string
+-- to be displayed on the console before waiting.
+--
+input :: (Typeable a, Read a,Show a) => (a -> Bool) -> String -> TransIO a
+input cond prompt= Transient . liftIO $do
+   putStr prompt >> hFlush stdout
+   atomically $ do
+       mr <- readTVar getLineRef
+       case mr of
+         Nothing -> STM.retry
+         Just r ->
+            case reads1 r  of
+            (s,_):_ -> if cond s  --  !> show (cond s)
+                     then do
+                       unsafeIOToSTM $ print s
+                       writeTVar  getLineRef Nothing -- !>"match"
+                       return $ Just s
+
+                     else return Nothing
+            _ -> return Nothing
+
+-- | Non blocking `getLine` with a validator
+getLine' cond=    do
+     atomically $ do
+       mr <- readTVar getLineRef
+       case mr of
+         Nothing -> STM.retry
+         Just r ->
+            case reads1 r of --  !> ("received " ++  show r ++ show (unsafePerformIO myThreadId)) of
+            (s,_):_ -> if cond s -- !> show (cond s)
+                     then do
+                       writeTVar  getLineRef Nothing -- !>"match"
+                       return s
+
+                     else STM.retry
+            _ -> STM.retry
+
+reads1 s=x where
+      x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec' 0 s
+      typeOfr :: [(a,String)] ->  a
+      typeOfr  = undefined
+
+
+inputLoop= do
+           r<- getLine
+           -- XXX hoping that the previous value has been consumed by now.
+           -- otherwise its just lost by overwriting.
+           atomically $ writeTVar getLineRef Nothing
+           processLine r
+           inputLoop
+
+processLine r= do
+
+   let rs = breakSlash [] r
+
+   -- XXX this blocks forever if an input is not consumed by any consumer.
+   -- e.g. try this "xxx/xxx" on the stdin
+   liftIO $ mapM_ (\ r ->
+                 atomically $ do
+--                    threadDelay 1000000
+                    t <- readTVar getLineRef
+                    when (isJust  t) STM.retry
+                    writeTVar  getLineRef $ Just r ) rs
+
+
+    where
+    breakSlash :: [String] -> String -> [String]
+    breakSlash [] ""= [""]
+    breakSlash s ""= s
+    breakSlash res ('\"':s)=
+      let (r,rest) = span(/= '\"') s
+      in breakSlash (res++[r]) $ tail1 rest
+
+    breakSlash res s=
+      let (r,rest) = span(/= '/') s
+      in breakSlash (res++[r]) $ tail1 rest
+
+    tail1 []=[]
+    tail1 x= tail x
+
+
+
+
+-- | Wait for the execution of `exit` and return the result or the exhaustion of thread activity
+
+stay rexit=  takeMVar rexit
+ `catch` \(e :: BlockedIndefinitelyOnMVar) -> return Nothing
+
+newtype Exit a= Exit a deriving Typeable
+
+-- | Runs the transient computation in a child thread and keeps the main thread
+-- running until all the user threads exit or some thread invokes 'exit'.
+--
+-- The main thread provides facilities to accept keyboard input in a
+-- non-blocking but line-oriented manner. The program reads the standard input
+-- and feeds it to all the async input consumers (e.g. 'option' and 'input').
+-- All async input consumers contend for each line entered on the standard
+-- input and try to read it atomically. When a consumer consumes the input
+-- others do not get to see it, otherwise it is left in the buffer for others
+-- to consume. If nobody consumes the input, it is discarded.
+--
+-- A @/@ in the input line is treated as a newline.
+--
+-- When using asynchronous input, regular synchronous IO APIs like getLine
+-- cannot be used as they will contend for the standard input along with the
+-- asynchronous input thread. Instead you can use the asynchronous input APIs
+-- provided by transient.
+--
+-- A built-in interactive command handler also reads the stdin asynchronously.
+-- All available commands handled by the command handler are displayed when the
+-- program is run.  The following commands are available:
+--
+-- 1. @ps@: show threads
+-- 2. @log@: inspect the log of a thread
+-- 3. @end@, @exit@: terminate the program
+--
+-- An input not handled by the command handler can be handled by the program.
+--
+-- The program's command line is scanned for @-p@ or @--path@ command line
+-- options.  The arguments to these options are injected into the async input
+-- channel as keyboard input to the program. Each line of input is separated by
+-- a @/@. For example:
+--
+-- >  foo  -p  ps/end
+--
+keep :: Typeable a => TransIO a -> IO (Maybe a)
+keep mx = do
+
+   liftIO $ hSetBuffering stdout LineBuffering
+   rexit <- newEmptyMVar
+   forkIO $ do
+--       liftIO $ putMVar rexit  $ Right Nothing
+       runTransient $ do
+           st <- get
+
+           setData $ Exit rexit
+           (async (return ()) >> labelState "input" >> liftIO inputLoop)
+
+            <|> do
+                   option "ps" "show threads"
+                   liftIO $ showThreads st
+                   empty
+            <|> do
+                   option "log" "inspect the log of a thread"
+                   th <- input (const True)  "thread number>"
+                   ml <- liftIO $ showState th st
+                   liftIO $ print $ fmap (\(Log _ _ log) -> reverse log) ml
+                   empty
+            <|> do
+                   option "end" "exit"
+                   killChilds
+                   liftIO $ putMVar rexit Nothing
+                   empty
+            <|> mx
+       return ()
+   threadDelay 10000
+   execCommandLine
+   stay rexit
+
+   where
+   type1 :: TransIO a -> Either String (Maybe a)
+   type1= undefined
+
+-- | Same as `keep` but does not read from the standard input, and therefore
+-- the async input APIs ('option' and 'input') cannot be used in the monad.
+-- However, keyboard input can still be passed via command line arguments as
+-- described in 'keep'.  Useful for debugging or for creating background tasks,
+-- as well as to embed the Transient monad inside another computation. It
+-- returns either the value returned by `exit`.  or Nothing, when there are no
+-- more threads running
+--
+keep' :: Typeable a => TransIO a -> IO  (Maybe a)
+keep' mx  = do
+   liftIO $ hSetBuffering stdout LineBuffering
+   rexit <- newEmptyMVar
+   forkIO $ do
+           runTransient $ do
+              setData $ Exit rexit
+              mx
+
+           return ()
+   threadDelay 10000
+   forkIO $ execCommandLine
+   stay rexit
+
+
+execCommandLine= do
+   args <- getArgs
+   let mindex =  findIndex (\o ->  o == "-p" || o == "--path" ) args
+   when (isJust mindex) $ do
+        let i= fromJust mindex +1
+        when (length  args >= i) $ do
+          let path= args !! i
+          putStr "Executing: " >> print  path
+          processLine  path
+
+-- | Exit the main thread, and thus all the Transient threads (and the
+-- application if there is no more code)
+exit :: Typeable a => a -> TransIO a
+exit x= do
+  Exit rexit <- getSData <|> error "exit: not the type expected"  `asTypeOf` type1 x
+  liftIO $  putMVar  rexit  $ Just x
+  stop
+  where
+  type1 :: a -> TransIO (Exit (MVar (Maybe a)))
+  type1= undefined
+
+
+
+-- | If the first parameter is 'Nothing' return the second parameter otherwise
+-- return the first parameter..
+onNothing :: Monad m => m (Maybe b) -> m b -> m b
+onNothing iox iox'= do
+       mx <- iox
+       case mx of
+           Just x -> return x
+           Nothing -> iox'
+
+
+
+
+
+----------------------------------backtracking ------------------------
+
+
+data Backtrack b= Show b =>Backtrack{backtracking :: Maybe b
+                                    ,backStack :: [EventF] }
+                                    deriving Typeable
+
+
+
+-- | Delete all the undo actions registered till now for the given track id.
+backCut :: (Typeable b, Show b) => b -> TransientIO ()
+backCut reason= Transient $ do
+     delData $ Backtrack (Just reason)  []
+     return $ Just ()
+
+-- | 'backCut' for the default track; equivalent to @backCut ()@.
+undoCut ::  TransientIO ()
+undoCut = backCut ()
+
+-- | Run the action in the first parameter and register the second parameter as
+-- the undo action. On undo ('back') the second parameter is called with the
+-- undo track id as argument.
+--
+{-# 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
+
+-- | 'onBack' for the default track; equivalent to @onBack ()@.
+onUndo ::  TransientIO a -> TransientIO a -> TransientIO a
+onUndo x y= onBack x (\() -> y)
+
+
+-- | Register an undo action to be executed when backtracking. The first
+-- parameter is a "witness" whose data type is used to uniquely identify this
+-- backtracking action. The value of the witness parameter is not used.
+--
+{-# 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
+
+-- XXX Should we enforce retry of the same track which is being undone? If the
+-- user specifies a different track would it make sense?
+--
+-- | For a given undo track id, stop executing more backtracking actions and
+-- resume normal execution in the forward direction. Used inside an undo
+-- action.
+--
+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 ()
+
+-- | 'forward' for the default undo track; equivalent to @forward ()@.
+retry= forward ()
+
+-- | Abort finish. Stop executing more finish actions and resume normal
+-- execution.  Used inside 'onFinish' actions.
+--
+noFinish= forward (FinishReason Nothing)
+
+-- | Start the undo process for the given undo track id. Performs all the undo
+-- actions registered till now in reverse order. An undo action can use
+-- 'forward' to stop the undo process and resume forward execution. If there
+-- are no more undo actions registered execution stops and a 'stop' action is
+-- returned.
+--
+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)
+
+        case mr of
+           Nothing -> return empty                                      -- !> "END EXECUTION"
+           Just x -> case back of
+                 Nothing -> 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)) []
+
+-- | 'back' for the default undo track; equivalent to @back ()@.
+--
+undo ::  TransIO a
+undo= back ()
+
+
+------ finalization
+
+newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show)
+
+-- | Clear all finish actions registered till now.
+initFinish= backCut (FinishReason Nothing)
+
+-- | Register an action that to be run when 'finish' is called. 'onFinish' can
+-- be used multiple times to register multiple actions. Actions are run in
+-- reverse order. Used in infix style.
+--
+onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO ()
+onFinish f= onFinish' (return ()) f
+
+
+-- | Run the action specified in the first parameter and register the second
+-- parameter as a finish action to be run when 'finish' is called. Used in
+-- infix style.
+--
+onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a
+onFinish' proc f= proc `onBack`   \(FinishReason reason) ->
+    f reason
+
+
+-- | Execute all the finalization actions registered up to the last
+-- 'initFinish', in reverse order.  Either an exception or 'Nothing' can be
+-- passed to 'finish'.  The argument passed is made available in the 'onFinish'
+-- actions invoked.
+--
+finish :: Maybe SomeException -> TransIO a
+finish reason= back (FinishReason reason)
+
+
+
+-- | trigger finish when the stream of data ends
+checkFinalize v=
+   case v of
+      SDone ->  stop
+      SLast x ->  return x
+      SError e -> back  e
+      SMore x -> return x
+
+------ exceptions ---
+--
+-- | Install an exception handler.  On exception, currently installed handlers
+-- are executed in reverse (i.e. last in first out) order. Note that multiple
+-- handlers can be installed for the same exception type.
+--
+onException :: Exception e => (e -> TransIO ()) -> TransIO ()
+onException exc= return () `onException'` exc
+
+
+onException' :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a
+onException' mx f= onAnyException mx $ \e ->
+    case fromException e of
+       Nothing -> empty
+       Just e'  -> f e'
+  where
+  onAnyException :: TransIO a -> (SomeException ->TransIO a) -> TransIO a
+  onAnyException mx f=  mx `onBack` f
+
+-- | Delete all the exception handlers registered till now.
+cutExceptions= backCut (undefined :: SomeException)
+
+-- | Used inside an exception handler. Stop executing any further exception
+-- handlers and resume normal execution from this point on.
+--
 continue = forward (undefined :: SomeException)
 
 

@@ -2,23 +2,47 @@ --
 -- Module      :  Transient.Logged
 -- Copyright   :
--- License     :  GPL-3
+-- License     :  MIT
 --
 -- Maintainer  :  agocorona@gmail.com
 -- Stability   :
 -- Portability :
 --
--- |
+-- | The 'logged' primitive is used to save the results of the subcomputations
+-- of a transient computation (including all its threads) in a log buffer. At
+-- any point, a 'suspend' or 'checkpoint' can be used to save the accumulated
+-- log on a persistent storage. A 'restore' reads the saved logs and resumes
+-- the computation from the saved checkpoint. On resumption, the saved results
+-- are used for the computations which have already been performed. The log
+-- contains purely application level state, and is therefore independent of the
+-- underlying machine architecture. The saved logs can be sent across the wire
+-- to another machine and the computation can then be resumed on that machine.
+-- We can also save the log to gather diagnostic information, especially in
+-- 'finish' blocks.
 --
+-- The following example illustrates the APIs. In its first run 'suspend' saves
+-- the state in a directory named @logs@ and exits, in the second run it
+-- resumes from that point and then stops at the 'checkpoint', in the third run
+-- it resumes from the checkpoint and then finishes.
+--
+-- @
+-- main= keep $ restore  $ do
+--      r <- logged $ choose [1..10 :: Int]
+--      logged $ liftIO $ print (\"A",r)
+--      suspend ()
+--      logged $ liftIO $ print (\"B",r)
+--      checkpoint
+--      liftIO $ print (\"C",r)
+-- @
 -----------------------------------------------------------------------------
 {-# LANGUAGE  CPP,ExistentialQuantification, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}
 module Transient.Logged(
+Loggable, logged, received, param
 
 #ifndef ghcjs_HOST_OS
-restore,checkpoint,suspend,
+, suspend, checkpoint, restore
 #endif
-
-logged, received,param, Loggable) where
+) where
 
 import Data.Typeable
 import Unsafe.Coerce
@@ -43,24 +67,10 @@ #ifndef ghcjs_HOST_OS
 logs= "logs/"
 
--- re-excutes all the threads whose state has been logged in the "./logs" folder
--- .Each log is removed when it is executed.
---
--- example: this program, if executed three times will first print hello <number> some times
--- but `suspend` will kill the threads and exit it.
-
--- The second time, it will print "world" <number> and "world22222" <number> and will stay.
---
--- The third time that it is executed, it only present "world22222" <number> messages
+-- | Reads the saved logs from the @logs@ subdirectory of the current
+-- directory, restores the state of the computation from the logs, and runs the
+-- computation.  The log files are removed after the state has been restored.
 --
--- > main= keep $ restore  $ do
--- >    r <- logged $ choose [1..10 :: Int]
--- >    logged $ liftIO $ print ("hello",r)
--- >    suspend ()
--- >    logged $ liftIO $ print ("world",r)
--- >    checkpoint
--- >    logged $ liftIO $ print ("world22222",r)
-
 restore :: TransIO a -> TransIO a
 restore   proc= do
      liftIO $ createDirectory logs  `catch` (\(e :: SomeException) -> return ())
@@ -84,11 +94,13 @@ 
 
 
--- | save the state of  the thread that execute it and exit the transient block initiated with `keep` or similar
--- . `keep` will return the value passed by `suspend`.
--- If the process is executed again with `restore` it will reexecute the thread from this point on.
+-- | Saves the logged state of the current computation that has been
+-- accumulated using 'logged', and then 'exit's using the passed parameter as
+-- the exit code. Note that all the computations before a 'suspend' must be
+-- 'logged' to have a consistent log state. The logs are saved in the @logs@
+-- subdirectory of the current directory. Each thread's log is saved in a
+-- separate file.
 --
--- it is useful to insert it in `finish` blocks to gather error information,
 suspend :: Typeable a => a -> TransIO a
 suspend  x= do
    Log recovery _ log <- getData `onNothing` return (Log False [] [])
@@ -96,7 +108,8 @@         logAll  log
         exit x
 
--- | Save the state of every thread at this point. If the process is re-executed with `restore` it will reexecute the thread from this point on..
+-- | Saves the accumulated logs of the current computation, like 'suspend', but
+-- does not exit.
 checkpoint ::  TransIO ()
 checkpoint = do
    Log recovery _ log <- getData `onNothing` return (Log False [] [])
@@ -122,24 +135,14 @@ 
 
 
--- | write the result of the computation in  the log and return it.
--- but if there is data in the internal log, it read the data from the log and
--- do not execute the computation.
---
--- It accept nested step's. The effect is that if the outer step is executed completely
--- the log of the inner steps are erased. If it is not the case, the inner steps are logged
--- this reduce the log of large computations to the minimum. That is a feature not present
--- in the package Workflow.
---
--- >  r <- logged $ do
--- >          logged this :: TransIO ()
--- >          logged that :: TransIO ()
--- >          logged thatOther
--- >  liftIO $ print r
---
---  when `print` is executed, the log is just the value of r.
+-- | Run the computation, write its result in a log in the parent computation
+-- and return the result. If the log already contains the result of this
+-- computation ('restore'd from previous saved state) then that result is used
+-- instead of running the computation again.
 --
---  but at the `thatOther` execution the log is: [Exec,(), ()]
+-- 'logged' can be used for computations inside a 'logged' computation. Once
+-- the parent computation is finished its internal (subcomputation) logs are
+-- discarded.
 --
 logged :: Loggable a => TransientIO a -> TransientIO a
 logged mx =  Transient $ do

@@ -1,46 +1,41 @@ name: transient
-
-
-version: 0.5.4
-
-
+version: 0.5.5
 author: Alberto G. Corona
-
 extra-source-files:
     ChangeLog.md README.md
-
 maintainer: agocorona@gmail.com
-
 cabal-version: >=1.10
-
 build-type: Simple
-
 license: MIT
 license-file: LICENSE
-
 homepage: http://www.fpcomplete.com/user/agocorona
 bug-reports: https://github.com/agocorona/transient/issues
-
 synopsis: composing programs with multithreading, events and distributed computing
 description: See <http://github.com/agocorona/transient>
-             In this release distributed primitives have been moved to the transient-universe package, and web primitives have been moved to the ghcjs-hplay package.
-category: Control
-
+             Distributed primitives are in the transient-universe package. Web primitives are in the axiom package.
+category: Control, Concurrency
 data-dir: ""
 
+flag debug
+  description:  Enable debugging outputs
+  default:      False
+  manual:       True
 
 library
-    build-depends:     base          > 4  &&  < 5
-                     , containers
+    -- Note: `stack sdist/upload` will add missing bounds (via "pvp-bounds: both") in `build-depends`
+    -- support GHC 7.10.3 and later; lower bounds below denote GHC 7.10.3's bundled versions
+    build-depends:     base          >= 4.8.1  &&  < 5
+                     , containers    >= 0.5.6
+                     , transformers  >= 0.4.2
+                     , time          >= 1.5
+                     , directory     >= 1.2.2
+                     , bytestring    >= 0.10.6
+
+                     -- libraries not bundled w/ GHC
                      , mtl
-                     , transformers
                      , stm
-                     , time
-                     , directory
                      , random
-                     , bytestring
 
-
     exposed-modules: Transient.Backtrack
                      Transient.Base
                      Transient.EVars
@@ -53,6 +48,8 @@     exposed: True
     default-language: Haskell2010
     hs-source-dirs: src .
+    if flag(debug)
+       cpp-options: -DDEBUG
 
 source-repository head
     type: git