Week 6 Lecture 1

1
import Control.Concurrent (
2
  Chan,
3
  ThreadId,
4
  forkIO,
5
  newChan,
6
  readChan,
7
  threadDelay,
8
  writeChan,
9
 )
10
import Control.Monad (forM, forever, void)
11
12
-- forkIO -- Creates a thread
13
-- newChan -- Creates a new channel
14
-- writeChan -- Writes to the channel's message queue
15
-- readChan -- Reads from the channel. Blocks if the channel is empty
16
17
messageExample :: IO ()
18
messageExample = do
19
  c <- newChan
20
  forkIO $ forever $ do
21
    x <- readChan c
22
    putStrLn $ "Received: " ++ x
23
  writeChan c "42"
24
  writeChan c "43"
25
  pure ()
26
27
messageExample2 :: IO ()
28
messageExample2 = do
29
  c <- newChan
30
  let threadLoop c = do
31
        x <- readChan c
32
        putStrLn $ "Received: " ++ x
33
        threadLoop c
34
  forkIO $ threadLoop c
35
  writeChan c "42"
36
  writeChan c "43"
37
  pure ()
38
39
-- Single reader principle
40
-- A channel shall only be read by one thread, yet can be written by multiple
41
42
---- IncServer BEGIN
43
44
data Msg = MsgInc Int (Chan Int) | MsgSet Int
45
46
newServer :: IO IncServer
47
newServer = do
48
  c <- newChan
49
  let threadLoop state = do
50
        msg <- readChan c
51
        case msg of
52
          MsgInc n rc -> do
53
            writeChan rc state
54
            threadLoop $ state + n
55
          MsgSet n -> threadLoop n
56
  forkIO $ threadLoop 0
57
  pure $ IncServer $ c
58
59
data IncServer = IncServer (Chan Msg)
60
61
-- This is an RPC operation
62
serverInc :: IncServer -> Int -> IO Int
63
serverInc (IncServer c) n = do
64
  rc <- newChan
65
  writeChan c $ MsgInc n rc
66
  readChan rc
67
68
-- This is an asynchronous operation
69
serverSet :: IncServer -> Int -> IO ()
70
serverSet (IncServer c) = writeChan c . MsgSet
71
72
usage :: IO ()
73
usage = do
74
  s <- newServer
75
  forM [1 .. 10] $ \i ->
76
    forkIO $ void $ serverInc s i
77
  serverSet s 0
78
  r <- serverInc s 0
79
  putStrLn $ show r
80
81
---- IncServer END
82
83
---- GenServer BEGIN
84
85
-- ørlæng (cursed)
86
87
data Server msg = Server ThreadId (Chan msg)
88
89
spawn :: (Chan msg -> IO ()) -> IO (Server msg)
90
spawn f = do
91
  c <- newChan
92
  fid <- forkIO $ f c
93
  pure $ Server fid c
94
95
send :: Chan msg -> msg -> IO ()
96
send = writeChan
97
98
receive :: Chan msg -> IO msg
99
receive = readChan
100
101
-- asynchronous
102
sendTo :: Server msg -> msg -> IO ()
103
sendTo (Server _ c) msg = send c msg
104
105
data ReplyChan a = ReplyChan (Chan a)
106
107
reply :: ReplyChan a -> a -> IO ()
108
reply (ReplyChan c) = send c
109
110
requestReply :: Server msg -> (ReplyChan a -> msg) -> IO a
111
requestReply server mkMsg = do
112
  rc <- newChan
113
  let msg = mkMsg $ ReplyChan rc
114
  sendTo server msg
115
  receive rc
116
117
---- GenServer END
118
119
---- IncServer based on GenServer BEGIN
120
121
data ISGMsg
122
  = ISGMsgInc Int (ReplyChan Int)
123
  | ISGMsgSet Int
124
125
data ISGServer = ISGServer (Server ISGMsg)
126
127
newISGServer :: IO ISGServer
128
newISGServer = do
129
  let serverLoop state c = do
130
        msg <- receive c
131
        case msg of
132
          (ISGMsgInc a rc) -> do
133
            reply rc state
134
            serverLoop (state + a) c
135
          (ISGMsgSet a) -> serverLoop a c
136
  ISGServer <$> (spawn $ serverLoop 0)
137
138
serverInc' :: Int -> ISGServer -> IO Int
139
serverInc' x (ISGServer server) = requestReply server (ISGMsgInc x)
140
141
serverSet' :: Int -> ISGServer -> IO ()
142
serverSet' n (ISGServer server) = sendTo server $ ISGMsgSet n
143
144
---- IncServer based on GenServer END
145
146
usage' :: IO ()
147
usage' = do
148
  s <- newISGServer
149
  serverSet' 3 s
150
  serverSet' 4 s
151
  _ <- serverInc' 4 s
152
  _ <- serverInc' 4 s
153
  r <- serverInc' 4 s
154
  putStrLn $ show r
155
156
type Timeout = Int
157
158
readWithTimeout :: Chan a -> Timeout -> IO (Maybe a)
159
readWithTimeout chan timeout = do
160
  -- tc :: Chan (Maybe a)
161
  tc <- newChan
162
  forkIO $ threadDelay timeout >> writeChan tc Nothing
163
  forkIO $ readChan chan >>= writeChan tc . Just
164
  readChan tc
165
166
usage'' :: IO ()
167
usage'' = do
168
  c <- newChan
169
  forkIO $ do
170
    threadDelay 10000000000
171
    writeChan c 123
172
  x <- readWithTimeout c 1000000
173
  print x
174
175
-- Our job as computer scientists is to take programs that are """exciting""", and make them somehow less """exciting"""
176
177
-- I'm not judging you on taste (in this course)
178
179
-- Space