transient 0.3 → 0.4.0

raw patch · 8 files changed

+374/−214 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Transient/Backtrack.hs +1/−1
• src/Transient/Base.hs +7/−5
• src/Transient/EVars.hs +108/−16
• src/Transient/Indeterminism.hs +2/−2
• src/Transient/Internals.hs +229/−104
• src/Transient/Logged.hs +26/−36
• src/Transient/Stream/Resource.hs +0/−49
• transient.cabal +1/−1

@@ -20,7 +20,7 @@ -- | assures that backtracking will not go further back
 undoCut :: TransientIO ()
 undoCut= Transient $ do
-     delSData $ Backtrack False []
+     delData $ Backtrack False []
      return $ Just ()
 
 -- | the secod parameter will be executed when backtracking

@@ -16,18 +16,20 @@ 
 TransIO(..), TransientIO
 ,keep, keep', stop
-,option, input
+,option, input, exit
 ,async,waitEvents, spawn, parallel
 ,react
 
-,setData,setSData,getData,getSData,delSData
+,setData,getData,getSData,delData
 
 , threads,addThreads, freeThreads, hookedThreads,oneThread, killChilds
 
-, (<**),(<***)
+, (**>), (<**),(<***), (<|)
 
 , StreamData(..)
-,genId)  where
--- /show
+,genId)
+
+where
+
 
 import    Transient.Internals

@@ -2,21 +2,24 @@ module Transient.EVars where
 
 import Transient.Base
-import Transient.Internals(onNothing, EventF)
+import Transient.Internals(runTransState,onNothing, EventF(..), killChildren)
 import qualified Data.Map as M
 import Data.Typeable
 
 import Control.Concurrent
 import Control.Applicative
 import Control.Concurrent.STM
-import Control.Monad.State
+import Control.Monad.IO.Class
+import Control.Exception(SomeException)
+
 import Data.List(nub)
+import Control.Monad.State
 
---newtype EVars= EVars  (IORef (M.Map Int [EventF]))  deriving Typeable
 
-data EVar a= EVar Int  (TChan (StreamData a)) deriving  Typeable
 
+data EVar a= EVar Int (TVar (Int,Int))  (TChan (StreamData a)) deriving  Typeable
 
+
 -- | creates an EVar.
 --
 -- Evars are event vars. `writeEVar` trigger the execution of all the continuations associated to the  `readEVar` of this variable
@@ -36,32 +39,121 @@ -- see https://www.fpcomplete.com/user/agocorona/publish-subscribe-variables-transient-effects-v
 --
 
-newEVar ::  TransientIO (EVar a)
+newEVar ::  TransIO (EVar a)
 newEVar  = Transient $ do
    id <- genId
+   rn <- liftIO $ newTVarIO (0,0)
    ref <-liftIO  newTChanIO
-   return . Just $ EVar id  ref
+   return . Just $ EVar id  rn ref
 
 -- | delete al the subscriptions for an evar.
-delEVar :: EVar a -> TransIO ()
-delEVar (EVar id  ref1)= liftIO $ atomically $ writeTChan  ref1 SDone
+cleanEVar :: EVar a -> TransIO ()
+cleanEVar (EVar id rn ref1)= liftIO $ atomically $ do
+    writeTChan  ref1 SDone
+    writeTVar rn (0,0)
 
 -- | read the EVar. It only succeed when the EVar is being updated
 -- The continuation gets registered to be executed whenever the variable is updated.
