-
-
Save ajnsit/d137f760b24c4769138826ec447ce888 to your computer and use it in GitHub Desktop.
Optimized, simplified continuation monad that implement all the Transient effects (except logging and distributed computing), with mockup implementation of some of them (https://github.com/transient-haskell/transient)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} | |
| import Control.Applicative | |
| import Control.Monad.IO.Class | |
| import Control.Monad.Trans | |
| import GHC.Conc | |
| import System.IO.Unsafe | |
| import Data.IORef | |
| import Control.Concurrent.MVar | |
| import qualified Data.Map as M | |
| import Data.Typeable | |
| import qualified Data.ByteString.Char8 as BS | |
| import Control.Monad.State | |
| import Data.Monoid | |
| import Unsafe.Coerce | |
| import System.Mem.StableName | |
| import Control.Exception hiding (onException) | |
| import Debug.Trace | |
| x !> y= trace (show y) x | |
| infixr 0 !> | |
| type SData= () | |
| data LifeCycle = Alive | Parent | Listener | Dead | |
| deriving (Eq, Show) | |
| -- | EventF describes the context of a TransientIO computation: | |
| data EventF = EventF | |
| { 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 coercion is necessary because continuations can only be modeled fully within Indexed monads. | |
| -- See paper P. Wadler "Monads and composable continuations" | |
| -- The symtom of that problem in the typical continaution monad is an extra parameter r that complicates reasoning | |
| -- This monad eliminates the extra parameter by coercing types since, by construction, the contination parameter is of the | |
| -- type of the result of the first term of the bind. | |
| ety :: a -> b | |
| ety= dontWorryEverithingisOk | |
| tdyn :: a -> Dyn | |
| tdyn= dontWorryEverithingisOk | |
| fdyn :: Dyn -> a | |
| fdyn = dontWorryEverithingisOk | |
| dontWorryEverithingisOk= unsafeCoerce | |
| type Dyn= () | |
| data Transient m a = Transient { runTransT :: (Dyn -> m a) -> m a } | |
| type StateIO = StateT EventF IO | |
| type TransIO = Transient StateIO | |
| instance Monad TransIO where | |
| return = pure | |
| m >>= k = Transient $ \c -> ety $ runTransT m (\x -> ety $ runTransT ( k $ fdyn x) c) | |
| instance MonadState EventF TransIO where | |
| get= lift get | |
| put= lift . put | |
| instance MonadTrans (Transient ) where | |
| lift m = Transient ((unsafeCoerce m) >>=) | |
| instance MonadIO TransIO where | |
| liftIO = lift . liftIO | |
| callCC :: ((a -> Transient m b) -> Transient m a) -> Transient m a | |
| callCC f = Transient $ \ c -> runTransT (f (\ x -> Transient $ \ _ -> ety $ c $ tdyn x)) c | |
| instance Functor (Transient m) where | |
| fmap f m = Transient $ \c -> ety $ runTransT m $ \ x-> ety c $ f $ fdyn x | |
| instance Monoid a => Monoid (TransIO a) where | |
| mappend x y = mappend <$> x <*> y | |
| mempty = return mempty | |
| instance Applicative TransIO where | |
| pure a = Transient ($ tdyn a) | |
| --f <*> v = ety $ Transient $ \ k -> ety $ runTransT f $ \ g -> ety $ runTransT v $ \t -> k $ (ety g) t | |
| f <*> v = do | |
| r1 <- liftIO $ newIORef Nothing | |
| r2 <- liftIO $ newIORef Nothing | |
| (fparallel r1 r2) <|> (vparallel r1 r2) | |
| where | |
| fparallel :: IORef (Maybe(a -> b)) -> IORef (Maybe a) -> TransIO b | |
| fparallel r1 r2= ety $ Transient $ \k -> | |
| runTransT f $ \g -> do | |
| (liftIO $ writeIORef r1 $ Just (fdyn g)) !> "f write r1" | |
| mt <- liftIO $ readIORef r2 !> "f read r2" | |
| case mt of | |
| Just t -> k $ (fdyn g) t | |
| Nothing -> get >>= liftIO . throw . Empty | |
| vparallel :: IORef (Maybe(a -> b)) -> IORef (Maybe a) -> TransIO b | |
| vparallel r1 r2= ety $ Transient $ \k -> | |
| runTransT v $ \t -> do | |
| (liftIO $ writeIORef r2 $ Just (fdyn t)) !> "v write r2" | |
| mg <- liftIO $ readIORef r1 !> "v read r1" | |
| case mg of | |
| Nothing -> get >>= liftIO . throw . Empty | |
| Just g -> k $ (ety g) t | |
| -- sempty c= do | |
| -- gs <- gets alternative | |
| -- modify $ \s -> s{alternative= tail $ alternative s} | |
| -- let (g,_)= head gs | |
| -- runTransT (ety g) c | |
| newtype Empty= Empty EventF deriving Typeable | |
| instance Show Empty where show _= "Empty" | |
| instance Exception Empty | |
| instance Alternative TransIO where | |
| -- empty= do | |
| -- gs <- gets alternative | |
| -- modify $ \s -> s{alternative= tail $ alternative s} | |
| -- let (g,c) = head gs | |
| -- ety $ g >>=c | |
| -- get >>= liftIO . throw . Empty --Transient ( $ throw Empty) | |
| -- f <|> g = ety $ do | |
| -- callCC $ \cont -> do | |
| -- modify $ \s -> s{alternative= (ety g,cont):alternative s} | |
| -- ety $ f <** (modify $ \s -> s{alternative= tail $ alternative s}) | |
| empty= get >>= liftIO . throw . Empty | |
| f <|> g= callCC $ \k -> do | |
| st <- get | |
| (x,st'') <- liftIO $ io st f k `catch` (\(Empty st') -> io st' g k) | |
| put st'' | |
| return x | |
| where | |
| io st f cont= runTransState st (f >>= cont ) | |
| -- Transient $ \ k ->do | |
| -- mr <- runTransT f k | |
| -- case mr of | |
| -- Nothing -> runTransT g k | |
| -- justr -> return justr | |
| emptyEventF :: ThreadId -> IORef (LifeCycle, BS.ByteString) -> MVar [EventF] -> EventF | |
| emptyEventF th label childs = | |
| EventF { 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 ( a, EventF) | |
| -- runTransient :: Transient r (StateT EventF IO) r -> IO (Maybe r, EventF) | |
| runTransient t = do | |
| th <- myThreadId | |
| label <- newIORef $ (Alive, BS.pack "top") | |
| childs <- newMVar [] | |
| runTransState (emptyEventF th label childs) t | |
| runTransState :: EventF -> TransIO a -> IO ( a, EventF) | |
| runTransState st t= runStateT (runTrans t) st | |
| where | |
| runTrans :: TransIO a -> StateIO a | |
| runTrans t= runTransT t (return . ety id ) | |
| inputLoop= getLine >>= \l -> atomically (writeTVar mvline l) >> inputLoop | |
| no = unsafePerformIO newEmptyMVar | |
| mvline= unsafePerformIO $ newTVarIO "" | |
| option :: String -> TransIO String | |
| --option :: [Char] -> Transient r (StateT t IO) [Char] | |
| option s = waitEvents . atomically $ do | |
| x <- readTVar mvline | |
| if x== s then writeTVar mvline "" >> return s else GHC.Conc.retry | |
| -- callCC :: ((a -> Transient r StateIO b) -> Transient r m a) -> Transient r m a | |
| async :: IO a -> TransIO a | |
| async io= callCC $ \ret -> do | |
| st <- get | |
| liftIO $ forkIO $ runTransState st ( liftIO io >>= ret ) >> return () | |
| empty | |
| waitEvents :: IO a -> TransIO a | |
| --waitEvents :: IO a -> Transient a (StateIO) a | |
| waitEvents io= callCC $ \ret -> do | |
| st <- get | |
| loop ret st | |
| where | |
| loop ret st= do | |
| liftIO $ forkIO $ do | |
| runTransState st (liftIO io >>= ret >> loop ret st) | |
| return () | |
| empty | |
| mainReact = do | |
| -- forkIO inputLoop | |
| forkIO reactLoop | |
| runTransient $ do | |
| r <- (reactOption "hello") <> (reactOption "world") | |
| liftIO $ print r | |
| empty | |
| takeMVar no | |
| 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 | |
| -- every time that an event happens in @m a@ | |
| (<***) :: m a -> m b -> m a | |
| atEnd :: m a -> m b -> m a | |
| atEnd = (<***) | |
| instance AdditionalOperators (Transient StateIO) where | |
| -- (**>) :: TransIO a -> TransIO b -> TransIO b | |
| (**>) f g = Transient $ \c -> ety $ runTransT f (\x -> ety $ runTransT g c) | |
| -- (<***) :: TransIO a -> TransIO b -> TransIO a | |
| (<***) f g = | |
| ety $ Transient $ \k -> ety $ runTransT f $ \x -> ety $ runTransT g (\_ -> k x) | |
| where | |
| f' = callCC $ \c -> g >> c () | |
| -- (<**) :: TransIO a -> TransIO b -> TransIO a | |
| (<**) f g = ety $ Transient $ \k -> ety $ runTransT f $ \x -> ety $ runTransT g (\_ -> k x) | |
| --f >>= g = Transient $ \k -> runTransT f $ \x -> ety $ runTransT ( g $ unsafeCoerce x) k | |
| infixr 1 <***, <**, **> | |
| react | |
| :: ((eventdata -> IO response) -> IO ()) | |
| -> IO response | |
| -> TransIO eventdata | |
| react setHandler iob= callCC $ \ret -> do | |
| st <- get | |
| liftIO $ setHandler $ \x -> (runTransState st $ ret x) >> iob | |
| empty | |
| reactOption :: String -> TransIO String | |
| reactOption s = do | |
| x <- react setCallback (return ()) | |
| if x /= s then empty else do | |
| -- liftIO $ atomically $ writeTVar mvline "" | |
| return s | |
| reactLoop = do | |
| x <- getLine -- atomically $ readTVar mvline | |
| mbs <- readIORef rcb | |
| mapM (\cb -> cb x) mbs | |
| reactLoop | |
| rcb= unsafePerformIO $ newIORef [] | |
| setCallback :: (String -> IO ()) -> IO () | |
| setCallback cb= atomicModifyIORef rcb $ \cbs -> (reverse $ cb : cbs,()) | |
| ----------------------------------backtracking ------------------------ | |
| data Backtrack b= forall a r c. Backtrack{backtracking :: Maybe b | |
| ,backStack :: [(b ->TransIO c,c -> TransIO a)] } | |
| deriving Typeable | |
| -- | Delete all the undo actions registered till now for the given track id. | |
| -- backCut :: (Typeable b, Show b) => b -> TransIO () | |
| backCut reason= | |
| delData $ Backtrack (Just reason) [] | |
| -- | 'backCut' for the default track; equivalent to @backCut ()@. | |
| undoCut :: TransIO () | |
| 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) => TransIO a -> ( b -> TransIO a) -> TransIO a | |
| onBack ac back = do | |
| -- Backtrack mreason _ <- getData `onNothing` backStateOf (typeof bac) !> "HANDLER1" | |
| -- r <-ac | |
| -- case mreason !> ("mreason",mreason) of | |
| -- Nothing -> ac | |
| -- Just reason -> bac reason | |
| registerBack ac back | |
| where | |
| typeof :: (b -> TransIO a) -> b | |
| typeof = undefined | |
| -- | 'onBack' for the default track; equivalent to @onBack ()@. | |
| onUndo :: TransIO a -> TransIO a -> TransIO 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 a, Show a) => (a -> TransIO a) -> a -> TransIO a | |
| registerBack ac back = callCC $ \k -> do | |
| md <- getData `asTypeOf` (Just <$> (backStateOf $ typeof back)) !> "HANDLER" | |
| case md of | |
| Just (bss@(Backtrack b (bs@((back',_):_)))) -> | |
| -- when (isNothing b) $ do | |
| -- addrx <- addr back' | |
| -- addrx' <- addr back -- to avoid duplicate backtracking points | |
| -- when (addrx /= addrx') $ do return () !> "ADD"; setData $ Backtrack mwit ( (back, k): unsafeCoerce bs) | |
| setData $ Backtrack b ( (back, k): unsafeCoerce bs) | |
| Just (Backtrack b []) -> setData $ Backtrack b [(back , k)] | |
| Nothing -> do | |
| setData $ Backtrack mwit [ (back , k)] !> "NOTHING" | |
| ac | |
| where | |
| typeof :: (b -> TransIO a) -> b | |
| typeof = undefined | |
| mwit= Nothing `asTypeOf` (Just $ typeof back) | |
| addr x = liftIO $ return . hashStableName =<< (makeStableName $! x) | |
| -- registerUndo :: TransIO a -> TransIO 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= do | |
| Backtrack _ stack <- getData `onNothing` (backStateOf reason) | |
| setData $ Backtrack(Nothing `asTypeOf` Just reason) stack | |
| -- | 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 -> TransIO a | |
| back reason = do | |
| Backtrack _ cs <- getData `onNothing` backStateOf reason | |
| let bs= Backtrack (Just reason) cs | |
| setData bs | |
| goBackt bs | |
| !>"GOBACK" | |
| where | |
| goBackt (Backtrack _ [] )= empty !> "END" | |
| goBackt (Backtrack Nothing _ )= error "goback: no reason" | |
| goBackt (Backtrack (Just reason) ((handler,cont) : bs))= do | |
| -- setData $ Backtrack (Just reason) $ tail stack | |
| -- unsafeCoerce $ first reason !> "GOBACK2" | |
| x <- unsafeCoerce handler reason -- !> ("RUNCLOSURE",length stack) | |
| Backtrack mreason _ <- getData `onNothing` backStateOf reason | |
| -- setData $ Backtrack mreason bs | |
| -- -- !> "END RUNCLOSURE" | |
| -- case mr of | |
| -- Nothing -> return empty -- !> "END EXECUTION" | |
| case mreason of | |
| Nothing -> do | |
| --setData $ Backtrack Nothing bs | |
| unsafeCoerce $ cont x !> "FORWARD EXEC" | |
| justreason -> do | |
| setData $ Backtrack justreason bs | |
| goBackt $ Backtrack justreason bs !> ("BACK AGAIN") | |
| empty | |
| backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a) | |
| backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) [] | |
| ------ exceptions --- | |
| -- | |
| -- | Install an exception handler. Handlers are executed in reverse (i.e. last in, first out) order when such exception happens in the | |
| -- continuation. Note that multiple handlers can be installed for the same exception type. | |
| -- | |
| -- The semantic is thus very different than the one of `Control.Exception.Base.onException` | |
| 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 -> return $ error "do nothing,this should not be evaluated" | |
| Just e' -> f e' | |
| where | |
| --onAnyException :: TransIO a -> (SomeException ->TransIO a) -> TransIO a | |
| onAnyException mx f= ioexp `onBack` f | |
| where | |
| ioexp = callCC $ \cont -> do | |
| st <- get | |
| ioexp' $ runTransState st (mx >>=cont ) `catch` exceptBack st | |
| ioexp' mx= do | |
| (mx,st') <- liftIO mx | |
| put st' | |
| case mx of | |
| Nothing -> empty | |
| Just x -> return x | |
| exceptBack st = \(e ::SomeException) -> do -- recursive catch itself | |
| return () !> "CATCHHHHHHHHHHHHH" | |
| runTransState st (back e ) | |
| `catch` exceptBack st | |
| -- | Delete all the exception handlers registered till now. | |
| cutExceptions :: TransIO () | |
| cutExceptions= backCut (undefined :: SomeException) | |
| -- | Use it inside an exception handler. it stop executing any further exception | |
| -- handlers and resume normal execution from this point on. | |
| continue :: TransIO () | |
| continue = forward (undefined :: SomeException) !> "CONTINUE" | |
| -- | catch an exception in a Transient block | |
| -- | |
| -- The semantic is the same than `catch` but the computation and the exception handler can be multirhreaded | |
| -- catcht1 mx exc= mx' `onBack` exc | |
| -- where | |
| -- mx'= Transient $ const $do | |
| -- st <- get | |
| -- (mx, st) <- liftIO $ runTransState st mx `catch` exceptBack st | |
| -- put st | |
| -- return mx | |
| catcht :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a | |
| catcht mx exc= do | |
| rpassed <- liftIO $ newIORef False | |
| sandbox $ do | |
| delData $ Backtrack (Just (undefined :: SomeException)) [] | |
| r <- onException' mx $ \e -> do | |
| passed <- liftIO $ readIORef rpassed | |
| if not passed then unsafeCoerce continue >> exc e else empty | |
| liftIO $ writeIORef rpassed True | |
| return r | |
| where | |
| sandbox :: TransIO a -> TransIO a | |
| sandbox mx= do | |
| exState <- getData `onNothing` backStateOf (undefined :: SomeException) | |
| mx <*** setState exState | |
| -- | throw an exception in the Transient monad | |
| throwt :: Exception e => e -> TransIO a | |
| throwt= back . toException | |
| -- * 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 $ const $ do | |
| mx <- getData | |
| case mx of | |
| Nothing -> empty | |
| Just x -> return x | |
| -- | 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 | |
| -- STRefs for the Transient monad | |
| -- | 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' | |
| mainBack = do | |
| runTransient $ do | |
| return () !> "before" | |
| r <- async (print "hello") `onBack` \s -> liftIO $ print $ "received: 111"++ s | |
| r <- async (print "world") `onBack` \s -> liftIO $ print $ "received: 222"++ s | |
| back "exception" | |
| empty | |
| takeMVar no | |
| main1= do | |
| runTransient $ do | |
| return () !> "before" | |
| onException $ \(s :: SomeException) -> liftIO $ print $ "received: 111"++ show s | |
| async $ print "$$$$$$$$$$$$" | |
| -- r <- async (print "hello") `onException'` \(s :: SomeException) -> liftIO $ print $ "received: 111"++ show s | |
| -- r <- async (print "world") `onException'` \(s :: SomeException) -> liftIO $ print $ "received: 222"++ show s | |
| liftIO $ print "AFTER" | |
| liftIO $ myThreadId >>= print | |
| error "exception" | |
| takeMVar no | |
| mainCatch= do | |
| runTransient $ do | |
| async $ print "hello" | |
| error "error" | |
| return () | |
| `catcht` (\(e :: SomeException) -> liftIO $ print $ "RECEIVED " ++ show e) | |
| takeMVar no | |
| main2= runTransient $ do | |
| r <- return 2 | |
| r' <- liftIO $ return $ r +5 | |
| r2 <- callCC $ \ret -> do | |
| ret 100 | |
| liftIO $ print "HELLO" | |
| return 1 | |
| liftIO $ print $ r2 | |
| liftIO $ print $ "world3" | |
| main= keep $ do | |
| -- r<- async ( return "hello") <*** liftIO (print "world") | |
| r <- ( async (threadDelay 10000 >> return "hello ") <> return "world" ) <|> return "world2" | |
| -- r <- Transient $ \c -> runTransT (return "hello") c | |
| liftIO $ putStrLn r | |
| mexit= unsafePerformIO $ newEmptyMVar | |
| keep mx= do | |
| forkIO $( runTransient mx >> return ()) `catch` \(Empty _) -> return () | |
| takeMVar mexit |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment