diff --git a/src/Transient/Internals.hs b/src/Transient/Internals.hs --- a/src/Transient/Internals.hs +++ b/src/Transient/Internals.hs @@ -987,7 +987,7 @@ $ \me -> do case me of - Left e -> exceptBack cont e >> return () + Left e -> exceptBack cont e >> return () !> "exceptBack 2" @@ -1243,7 +1243,7 @@ -- | 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 +-- The main thread provides facilities for accepting 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 @@ -1259,7 +1259,7 @@ -- 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 +-- All available options waiting for input are displayed when the -- program is run. The following commands are available: -- -- 1. @ps@: show threads @@ -1330,7 +1330,7 @@ setData $ Exit rexit mx - return () + return () threadDelay 10000 forkIO $ execCommandLine stay rexit @@ -1398,7 +1398,7 @@ {-# NOINLINE onBack #-} onBack :: (Typeable b, Show b) => TransientIO a -> ( b -> TransientIO a) -> TransientIO a onBack ac bac = registerBack (typeof bac) $ Transient $ do - Backtrack mreason stack <- getData `onNothing` backStateOf (typeof bac) + Backtrack mreason stack <- getData `onNothing` (return $ backStateOf (typeof bac)) runTrans $ case mreason of Nothing -> ac Just reason -> do @@ -1421,18 +1421,18 @@ {-# 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) + cont@(EventF _ x _ _ _ _ _ _ _ _ _) <- get + -- if isJust (event cont) then return Nothing else do + md <- getData `asTypeOf` (Just <$> return (backStateOf witness)) case md of Just (Backtrack b []) -> setData $ Backtrack b [cont] 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) - setData $ Backtrack b (cont:bs) + when (isNothing b) $ do + addrx <- addr x + addrx' <- addr x' -- to avoid duplicate backtracking points + setData $ if addrx == addrx' then bss else Backtrack b (cont:bs) + --setData $ Backtrack b (cont:bs) Nothing -> setData $ Backtrack mwit [cont] @@ -1454,7 +1454,7 @@ -- forward :: (Typeable b, Show b) => b -> TransIO () forward reason= Transient $ do - Backtrack _ stack <- getData `onNothing` (backStateOf reason) + Backtrack _ stack <- getData `onNothing` ( return $ backStateOf reason) setData $ Backtrack(Nothing `asTypeOf` Just reason) stack return $ Just () @@ -1474,31 +1474,31 @@ -- back :: (Typeable b, Show b) => b -> TransientIO a back reason = Transient $ do - bs <- getData `onNothing` backStateOf reason - goBackt bs -- !!>"GOBACK" + bs <- getData `onNothing` return (backStateOf reason) + goBackt bs !>"GOBACK" where - goBackt (Backtrack _ [] )= return Nothing -- !!> "END" + goBackt (Backtrack _ [] )= return Nothing goBackt (Backtrack b (stack@(first : bs)) )= do setData $ Backtrack (Just reason) stack - mr <- runClosure first -- !> ("RUNCLOSURE",length stack) + mr <- runClosure first -- !> ("RUNCLOSURE",length stack) - Backtrack back _ <- getData `onNothing` backStateOf reason - -- !> "END RUNCLOSURE" + Backtrack back _ <- getData `onNothing` return (backStateOf reason) + -- !> "END RUNCLOSURE" case mr of - Nothing -> return Nothing -- !> "END EXECUTION" + Nothing -> return Nothing -- !> "END EXECUTION" Just x -> case back of - Nothing -> runContinuation first x -- !> "FORWARD EXEC" + Nothing -> runContinuation first x -- !> "FORWARD EXEC" justreason ->do setData $ Backtrack justreason bs - goBackt $ Backtrack justreason bs - return Nothing -- !> ("BACK AGAIN",back) + goBackt $ Backtrack justreason bs !> ("BACK AGAIN",back) + return Nothing -backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a) -backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) [] +backStateOf :: (Show a, Typeable a) => a -> Backtrack a +backStateOf reason= Backtrack (Nothing `asTypeOf` (Just reason)) [] -- | 'back' for the default undo track; equivalent to @back ()@. -- @@ -1569,15 +1569,16 @@ Just e' -> f e' where onAnyException :: TransIO a -> (SomeException ->TransIO a) -> TransIO a - onAnyException mx f= ioexp `onBack` f + onAnyException mx f= ioexp f `onBack` f - ioexp = Transient $ do + ioexp f = Transient $ do st <- get - (mx,st') <- liftIO $ (runStateT (do + (mx,st') <- liftIO $ (runStateT + (do case event st of Nothing -> do - r <- runTrans mx -- !> "mx" + r <- runTrans mx modify $ \s -> s{event= Just $ unsafeCoerce r} @@ -1591,17 +1592,24 @@ Just r -> do modify $ \s -> s{event=Nothing} return $ unsafeCoerce r) st) - `catch` exceptBack st + `catch` exceptBack st put st' return mx exceptBack st = \(e ::SomeException) -> do -- recursive catch itself - -- return () !> "CATCH" runStateT ( runTrans $ back e ) st - `catch` exceptBack st - + `catch` exceptBack (stex st) - + where + -- drop the current exception handler from the stack + stex st = + let list = mfData st + emptyback=backStateOf(undefined :: SomeException) + Backtrack b stack = case M.lookup (typeOf emptyback) list of + Just x -> unsafeCoerce x + Nothing -> emptyback + + in st { mfData = M.insert (typeOf emptyback) (unsafeCoerce $ Backtrack b $ tail stack) (mfData st) } -- | Delete all the exception handlers registered till now. cutExceptions :: TransIO () @@ -1627,7 +1635,7 @@ return r where sandbox mx= do - exState <- getState <|> backStateOf (undefined :: SomeException) + exState <- getState <|> return (backStateOf (undefined :: SomeException)) mx <*** do setState exState diff --git a/transient.cabal b/transient.cabal --- a/transient.cabal +++ b/transient.cabal @@ -1,5 +1,5 @@ name: transient -version: 0.5.9.1 +version: 0.5.9.2 author: Alberto G. Corona extra-source-files: ChangeLog.md README.md