--- if readEVar is in any kind of loop, since each continuation is different, this will register
--- again the continuation. The effect is that the continuation will be executed multiple times
--- To avoid multiple registrations, use `unsubscribe`
-readEVar :: EVar a -> TransIO a
-readEVar (EVar id  ref1)= do
-     r <- parallel $ atomically $ readTChan ref1     -- !> "READEVAR"
+--
+-- if readEVar is re-executed in any kind of loop, since each continuation is different, this will register
+-- again. The effect is that the continuation will be executed multiple times
+-- To avoid multiple registrations, use `cleanEVar`
+readEVar (EVar id rn ref1)= do
+     liftIO $ atomically $ readTVar rn >>= \(n,n') -> writeTVar rn $ (n+1,n'+1)
+     r <- parallel $ atomically $ do
+                r <- peekTChan ref1
+----                return ()               !> "peekTChan executed"
+                (n,n') <- readTVar rn  -- !> "readtvar rn"
+--                return ()              !> ("rn",n)
+                if n'> 1 then do
+                           writeTVar rn (n,n'-1)
+                           return r
+                         else do
+                           readTChan ref1
+                           writeTVar rn (n,n)
+                           return r
+
      case r of
         SDone -> empty
         SMore x -> return x
         SLast x -> return x
-        SError e -> error $ show e
+        SError e -> do
+            liftIO . atomically $ readTVar rn >>= \(n,n') -> writeTVar rn $ (n-1,n'-1)
+            error $ "readEVar: "++ show e
 
 -- |  update the EVar and execute all readEVar blocks with "last in-first out" priority
-writeEVar (EVar id  ref1) x= liftIO $ atomically $ writeTChan  ref1 $ SMore x
+--
+writeEVar (EVar id rn ref1) x= liftIO $ atomically $ do
+       writeTChan  ref1 $ SMore x
 
 
+-- | write the EVar and drop all the `readEVar` handlers.
+--
+-- It is like a combination of `writeEVar` and `cleanEVar`
+lastWriteEVar (EVar id rn ref1) x= liftIO $ atomically $ do
+       writeTChan  ref1 $ SLast x
 
+
+-- Finalization
+
+
+type FinishReason= Maybe SomeException
+
+-- | trigger finish when the stream data return SDone
+checkFinalize v=
+           case v of
+              SDone ->  finish Nothing >> stop
+              SLast x ->  return x
+              SError e -> liftIO ( print e) >> finish Nothing >> stop
+              SMore x -> return x
+
+
+
+data Finish= Finish (EVar FinishReason) deriving Typeable
+
+-- | initialize the event variable for finalization.
+-- all the following computations in different threads will share it
+initFinish :: TransIO Finish
+initFinish= do
+      fin <-  newEVar
+      let f = Finish fin
+      setData  f
+      return  f
+
+
+onFinish :: (FinishReason ->TransIO ()) -> TransIO ()
+onFinish  close=  do
+
+                               Finish finish <- getSData <|> initFinish
+                               e <- readEVar finish
+                               close e  -- !!> "CLOSE"
+                               stop
+                         <|>
+                           return ()
+
+
+
+-- | trigger the event, so this closes all the resources
+finish :: FinishReason -> TransIO ()
+finish e= do
+    liftIO $ putStr  "finish: " >> print e
+    Finish finish <- getSData <|> initFinish
+    lastWriteEVar finish e
+
+-- | deregister all the finalization actions.
+-- A initFinish is needed to register actions again
+unFinish= do
+    Finish fin <- getSData
+    cleanEVar fin    -- !!> "DELEVAR"
+   <|> return ()   -- !!> "NOT DELEVAR"
+
+
+killOnFinish comp=   do
+
+   chs <- liftIO $ newTVarIO []
+   onFinish $ const $ do
+
+      liftIO $ killChildren chs   -- !> "killOnFinish event"
+   r <- comp
+   modify $ \ s -> s{children= chs}
+   return r

@@ -98,7 +98,7 @@ -- It works monitoring the solutions found and the number of active threads.
 -- If the first parameter is 0, collect will return all the results
 collect ::  Int -> TransIO a -> TransIO [a]
-collect n = collect' n 0.01 0
+collect n = collect' n 0.1 0
 
 -- | search also between two time intervals. If the first interval has passed and there is no result,
 --it stops.
@@ -131,7 +131,7 @@ 
           th <- liftIO $ myThreadId   -- !> "KILL"
           stnow <-  get
-          liftIO $ killChildren st
+          liftIO . killChildren $ children st
           liftIO $ hangThread st stnow
           return  xs
 

@@ -39,11 +39,11 @@ import           Data.List
 import           Data.IORef
 import           System.Environment
-
-{-# INLINE (!>) #-}
-(!>) :: Show a => b -> a -> b
-(!>) x y=   trace (show y) x
-infixr 0 !>
+import           System.IO (hFlush,stdout)
+--{-# INLINE (!>) #-}
+--(!>) :: Show a => b -> a -> b
+--(!>) x y=   trace (show y) x
+--infixr 0 !>
 
 
 data TransIO  x = Transient  {runTrans :: StateT EventF IO (Maybe x)}
@@ -85,10 +85,10 @@       put s'
       return $ Just a
 
-type StateIO= StateT EventF  IO
-
+type StateIO= StateT EventF IO
 
 
+-- | run the transient computation with a blank state
 runTransient :: TransIO x -> IO (Maybe x, EventF)
 runTransient t= do
   th <- myThreadId
@@ -98,19 +98,22 @@ 
   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 context
+-- | 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)
+      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
@@ -160,6 +163,9 @@      x <- mx
      return $ f x
 
+-- to set the identifier number...
+newtype IDNUM = IDNUM Int deriving Show
+
 instance Applicative TransIO where
   pure a  = Transient . return $ Just a
 
@@ -167,7 +173,6 @@          rf <- liftIO $ newIORef (Nothing,[])
          rg <- liftIO $ newIORef (Nothing,[])   -- !> "NEWIOREF"
 
-
          fs  <- getContinuations
 
          let
@@ -177,18 +182,17 @@ 
              appf k = Transient $  do
                    Log rec _ full <- getData `onNothing` return (Log False [] [])
-                   liftIO $ writeIORef rf  (Just k,full)
+                   liftIO $ writeIORef rf  (Just k,full)       --  !> "APPF"
                    (x, full2)<- liftIO $ readIORef rg
                    when (hasWait full2) $
                         let full'= head full2: full
                         in setData $ Log rec full' full'
 
-
                    return $ Just k <*> x
 
              appg x = Transient $  do
                    Log rec _ full <- getData `onNothing` return (Log False [] [])
-                   liftIO $ writeIORef rg $ (Just x, full)
+                   liftIO $ writeIORef rg (Just x, full)       -- !> "APPG"
                    (k,full1) <- liftIO $ readIORef rf
                    when (hasWait  full) $
                         let full'= head full: full1
@@ -200,11 +204,13 @@ 
          k <- runTrans f    -- !> "RUN f"
          was <- getData `onNothing` return NoRemote
-         when (was == WasParallel) $  setData NoRemote                                    -- !>  ("was=",was)
+         when (was == WasParallel) $  setData NoRemote
 
          Log recovery _ full <- getData `onNothing` return (Log False [] [])
 
-         if was== WasRemote  || (not recovery && was == NoRemote  && isNothing k)
+
+
+         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
@@ -215,9 +221,11 @@            else do
              liftIO $ writeIORef rf  (k,full)
 
-             mfdata <- gets mfData
-             seq <- gets mfSequence
 
+--             mfdata <- gets mfData
+             n <- gets mfSequence
+             setData $ IDNUM n
+
              setContinuation g appg fs
 
              x <- runTrans g             --  !> "RUN g"
@@ -230,8 +238,17 @@        modify $ \(EventF eff _ f _ a b c d parent children g1) ->
                EventF eff Nothing f fs a b c d parent children g1
 
+readWithErr line=
+     let [(v,left)] = readsPrec 0 line
+     in (v   `seq` return [(v,left)])
+                    `catch` (\(e::SomeException) ->
+                      error ("read error of " ++ show( typeOf v) ++ " in: "++ line))
 
 
+readsPrec' _= unsafePerformIO . readWithErr
+
+
+
 -- | dynamic serializable data for logging
 data IDynamic= IDyns String | forall a.(Read a, Show a,Typeable a) => IDynamic a
 
@@ -240,7 +257,7 @@   show (IDyns s)= show s
 
 instance Read IDynamic where
-  readsPrec n str= map (\(x,s) -> (IDyns x,s)) $ readsPrec n str
+  readsPrec n str= map (\(x,s) -> (IDyns x,s)) $ readsPrec' n str
 
 
 type Recover= Bool
@@ -254,13 +271,7 @@   empty = Transient $ return  Nothing
   (<|>) = mplus
 
---  Transient f <|> Transient g= Transient $ do
---         k <-   f
---         x <-   g
---         return $ k <|> x
 
-
-
 data RemoteStatus=   WasRemote | WasParallel | NoRemote deriving (Typeable, Eq, Show)
 
 instance MonadPlus TransIO where
@@ -268,22 +279,33 @@     mplus  x y=  Transient $ do
          mx <- runTrans x                -- !!> "RUNTRANS11111"
          was <- getData `onNothing` return NoRemote
-         if was== WasRemote              -- !!> "check wasremote"
-           then return Nothing           --  !> was
-           else case mx of
-             Nothing -> runTrans y      --  !!> "RUNTRANS22222"
-             justx -> return justx
+         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
-stop :: Alternative m => m a
+-- computation and execute the next alternative computation (composed with `<|>`)
+stop :: Alternative m => m stop
 stop= empty
 
-infixr 1  <**  ,  <***
 
--- | forces the execution of the second operand even if the first stop. Return the first result (experimental)
-(<**) :: TransIO a -> TransIO b -> TransIO a
-(<**) ma mb= Transient $ do
+-- | 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.
+(**>) :: TransIO a -> TransIO b -> TransIO b
+(**>) x y=  Transient $ do
+          runTrans x
+          runTrans y
+
+infixr 1  <***  ,  <**, **>
+
+-- | 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
+(<***) :: TransIO a -> TransIO b -> TransIO a
+(<***) ma mb= Transient $ do
               fs  <- getContinuations
               setContinuation ma (\x -> mb >> return x)  fs
               a <- runTrans ma
@@ -291,20 +313,47 @@               restoreStack fs
               return  a
 
-atEnd= (<**)
+atEnd= (<***)
 
--- | forces the execution of the second operand  if the first fails only if the first operand
--- is executed normally, that is , it is not a reexecution consequence of an internal event on it.
+-- | 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
-(<***) :: TransIO a -> TransIO b -> TransIO a
-(<***) ma mb= Transient $ do
+(<**) :: TransIO a -> TransIO b -> TransIO a
+(<**) ma mb= Transient $ do
               a <- runTrans ma    -- !> "ma"
               runTrans  mb        -- !> "mb"
               return a
 
 
-atEnd' = (<***)
+atEnd' = (<**)
 
+
+
+-- | 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
@@ -344,7 +393,7 @@ 
 instance Monad TransIO where
 
-      return x = Transient $ return $ Just x
+      return  = pure
 
       x >>= f  = Transient $ do
 --            effects <- gets effects -- liftIO $ readIORef refEventCont
@@ -377,9 +426,9 @@    modify $ \s -> s{maxThread = msem} -- restore it
    return r
 
--- | delete all the previous childs generated by the expressions and continue execution
+-- | delete all the previous childs generated by the expression taken as parameter and continue execution
 -- of the current thread.
-oneThread :: TransientIO a -> TransientIO a
+oneThread :: TransIO a -> TransientIO a
 oneThread comp=  do
    chs <- liftIO $ newTVarIO []
    r <-  comp
@@ -387,8 +436,27 @@    killChilds
    return r
 
+showThreads :: TransIO empty
+showThreads= do
+   st' <- gets (fromJust . parent)
+   liftIO $ showTree 0 st'
+   stop
+   where
+   toplevel st =
+      case parent st of
+        Nothing ->  st
+        Just p -> toplevel p
 
+   showThreads' n rchs= do
+      chs <- atomically $ readTVar rchs
+      mapM_ (showTree n) chs
 
+   showTree n ch=  do
+         putStr $ take n $ repeat  ' '
+         print $ threadId ch
+         showThreads' (n+4) $ children ch
+
+
 -- | add n threads to the limit of threads. If there is no limit, it set it
 addThreads' :: Int -> TransIO ()
 addThreads' n= Transient $ do
@@ -415,7 +483,7 @@ --    Nothing -> return Nothing
 
 
--- | The threads generated in the process passed as parameter will not be killed.
+-- | The threads generated in the process passed as parameter will not be killed by `kill*` primitives
 freeThreads :: TransIO a -> TransIO a
 freeThreads proc= Transient $ do
      st <- get
@@ -434,11 +502,11 @@      modify $ \st -> st{freeTh= freeTh st}
      return r
 
--- | kill all the child processes
+-- | kill all the child threads of the current thread
 killChilds :: TransientIO()
 killChilds= Transient $  do
    cont <- get
-   liftIO $  killChildren cont
+   liftIO $  killChildren $ children cont
    return $ Just ()
 
 -- * extensible state: session data management
@@ -463,6 +531,14 @@ --
 -- >  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
 
@@ -476,16 +552,13 @@ setData  x=
   let t= typeOf x in  modify $ \st -> st{mfData= M.insert  t (unsafeCoerce x) (mfData st)}
 
--- | a shorter name for setData
-setSData ::  (MonadState EventF m, Typeable a) => a -> m ()
-setSData = setData
 
-delSessionData x=
+delData :: ( MonadState EventF m,Typeable a) => a -> m ()
+delData x=
   modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
 
-delSData :: ( MonadState EventF m,Typeable a) => a -> m ()
-delSData= delSessionData
 
+
 --withSData ::  ( MonadState EventF m,Typeable a) => (Maybe a -> a) -> m ()
 --withSData f= modify $ \st -> st{mfData=
 --    let dat = mfData st
@@ -528,31 +601,41 @@ -- previous events
 waitEvents ::   IO b -> TransIO b
 waitEvents io= do
-   SMore r <- parallel (SMore <$> io)
-   return r
+   mr <- parallel (SMore <$> io)
+   case mr of
+     SMore x -> return x
+     SError e -> throw e
 
+
 -- Multithreaded version of `waitEvents` that do not kill the computations spawned by previous events
 waitEvents' ::   IO b -> TransIO b
 waitEvents' io= do
-   SMore r <- parallel (SMore <$> io)
-   return r
+   mr <- parallel (SMore <$> io)
+   case mr of
+     SMore x -> return x
+     SError e -> throw e
 
 -- | variant of `parallel` that execute the IO computation once, and kill the previous child threads
 async  ::  IO b -> TransIO b
 async io= do
-   SLast r <- parallel  (SLast <$>io)
-   return r
+   mr <- parallel  (SLast <$>io)
+   case mr of
+     SLast x -> return x
+     SError e -> throw e
 
 -- | variant that spawn free threads. Since there is no thread control, this is faster
 spawn ::  IO b -> TransIO b
 spawn io= freeThreads $ do
-   SMore r <- parallel (SMore <$>io)
-   return r
+   mr <- parallel (SMore <$>io)
+   case mr of
+     SMore x -> return x
+     SError e -> throw e
 
 
 
 
 
+
 -- |  return empty to the current thread, in new thread, execute the IO action,
 -- this IO action modify an internal buffer. then, executes the closure where `parallel` is located
 -- In this new execution, since the buffer is filled, `parallel` return the content of this buffer.
@@ -577,7 +660,9 @@         return $ unsafeCoerce j
      Nothing -> do
         liftIO $ loop cont ioaction
-        setData WasParallel
+        was <- getData `onNothing` return NoRemote
+        when (was /= WasRemote) $ setData WasParallel
+
         return Nothing
 
 
@@ -595,7 +680,7 @@ 
       -- execute the IO computation and then the closure-continuation
       loop'= forkMaybe False cont $ do
-         mdat <- threadDelay 0 >> rec
+         mdat <- threadDelay 0 >> rec `catch` \(e :: SomeException) -> return $ SError e
          case mdat of
              se@(SError _) ->  iocont se
              SDone ->          iocont SDone
@@ -604,7 +689,6 @@              more@(SMore _) -> do
                   forkMaybe False cont $ iocont more
                   loop'
-
   loop'
   return ()
   where
@@ -628,9 +712,9 @@                          case me of -- !> "THREAD END" of
                           Left  e -> do
                              when (fromException e /= Just ThreadKilled)$ liftIO $ print e
-                             killChildren  cont  -- !!> "KILL RECEIVED" ++ (show $ unsafePerformIO myThreadId)
+                             killChildren $ children cont          -- !> "KILL RECEIVED" ++ (show $ unsafePerformIO myThreadId)
 
-                          Right _ ->  when(not $ freeTh cont') $ do -- if was not a free thread
+                          Right _ ->  when(not $ freeTh cont')  $ do -- if was not a free thread
                              --  if parent is alive
                              --  then remove himself from the parent list (with free)
                              --  and pass his active children to his parent
@@ -638,7 +722,7 @@                              th <- myThreadId
                              mparent <- free th cont
                              return ()
-
+                               -- pass the active children to the parent
 --                             case mparent of
 --                              Nothing  ->  return()
 --                              Just parent -> atomically $ do
@@ -659,8 +743,7 @@ 
 forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
 forkFinally1 action and_then =
-  mask $ \restore ->
-    forkIO $ try (restore action) >>= and_then
+  mask $ \restore ->  forkIO $ try (restore action) >>= and_then
 
 free th env= do
   if isNothing $ parent env
@@ -692,10 +775,9 @@        writeTVar headpths $  child:ths   -- !!>  "thread added: "++ show (threadId child)
 
 -- | kill  all the child threads associated with the continuation context
-killChildren cont  = do
+killChildren childs  = do
 
      forkIO $ do
-        let childs= children cont
         ths <- atomically $ do
            ths <- readTVar childs
            writeTVar childs []
@@ -711,12 +793,15 @@ type EventSetter eventdata response= (eventdata ->  IO response) -> IO ()
 type ToReturn  response=  IO response
 
--- | deinvert an event handler. The first parameter is the event handler setter to be
+-- | deinvert 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 is the value to return to the event handler
--- it configures the event handler by calling the first parameter, that set the event
--- handler, with the current continuation
+-- 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
   => EventSetter eventdata response
@@ -724,22 +809,37 @@   -> TransIO eventdata
 react setHandler iob= Transient $ do
         cont    <- get
-        mEvData <- getData
-        case mEvData of
+        case event cont of
           Nothing -> do
             liftIO $ setHandler $ \dat ->do
-              runStateT (setData dat >> runCont cont) cont
+              runStateT (runCont cont) cont{event= Just $ unsafeCoerce dat}
               iob
-            setSData WasParallel
+            was <- getData `onNothing` return NoRemote
+            when (was /= WasRemote) $ setData WasParallel
             return Nothing
-          Just dat -> do
-             delSessionData dat
-             return (Just  dat)
 
+          j@(Just _) -> do
+            put cont{event=Nothing}
+            return $ unsafeCoerce j
 
+--          Just dat -> do
+--             delData dat
+--             return (Just  dat)
 
 
+--    case event cont of
+--     Nothing -> do
+--        liftIO $ loop cont ioaction
+--        was <- getData `onNothing` return NoRemote
+--        when (was /= WasRemote) $ setData WasParallel
+--
+--        return Nothing
+--     j@(Just _) -> do
+--        put cont{event=Nothing}
+--        return $ unsafeCoerce j
 
+
+
 -- * non-blocking keyboard input
 
 getLineRef= unsafePerformIO $ newTVarIO Nothing
@@ -763,8 +863,10 @@ -- | 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) => (a -> Bool) -> TransIO a
-input cond= Transient . liftIO . atomically $ do
+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 -> retry
@@ -772,6 +874,7 @@             case reads1 r  of
             (s,_):_ -> if cond s  --  !> show (cond s)
                      then do
+                       unsafeIOToSTM $ print s
                        writeTVar  getLineRef Nothing -- !>"match"
                        return $ Just s
 
@@ -795,12 +898,12 @@             _ -> retry
 
 reads1 s=x where
-      x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec 0 s
+      x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec' 0 s
       typeOfr :: [(a,String)] ->  a
       typeOfr  = undefined
 
 inputLoop=  do
-    putStrLn "Press end to exit"
+--    putStrLn "Press end to exit"
     inputLoop'  -- !> "started inputLoop"
     where
 
@@ -812,20 +915,27 @@ processLine r= do
 --   when (r=="end") $ atomically $ writeTVar rexit ()
    let rs = breakSlash [] r
-   mapM_ (\ r -> if (r=="end") then exit' $ Left "terminated by user" else do
-                    threadDelay 1000
-                    atomically . writeTVar  getLineRef $ Just r) rs
+   mapM_ (\ r ->  -- if (r=="end") then exit' $ Left "terminated by user" else
+                 do
+                    threadDelay 100000
+                    atomically . 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
-      where
-      tail1 []=[]
-      tail1 x= tail x
 
+    tail1 []=[]
+    tail1 x= tail x
+
 {-# NOINLINE rexit #-}
 rexit= unsafePerformIO $ newEmptyMVar
 
@@ -837,21 +947,36 @@       Right (Just r) -> return r
       Left msg -> error msg
 
--- | keep the main thread running, initiate the asynchronous keyboard input and execute
--- the transient computation. It also read a slash separated list of string that are interpreted by
+-- | 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 :: TransIO a -> IO a
 keep mx = do
-   forkIO inputLoop
    forkIO $ do
-           runTransient $  mx >> liftIO (putMVar rexit  $ Right Nothing) -- to avoid takeMVar in a infinite loop
+           liftIO $ putMVar rexit  $ Right Nothing
+           runTransient $ do
+               (async inputLoop
+                       <|> (option "end" "exit" >> exit' (Left "terminated by user"))
+                       <|> return ())
+
+
+               mx
+               liftIO (putMVar rexit  $ Right Nothing) -- to avoid "takeMVar blocked in a infinite loop" error
            return ()
-   threadDelay 100000
+   threadDelay 10000
    args <- getArgs
-   let path = filter (\arg -> arg !! 0 == '/') args
-   when (not (null path)) $ do
-        putStr "Executing: " >> print (head path)
-        processLine $  head path
+   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
    stay
 
 -- | same than `keep`but do not initiate the asynchronous keyboard input.

@@ -17,19 +17,19 @@ import Data.Typeable
 import Unsafe.Coerce
 import Transient.Base
-import Transient.Internals(onNothing,IDynamic(..),Log(..),LogElem(..),RemoteStatus(..))
+import Transient.Internals(onNothing,IDynamic(..),Log(..),LogElem(..),RemoteStatus(..),StateIO)
 import Control.Applicative
 import Control.Monad.IO.Class
-
+import Data.IORef
 
 
 class (Show a, Read a,Typeable a) => Loggable a
 instance (Show a, Read a,Typeable a) => Loggable a
 
 fromIDyn :: (Read a, Show a, Typeable a) => IDynamic -> a
-fromIDyn (IDynamic x)= unsafeCoerce x
+fromIDyn (IDynamic x)=r where r= unsafeCoerce x     -- !> "coerce" ++ " to type "++ show (typeOf r)
 
-fromIDyn (IDyns s)=r where r= read s  -- !!> "read " ++ s ++ "to type "++ show (typeOf r)
+fromIDyn (IDyns s)=r `seq`r where r= read s         -- !> "read " ++ s ++ " to type "++ show (typeOf r)
 
 toIDyn x= IDynamic x
 
@@ -62,53 +62,43 @@ logged mx =  Transient $ do
    Log recover rs full <- getData `onNothing` return ( Log False  [][])
    runTrans $
-    case (recover,rs) of
-      (True, Var x: rs') -> do setSData $ Log True rs' full
-                               return $ fromIDyn x              -- !!>  "read in Var:" ++ show x
+    case (recover ,rs) of        -- !> ("logged enter",recover,rs) of
+      (True, Var x: rs') -> do
+            setData $ Log True rs' full
+            return $ fromIDyn x
+--                                   !> ("read in Var:", x)
 
       (True, Exec:rs') -> do
-            setSData $ Log True  rs' full
-            mx                                 -- !!> "Var True Exec"
+            setData $ Log True  rs' full
+            mx                                  -- !> "Exec"
 
       (True, Wait:rs') -> do
-            setSData (Log True  rs' full)      -- !!> "Wait"
+            setData (Log True  rs' full)        -- !> "Wait"
             empty
 
       _ -> do
-            let add= Exec: full
-            setSData $ Log False add add
+--            let add= Exec: full
+            setData $ Log False (Exec : rs) (Exec: full)     -- !> ("setLog False", Exec:rs)
 
-            r <-  mx <*** ( do  -- when   p1 <|> p2, to avoid the re-execution of p1 at the
+            r <-  mx <** ( do  -- when   p1 <|> p2, to avoid the re-execution of p1 at the
                                 -- recovery when p1 is asynchronous
                             r <- getSData <|> return NoRemote
                             case r of
                                       WasParallel ->
-                                         let add= Wait: full
-                                         in setSData $ Log False add add
+--                                         let add= Wait: full
+                                           setData $ Log False (Wait: rs) (Wait: full)
                                       _ -> return ())
 
-
-            let add= Var (toIDyn r): full
-            (setSData $ Log False add add)     -- !!> "AFTER Var"
+            Log recoverAfter lognew _ <- getData `onNothing` return ( Log False  [][])
+            let add= Var (toIDyn r):  full
+            if recoverAfter && (not $ null lognew)      -- !> ("recoverAfter", recoverAfter)
+              then  (setData $ Log True lognew (reverse lognew ++ add) )
+                                                        -- !> ("recover",reverse lognew ,add)
+              else if recoverAfter && (null lognew) then
+                   setData $ Log False [] add
+              else
+                  (setData $ Log False (Var (toIDyn r):rs) add)  -- !> ("restore", (Var (toIDyn r):rs))
             return  r
 
-
-
-
-
-
-
---step :: (Show a, Read a, Typeable a) => TransientIO a -> TransientIO a
---step mx = step' mx $ \full mx -> do
---            let add= Exec: full
---            setSData $ Log False add add
---
---            r <-  mx
---
---            let add= Step (toIDyn r): full
---            (setSData $ Log False add add)     -- !!> "AFTER STEP"
---            return  r
---
---
 
 

@@ -74,52 +74,3 @@        v <- proc h  some
        liftIO $ myThreadId >>= print
        checkFinalize v
-
-type FinishReason= Maybe SomeException
-
-checkFinalize v=
-           case v of
-              SDone ->  finish Nothing >> stop
-              SLast x ->  finish Nothing >> return x
-              SError e -> liftIO ( print e) >> finish Nothing >> stop
-              SMore x -> return x
-
-
-
-data Finish= Finish (EVar FinishReason) deriving Typeable
-
--- | initialize the event variable for finalization.
--- all the following computations will share it
-initFinish :: TransIO Finish
-initFinish= do
-      fin <-  newEVar
-      let f = Finish fin
-      setSData  f
-      return  f
-
-
--- | suscribe a computation to be called when the finish event is triggered
-onFinish :: (FinishReason ->TransIO ()) -> TransIO ()
-onFinish  close= do
-       Finish finish <- getSData <|> initFinish
-
-       e <- readEVar finish
---       unsubscribe finish
-       close e  -- !!> "CLOSE"
-       stop
-     <|> return()
-
--- | trigger the event, so this closes all the resources
-finish :: FinishReason -> TransIO ()
-finish e= do
-    liftIO $ putStrLn "finish Called"
-    Finish finish <- getSData
-    writeEVar finish e
-
--- | deregister all the finalization actions.
--- A initFinish is needed to register actions again
-unFinish= do
-    Finish fin <- getSData
-    delEVar fin    -- !!> "DELEVAR"
-   <|> return ()   -- !!> "NOT DELEVAR"
-

@@ -1,6 +1,6 @@ name: transient
 
-version: 0.3
+version: 0.4.0
 cabal-version: >=1.10
 build-type: Simple
 license: MIT