transient 0.4.2.2 → 0.4.4

raw patch · 7 files changed

+350/−173 lines, 7 filesdep +directorydep +random

Dependencies added: directory, random

Files

src/Transient/Backtrack.hs +124/−43
src/Transient/EVars.hs +64/−64
src/Transient/Indeterminism.hs +16/−21
src/Transient/Internals.hs +61/−37
src/Transient/Logged.hs +79/−4
src/Transient/Stream/Resource.hs +3/−3
transient.cabal +3/−1

src/Transient/Backtrack.hs view

@@ -3,80 +3,161 @@ 
 -- | <https://www.fpcomplete.com/user/agocorona/the-hardworking-programmer-ii-practical-backtracking-to-undo-actions>
 
-module Transient.Backtrack (registerUndo, onUndo, undo, retry, undoCut) where
+module Transient.Backtrack (onUndo, undo, retry, undoCut,registerUndo,
 
+-- * 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,
+
+-- * finalization primitives
+finish, onFinish, onFinish' ,initFinish , noFinish, killOnFinish ,checkFinalize , FinishReason
+) where
+
 import Transient.Base
-import Transient.Internals(EventF(..),onNothing,runClosure,runContinuation)
+import Transient.Internals(EventF(..),killChildren,onNothing,runClosure,runContinuation)
 import Data.Typeable
 import Control.Applicative
 import Control.Monad.State
 import Unsafe.Coerce
 import System.Mem.StableName
+import Control.Exception
+import Control.Concurrent.STM hiding (retry)
+import Data.Maybe
 
-data Backtrack= forall a b.Backtrack{backtracking :: Bool
-                                    ,backStack :: [EventF]}
+data Backtrack b= Show b =>Backtrack{backtracking :: Maybe b
+                                    ,backStack :: [EventF] }
                                     deriving Typeable
 
 -- | assures that backtracking will not go further back
-undoCut :: TransientIO ()
-undoCut= Transient $ do
-     delData $ Backtrack False []
+backCut :: (Typeable reason, Show reason) => reason -> TransientIO ()
+backCut reason= Transient $ do
+     delData $ Backtrack (Just reason)  []
      return $ Just ()
 
