example
function is, of course, non-blocking):
example :: Int -> AIO () <br>
example v = do <br>
x <- request v<br>
y <- request ( x * x ) <br>
io $ print ( x + y ) <br>
example :: Int -> IO () <br>
example v = do <br>
x <- request v<br>
y <- request ( x * x ) <br>
print ( x + y ) <br>
Chan a
), and the message will be of type (Int, String)
, i.e. message number and serialized value.
> module Test ( <br>
> ) where <br>
> <br>
> import Control . Arrow <br>
> import Control . Monad <br>
> import Control . Concurrent . MVar <br>
> import Control . Concurrent . Chan <br>
> import Control . Concurrent <br>
> import Data . List <br>
> import Data . Maybe <br>
> data AState = AState { <br>
> aCurrent :: MVar Int , <br>
> aWait :: MVar [ ( Int , String -> IO () ) ] , <br>
> aChanOut :: Chan ( Int , String ) , <br>
> aChanIn :: Chan ( Int , String ) } <br>
> <br>
> newA = liftM4 AState ( newMVar 0 ) ( newMVar [] ) newChan newChan<br>
> listener ( AState _ w _ chIn ) = forever $ do <br>
> ( i , s ) <- readChan chIn<br>
> -- modifyMVar a -> IO (a, b) <br>
> -- .. , . <br>
> -- callback. <br>
> callback <- modifyMVar w $ \ callbacks -> do <br>
> -- callback' . <br>
> let ( past , ok ) = partition ( ( /= i ) . fst ) callbacks<br>
> -- ( ). <br>
> case ok of <br>
> ( ( _ , f ) : _ ) -> return ( past , f ) -- callback ( ). <br>
> _ -> return ( past , \ s -> return () ) -- , <br>
> callback s -- callback. <br>
aChanOut
channel).
aChanOut
and display on the screen:
> tracer ( AState _ _ chOut _ ) = forever $ readChan chOut >>= print<br>
sendAndReceive1 :: AState -> String -> ( String -> IO () ) -> IO () <br>
sendAndReceive1 ( AState cur w chOut _ ) msg onMsg = do <br>
i <- modifyMVar cur ( return . ( succ &&& id ) ) -- 1 . <br>
modifyMVar_ w ( return . ( ( i , onMsg ) : ) ) -- callback. <br>
writeChan chOut ( i , msg ) -- . <br>
sendAndReceive1 a ( show 123 ) $ \ ans -> do <br>
let x = read ans -- . <br>
print x<br>
sendAndReceive1 a ( show x ) $ \ ans2 -> do <br>
-- ... <br>
sendAndReceive2
, using, for example, the standard read
and show
defaults.
sendAndReceive1 :: AState -> a -> ( a -> String ) -> ( String -> b ) -> ( b -> IO () ) -> IO () <br>
sendAndReceive1 ( AState cur w chOut _ ) msg show_ read_ onMsg = do <br>
i <- modifyMVar cur ( return . ( succ &&& id ) ) <br>
modifyMVar_ w ( return . ( ( i , onMsg . read_ ) : ) ) <br>
writeChan chOut ( i , show_ msg ) <br>
<br>
sendAndReceive2 :: ( Show a , Read b ) => AState -> a -> ( b -> IO () ) -> IO () <br>
sendAndReceive2 a msg onMsg = sendAndReceive1 a msg show read onMsg<br>
<br>
-- . <br>
sendAndReceive2 a 23 $ \ x -> do <br>
print x<br>
sendAndReceive2 a ( x + 10 ) $ \ z -> ... <br>
ma -> (a -> mb) -> mb
, then our callback is suggested as the second argument. But also there one must be able to transfer the usual calculation of the type print
.
> data AS a = Send String ( String -> AIO a ) | Pure a<br>
IO
monad.
> data AIO a = AIO { aio :: IO ( AS a ) } <br>
IO
into our monad. It should just return the same as IO
, but wrapping it in the Pure
constructor Pure
> io :: IO a -> AIO a<br>
<br>
io act = AIO $ do <br>
v <- act<br>
return ( Pure v ) <br>
> io = AIO . liftM Pure <br>
Send
, in essence, simply wrapping the arguments into the constructor:
> sendAndReceive :: a -> ( a -> String ) -> ( String -> b ) -> AIO b<br>
> sendAndReceive msg to from = AIO $ return $ Send ( to msg ) ( return . from ) <br>
request
, using show
, read
for serialization:
> request :: ( Show a , Read b ) => a -> AIO b<br>
> request msg = sendAndReceive msg show read<br>
AIO
type.
example
). The created dialogue is reduced to two options:
Pure
- you just need to remove the value and return it.
Send
- the main work takes place here - we generate a number, register a callback and send a message.
> run :: AState -> AIO () -> IO () <br>
> run a @ ( AState cur w chOut chIn ) act = run' act where <br>
> run' ( AIO actIO ) = do <br>
> as <- actIO<br>
> case as of <br>
> Pure value -> return value<br>
> Send msg onMsg -> do <br>
> i <- modifyMVar cur ( return . ( succ &&& id ) ) -- <br>
> modifyMVar_ w ( return . ( ( i , run' . onMsg ) : ) ) -- callback. <br>
> writeChan chOut ( i , msg ) -- . <br>
instance
monads:
> instance Monad AIO where <br>
> return = AIO . return . Pure -- <br>
> AIO v >>= f = AIO $ do <br>
> x <- v -- AS, Send Pure? <br>
> case x of <br>
> -- Pure, callback . <br>
> Pure value -> aio $ f value<br>
> -- "" callback . <br>
> Send msg onMsg -> return $ Send msg ( \ s -> onMsg s >>= f ) <br>
listener
threads to process incoming messages to the client and the tracer
to output incoming messages to the server, and return the function to us to send messages from the server back to our client. Those. in this case, we will act as an interlocutor, typing what we want to send to our client:
> start :: IO ( AState , ( Int , String ) -> IO () ) <br>
> start = newA >>= forks where <br>
> forks a = mapM_ forkIO [ listener a , tracer a ] >> return ( a , writeChan ( aChanIn a ) ) <br>
-- , - <br>
-- , <br>
ghci > ( a , f ) <- start<br>
-- <br>
ghci > run a ( example 10 ) <br>
-- <br>
( 0 , "10" ) <br>
-- <br>
ghci > run a ( example 20 ) <br>
-- , <br>
( 1 , "20" ) <br>
-- "" <br>
ghci > f ( 0 , "11" ) <br>
-- <br>
( 2 , "121" ) <br>
-- "" <br>
ghci > f ( 1 , "21" ) <br>
-- <br>
( 3 , "441" ) <br>
-- "", , "" <br>
ghci > f ( 3 , "444" ) <br>
-- <br>
465 <br>
-- "" <br>
ghci > f ( 2 , "122" ) <br>
133 <br>
ghci > <br>
example
once, the dialogs with them do not overlap.
test.lhs
and test it yourself.
Source: https://habr.com/ru/post/117031/