--- | the secod parameter will be executed when backtracking
-{-# NOINLINE onUndo #-}
-onUndo :: TransientIO a -> TransientIO a -> TransientIO a
-onUndo ac bac= registerUndo $ Transient $ do
-     Backtrack back _ <- getData `onNothing` return (Backtrack False [])
-     runTrans $ if back then bac  else ac
+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 #-}
-registerUndo :: TransientIO a -> TransientIO a
-registerUndo f  = Transient $ do
+registerBack :: (Typeable b, Show b) => b -> TransientIO a -> TransientIO a
+registerBack witness f  = Transient $ do
    cont@(EventF _ _ x _ _ _ _ _ _ _ _)  <- get   -- !!> "backregister"
-   md  <- getData
-   ss <- case md of
-        Just (bss@(Backtrack b (bs@((EventF _ _ x'  _ _ _ _ _ _ _ _):_)))) -> do
-            addrx  <- addr x
-            addrx' <- addr x'         -- to avoid duplicate backtracking points
-            return $ if addrx == addrx' then bss else  Backtrack b $ cont:bs
-        Nothing ->  return $ Backtrack False [cont]
-   setData ss
+
+   md <- getData `asTypeOf` (Just <$> backStateOf witness)
+
+   case md of
+            Just (bss@(Backtrack b (bs@((EventF _ _ x'  _ _ _ _ _ _ _ _):_)))) ->
+               when (isNothing b) $ do
+                   addrx  <- addr x
+                   addrx' <- addr x'         -- to avoid duplicate backtracking points
+                   setData $ if addrx == addrx' then bss else  Backtrack mwit (cont:bs)
+            Nothing ->  setData $ Backtrack mwit [cont]
+
    runTrans f
    where
+   mwit= Nothing `asTypeOf` (Just witness)
    addr x = liftIO $ return . hashStableName =<< (makeStableName $! x)
 
+
+registerUndo :: TransientIO a -> TransientIO a
+registerUndo f= registerBack ()  f
+
 -- | restart the flow forward from this point on
-retry :: TransIO ()
-retry= Transient $ do
-    Backtrack _ stack <- getData `onNothing` return (Backtrack False [])
-    setData $ Backtrack False stack
+forward :: (Typeable b, Show b) => b -> TransIO ()
+forward reason= Transient $ do
+    Backtrack _ stack <- getData `onNothing`  (backStateOf reason)
+    setData $ Backtrack(Nothing `asTypeOf` Just reason)  stack
     return $ Just ()
 
+retry= forward ()
+
+noFinish= forward (FinishReason Nothing)
+
 -- | execute backtracking. It execute the registered actions in reverse order.
 --
 -- If the backtracking flag is changed the flow proceed  forward from that point on.
 --
---If the backtrack stack is finished or undoCut executed, `undo` will stop.
-undo :: TransientIO a
-undo= Transient $ do
-  bs <- getData  `onNothing` return nullBack            -- !!>"GOBACK"
+-- If the backtrack stack is finished or undoCut executed, `undo` will stop.
+back :: (Typeable b, Show b) => b -> TransientIO a
+back reason = Transient $ do
+  bs <- getData  `onNothing`  backStateOf  reason           -- !!>"GOBACK"
   goBackt  bs
 
   where
-  nullBack= Backtrack False []
-  goBackt (Backtrack _ [])= return Nothing                      -- !!> "END"
-  goBackt (Backtrack b (stack@(first@(EventF _ _ x fs _ _  _ _ _ _ _): bs)))= do
---        put first{replay=True}
-        setData $ Backtrack True stack
-        mr <-  runClosure first                                 -- !!> "RUNCLOSURE"
-        Backtrack back _ <- getData `onNothing` return nullBack
-                                                                -- !!>"END RUNCLOSURE"
+
+  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
-           True ->  goBackt $ Backtrack True bs                 -- !!> "BACK AGAIN"
-           False -> case mr of
-                   Nothing -> return empty                      -- !!> "FORWARD END"
-                   Just x ->  runContinuation first x           -- !!> "FORWARD EXEC"
+           Nothing -> case mr of
+                   Nothing ->  return empty                      -- !> "FORWARD END"
+                   Just x  ->  runContinuation first x           -- !> "FORWARD EXEC"
+           justreason -> goBackt $ Backtrack justreason bs       -- !> ("BACK AGAIN",back)
 
+backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a)
+backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
+
+undo ::  TransIO a
+undo= back ()
+
+------ finalization
+
+newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show)
+
+-- | initialize the event variable for finalization.
+-- all the following computations in different threads will share it
+-- it also isolate this event from other branches that may have his own finish variable
+initFinish= backCut (FinishReason Nothing)
+
+-- | set a computation to be called when the finish event happens
+onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO ()
+onFinish f= onFinish' (return ()) f
+
+
+-- | set a computation to be called when the finish event happens this only apply for
+onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a
+onFinish' proc f= proc `onBack`   \(FinishReason reason) ->
+    f reason
+
+
+-- | trigger the event, so this closes all the resources
+finish :: Maybe SomeException -> TransIO a
+finish reason= back (FinishReason reason)
+
+
+-- | kill all the processes generated by the parameter when finish event occurs
+killOnFinish comp= do
+   chs <- liftIO $ newTVarIO []
+   onFinish $ const $ liftIO $ killChildren chs   -- !> "killOnFinish event"
+   r <- comp
+   modify $ \ s -> s{children= chs}
+   return r
+
+-- | trigger finish when the stream of data ends
+checkFinalize v=
+           case v of
+              SDone ->  finish Nothing >> stop
+              SLast x ->  return x
+              SError e -> liftIO ( print e) >> finish  Nothing >> stop
+              SMore x -> return x

src/Transient/EVars.hs view

@@ -66,8 +66,8 @@         SDone -> empty
         SMore x -> return x
         SLast x -> return x
-        SError e -> error ""
---            error $ "readEVar: "++ show e
+        SError e -> empty
+--              error $ "readEVar: "++ show e
 
 -- |  update the EVar and execute all readEVar blocks with "last in-first out" priority
 --
@@ -82,66 +82,66 @@        writeTChan  ref1 $ SLast x
 
 
--- Finalization
-
-
-type FinishReason= Maybe SomeException
-
-
-
-data Finish= Finish (EVar FinishReason) deriving Typeable
-
--- | 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 :: TransIO Finish
-initFinish= do
-      fin <-  newEVar
-      let f = Finish fin
-      setData  f
-      return  f
-
--- | set a computation to be called when the finish event happens
-onFinish :: (FinishReason ->TransIO ()) -> TransIO ()
-onFinish  close=  do
-       Finish finish <- getSData <|> initFinish
-       e <-  freeThreads $ 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"
-
-
--- | kill all the processes generated by the parameter when finish event occurs
-killOnFinish comp= do
-
-   chs <- liftIO $ newTVarIO []
-   onFinish $ const $ liftIO $ killChildren chs   -- !> "killOnFinish event"
-   r <- comp
-   modify $ \ s -> s{children= chs}
-   return r
-
--- | trigger finish when the stream 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
+---- Finalization
+--
+--
+--type FinishReason= Maybe SomeException
+--
+--
+--
+--data Finish= Finish (EVar FinishReason) deriving Typeable
+--
+---- | 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 :: TransIO Finish
+--initFinish= do
+--      fin <-  newEVar
+--      let f = Finish fin
+--      setData  f
+--      return  f
+--
+---- | set a computation to be called when the finish event happens
+--onFinish :: (FinishReason ->TransIO ()) -> TransIO ()
+--onFinish  close=  do
+--       Finish finish <- getSData <|> initFinish
+--       e <-  freeThreads $ 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"
+--
+--
+---- | kill all the processes generated by the parameter when finish event occurs
+--killOnFinish comp= do
+--
+--   chs <- liftIO $ newTVarIO []
+--   onFinish $ const $ liftIO $ killChildren chs   -- !> "killOnFinish event"
+--   r <- comp
+--   modify $ \ s -> s{children= chs}
+--   return r
+--
+---- | trigger finish when the stream 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

src/Transient/Indeterminism.hs view

@@ -17,7 +17,7 @@ ) where
 
 import Transient.Base
-import Transient.EVars
+import Transient.Backtrack(checkFinalize)
 import Transient.Internals(killChildren, EventF(..),hangThread)
 import Data.IORef
 import Control.Applicative
@@ -41,12 +41,7 @@            case es  of
             [x]  -> x `seq` return $ SLast x
             x:_  -> x `seq` return $ SMore x
-    toData r
-
-toData r= case r of
-      SMore x -> return x
-      SLast x -> return x
-      SError e ->  finish (Just e) >> empty
+    checkFinalize r
 
 
 -- | group the output of a possible multithreaded process in groups of n elements.
@@ -87,8 +82,6 @@ choose' xs = foldl (<|>) empty $ map (async . return) xs
 
 
---newtype Collect a= Collect (MVar (Int, [a])) deriving Typeable
-
 -- collect the results of a search done in parallel, usually initiated by
 -- `choose` .
 --
@@ -106,15 +99,15 @@ -- It also stops as soon as there are enough results specified in the first parameter.
 collect' :: Int -> NominalDiffTime -> NominalDiffTime -> TransIO a -> TransIO [a]
 collect' n t1 t2 search= hookedThreads $  do
-  rv <- liftIO $ atomically $ newTVar (0,[]) -- !> "NEWMVAR"
+  rv <- liftIO $ atomically $ newTVar (0,[])    -- !> "NEWMVAR"
   endflag <- liftIO $ newTVarIO False
-  st <-  get
+  st <-  newPool
   t <- liftIO getCurrentTime
   let worker = do
-        r <- search    -- !> "ANY"
+        r <- search
         liftIO $ atomically $ do
             (n1,rs) <- readTVar rv
-            writeTVar  rv (n1+1,r:rs)  -- !> "MODIFY"
+            writeTVar  rv (n1+1,r:rs)           -- !> "MODIFY"
         stop
 
       monitor=  freeThreads $ do
@@ -126,17 +119,19 @@                                (n > 0 && n' >= n) ||
                                  (null ns && (diffUTCTime t' t > t1))    ||
                                  (t2 > 0 && diffUTCTime t' t > t2)
-                                        -- !>  (diffUTCTime t' t, n', length ns)
+                                         -- !>  (diffUTCTime t' t, n', length ns)
                                then return xs else retry
 
-          th <- liftIO $ myThreadId   -- !> "KILL"
-          stnow <-  get
+
           liftIO . killChildren $ children st
-          liftIO $ hangThread st stnow
+
           return  xs
 
   monitor <|> worker
-
-
-
-
+  where
+  newPool  =  do
+       chs <- liftIO $ newTVarIO []
+       s <- get
+       let s'=  s{children= chs}
+       put s'
+       return s'

src/Transient/Internals.hs view

@@ -41,10 +41,10 @@ import           System.Environment
 import           System.IO (hFlush,stdout)
 import           System.Exit
---{-# INLINE (!>) #-}
---(!>) :: Show a => b -> a -> b
---(!>) x y=   trace (show y) x
---infixr 0 !>
+{-# INLINE (!>) #-}
+(!>) :: Show a => b -> a -> b
+(!>) x y=  trace (show y) x
+infixr 0 !>
 
 
 data TransIO  x = Transient  {runTrans :: StateT EventF IO (Maybe x)}
@@ -140,6 +140,7 @@ runClosure :: EventF -> StateIO (Maybe a)
 runClosure (EventF _ _ x _ _ _ _ _ _ _ _) =  unsafeCoerce $ runTrans x
 
+
 -- | run the continuation (the 'f' in 'x >>= f') of the current bind operation
 runContinuation ::  EventF -> a -> StateIO (Maybe b)
 runContinuation (EventF _ _ _ fs _ _ _ _  _ _ _) =
@@ -259,7 +260,7 @@      let [(v,left)] = readsPrec 0 line
      in (v   `seq` return [(v,left)])
                     `catch` (\(e::SomeException) ->
-                      error ("read error of " ++ show( typeOf v) ++ " in: "++ line))
+                      error ("read error of " ++ show( typeOf v) ++ " in: "++ "\""++line++"\""))
 
 
 readsPrec' _= unsafePerformIO . readWithErr
@@ -465,6 +466,7 @@    killChilds
    return r
 
+
 showThreads :: TransIO empty
 showThreads= do
    st' <- gets (fromJust . parent)
@@ -583,9 +585,7 @@ 
 
 delData :: ( MonadState EventF m,Typeable a) => a -> m ()
-delData x=
-  modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
-
+delData x=  modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}
 
 
 --withSData ::  ( MonadState EventF m,Typeable a) => (Maybe a -> a) -> m ()
@@ -960,14 +960,14 @@     tail1 []=[]
     tail1 x= tail x
 
-{-# NOINLINE rexit #-}
-rexit= unsafePerformIO $ newEmptyMVar
 
+
+
 -- | wait for the execution of `exit` and return the result
-stay=   do
+stay rexit=   do
     mr <- takeMVar rexit
     case mr of
-      Right Nothing -> stay
+      Right Nothing -> stay rexit
       Right (Just r) -> return r
       Left msg -> putStrLn msg >> exitWith ExitSuccess
 
@@ -978,21 +978,50 @@ -- `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
+
+newtype Exit a= Exit a deriving Typeable
+
+keep :: Typeable a => TransIO a -> IO a
 keep mx = do
+   rexit <- newEmptyMVar
    forkIO $ do
-           liftIO $ putMVar rexit  $ Right Nothing
-           runTransient $ do
-               (async inputLoop
-                       <|> (option "end" "exit" >> killChilds >> exit' (Left "terminated by user"))
-                       <|> return ())
+       liftIO $ putMVar rexit  $ Right Nothing
+       runTransient $ do
+           setData $ Exit rexit
+           async inputLoop
+            <|> do mx  -- ; liftIO (putMVar rexit  $ Right Nothing)
+                       -- to avoid "takeMVar blocked in a infinite loop" error
+            <|> do
+               option "end" "exit"
+               killChilds
+               exit' (Left "terminated by user" `asTypeOf`  (type1 mx))
 
 
-               mx
-               liftIO (putMVar rexit  $ Right Nothing) -- to avoid "takeMVar blocked in a infinite loop" error
+       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.
+keep' :: Typeable a => TransIO a -> IO a
+keep' mx  = do
+   rexit <- newEmptyMVar
+   forkIO $ do
+           runTransient $ do
+              setData $ Exit rexit
+              mx >> liftIO (putMVar rexit  $ Right Nothing)
+           -- to avoid takeMVar in a infinite loop
            return ()
    threadDelay 10000
+   execCommandLine
+
+   stay rexit
+
+execCommandLine= do
    args <- getArgs
    let mindex =  findIndex (\o ->  o == "-p" || o == "--path" ) args
    when (isJust mindex) $ do
@@ -1001,28 +1030,23 @@           let path= args !! i
           putStr "Executing: " >> print  path
           processLine  path
-   stay
 
--- | same than `keep`but do not initiate the asynchronous keyboard input.
--- Useful for debugging
-keep' :: TransIO a -> IO a
-keep' mx  = do
-
-   forkIO $ do
-           runTransient $  mx >>   liftIO (putMVar rexit  $ Right Nothing)   -- to avoid takeMVar in a infinite loop
-           return ()
-   threadDelay 100000
-
-   stay
-
 -- | force the finalization of the main thread and thus, all the Transient block (and the application
 -- if there is no more code)
-exit :: a -> TransIO a
+exit :: Typeable a => a -> TransIO a
 exit x= do
-  liftIO $  putMVar rexit .  Right $ Just   x
+  Exit rexit <- getSData <|> error "exit: not the type expected"  `asTypeOf` type1 x
+  liftIO $  putMVar rexit .  Right $ Just x
   stop
+  where
+  type1 :: a -> TransIO (Exit (MVar (Either String (Maybe a))))
+  type1= undefined
 
-exit' x= liftIO $  putMVar rexit  x
+exit' x= do
+  Exit rexit <- getSData <|> error "exit: not type expected"
+  liftIO $  putMVar rexit  x ; stop
+
+
 -- | alternative operator for maybe values. Used  in infix mode
 onNothing :: Monad m => m (Maybe b) -> m b -> m b
 onNothing iox iox'= do

src/Transient/Logged.hs view

@@ -11,20 +11,95 @@ -- |
 --
 -----------------------------------------------------------------------------
-{-# LANGUAGE  ExistentialQuantification, FlexibleInstances, UndecidableInstances #-}
-module Transient.Logged  where
+{-# LANGUAGE  ExistentialQuantification, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-}
+module Transient.Logged(restore,checkpoint,suspend,logged,Loggable) where
 
 import Data.Typeable
 import Unsafe.Coerce
 import Transient.Base
-import Transient.Internals(onNothing,IDynamic(..),Log(..),LogElem(..),RemoteStatus(..),StateIO)
+import Transient.Indeterminism(choose)
+import Transient.Internals(onNothing,reads1,IDynamic(..),Log(..),LogElem(..),RemoteStatus(..),StateIO)
 import Control.Applicative
 import Control.Monad.IO.Class
-import Data.IORef
+import System.Directory
+import Control.Exception
+import Control.Monad
+import System.Random
 
 
 class (Show a, Read a,Typeable a) => Loggable a
 instance (Show a, Read a,Typeable a) => Loggable a
+
+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
+--
+-- > 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 ())
+     list <- liftIO $ getDirectoryContents logs
+                 `catch` (\(e::SomeException) -> return [])
+     if length list== 2 then proc else do
+
+         let list'= filter ((/=) '.' . head) list
+         file <- choose  list'       -- !> list'
+
+         logstr <- liftIO $ readFile (logs++file)
+         let log= length logstr `seq` read' logstr
+
+         log `seq` setData (Log True (reverse log) log)
+         liftIO $ remove $ logs ++ file
+         proc
+     where
+     read'= fst . head . reads1
+
+     remove f=  removeFile f `catch` (\(e::SomeException) -> remove f)
+
+
+
+-- | 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.
+--
+-- 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 [] [])
+   if recovery then return x else do
+        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..
+checkpoint ::  TransIO ()
+checkpoint = do
+   Log recovery _ log <- getData `onNothing` return (Log False [] [])
+   if recovery then return () else logAll log
+
+
+logAll log= do
+        newlogfile <- liftIO $  (logs ++) <$> replicateM 7 (randomRIO ('a','z'))
+        liftIO $ writeFile newlogfile $ show log
+      :: TransIO ()
+
+
+
+
 
 fromIDyn :: (Read a, Show a, Typeable a) => IDynamic -> a
 fromIDyn (IDynamic x)=r where r= unsafeCoerce x     -- !> "coerce" ++ " to type "++ show (typeOf r)

src/Transient/Stream/Resource.hs view

@@ -12,11 +12,11 @@ --
 -----------------------------------------------------------------------------
 {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable  #-}
-module Transient.Stream.Resource(sourceFile, sinkFile, process, initFinish, finish,unFinish, onFinish) where
+module Transient.Stream.Resource(sourceFile, sinkFile, process, initFinish, finish, onFinish) where
 
 
 import Transient.Base hiding (loop)
-import Transient.EVars
+import Transient.Backtrack
 import Control.Exception
 import Control.Applicative
 import Data.Typeable
@@ -61,7 +61,7 @@ process
   :: TransIO a       -- ^ input computation
      -> IO handle    -- ^ open computation that gives resources to be used during the computation
-     -> (handle -> FinishReason -> IO ())   -- ^ close computation that frees the resources
+     -> (handle -> Maybe SomeException -> IO ())   -- ^ close computation that frees the resources
      -> (handle -> a -> TransIO (StreamData b))   -- ^ process to be done
      -> TransIO b
 process input open close proc=do

transient.cabal view

@@ -1,6 +1,6 @@ name: transient
 
-version: 0.4.2.2
+version: 0.4.4
 
 
 author: Alberto G. Corona
@@ -29,6 +29,8 @@                      , transformers
                      , stm
                      , time
+                     , directory
+                     , random
 
     exposed-modules: Transient.Backtrack
                      Transient.Base