Week 6 Lecture 2

1
import Control.Concurrent (
2
  Chan,
3
  ThreadId,
4
  forkIO,
5
  newChan,
6
  readChan,
7
  threadDelay,
8
  writeChan,
9
 )
10
import Control.Exception (SomeException, catch, evaluate)
11
import Control.Monad (forM, forever, void)
12
import Distribution.Simple.Build (repl)
13
14
-- import GenServer
15
16
data Server msg = Server ThreadId (Chan msg)
17
18
spawn :: (Chan msg -> IO ()) -> IO (Server msg)
19
spawn f = do
20
  c <- newChan
21
  fid <- forkIO $ f c
22
  pure $ Server fid c
23
24
send :: Chan msg -> msg -> IO ()
25
send = writeChan
26
27
receive :: Chan msg -> IO msg
28
receive = readChan
29
30
-- asynchronous
31
sendTo :: Server msg -> msg -> IO ()
32
sendTo (Server _ c) msg = send c msg
33
34
data ReplyChan a = ReplyChan (Chan a)
35
36
reply :: ReplyChan a -> a -> IO ()
37
reply (ReplyChan c) = send c
38
39
requestReply :: Server msg -> (ReplyChan a -> msg) -> IO a
40
requestReply server mkMsg = do
41
  rc <- newChan
42
  let msg = mkMsg $ ReplyChan rc
43
  sendTo server msg
44
  receive rc
45
46
--
47
48
type Seconds = Int
49
50
data Status a
51
  = Value a
52
  | Timeout
53
  | Error String
54
  deriving (Show)
55
56
data Async a = Async (Server (Msg a))
57
58
data Msg a
59
  = MsgWait (ReplyChan (Status a))
60
  | MsgPoll (ReplyChan (Maybe (Status a)))
61
  | MsgPutVal a
62
  | MsgTimeout
63
  | MsgError String
64
65
{-
66
serverLoopOld :: a -> Chan (Msg a) -> IO ()
67
serverLoopOld x c = do
68
  msg <- receive c
69
  case msg of
70
    MsgWait rc -> do
71
      reply rc x
72
      serverLoopOld x c
73
    MsgPoll rc -> do
74
      reply rc $ Just x
75
      serverLoopOld x c
76
    MsgPutVal a -> undefined
77
-}
78
79
-- State machine approach
80
81
serverLoopNoVal :: Chan (Msg a) -> [ReplyChan (Status a)] -> IO ()
82
serverLoopNoVal c waiters = do
83
  msg <- receive c
84
  case msg of
85
    MsgWait rc -> do
86
      serverLoopNoVal c (rc : waiters)
87
    MsgPoll rc -> do
88
      reply rc Nothing
89
      serverLoopNoVal c waiters
90
    MsgPutVal a -> do
91
      mapM_ (\rc -> reply rc (Value a)) waiters
92
      serverLoopVal (Value a) c
93
    MsgTimeout -> do
94
      mapM_ (\rc -> reply rc Timeout) waiters
95
      serverLoopNoVal c []
96
    MsgError e -> do
97
      mapM_ (\rc -> reply rc $ Error e) waiters
98
      serverLoopVal (Error e) c
99
100
serverLoopVal :: Status a -> Chan (Msg a) -> IO ()
101
serverLoopVal a c = do
102
  msg <- receive c
103
  case msg of
104
    MsgWait rc -> do
105
      reply rc $ a
106
      serverLoopVal a c
107
    MsgPoll rc -> do
108
      reply rc $ Just $ a
109
      serverLoopVal a c
110
    MsgPutVal _ ->
111
      serverLoopVal a c
112
    MsgTimeout -> do
113
      serverLoopVal a c
114
    MsgError _ -> do
115
      serverLoopVal a c
116
117
{-
118
-- will block only at wait, thx Haskell
119
asyncLazy :: (b -> a) -> b -> IO (Async a)
120
asyncLazy f x = do
121
  s <- spawn $ do
122
    let y = f x
123
    serverLoopOld y
124
  pure $ Async s
125
126
-- when serverLoop :: a -> Chan (Msg a) -> IO ()
127
asyncBlockServer :: (b -> a) -> b -> IO (Async a)
128
asyncBlockServer f x = do
129
  s <- spawn $ \c -> do
130
    y <- evaluate $ f x
131
    serverLoopOld y c
132
  pure $ Async s
133
-}
134
135
async :: (b -> a) -> b -> IO (Async a)
136
async f x = do
137
  s <- spawn $ \c -> do
138
    forkIO $ do
139
      y <- evaluate $ f x
140
      send c $ MsgPutVal y
141
    serverLoopNoVal c []
142
  pure $ Async s
143
144
asyncTimeout :: Seconds -> (b -> a) -> b -> IO (Async a)
145
asyncTimeout t f x = do
146
  s <- spawn $ \c -> do
147
    _ <- forkIO $ do
148
      let comp :: IO ()
149
          comp = do
150
            y <- evaluate $ f x
151
            send c $ MsgPutVal y
152
          handler :: SomeException -> IO ()
153
          handler e = do
154
            send c $ MsgError (show e)
155
      catch comp handler
156
    _ <- forkIO $ do
157
      threadDelay $ t * 1000000
158
      send c $ MsgTimeout
159
    serverLoopNoVal c []
160
  pure $ Async s
161
162
wait :: Async a -> IO (Status a)
163
wait (Async s) = requestReply s MsgWait
164
165
waitAny :: [Async a] -> IO (Status a)
166
waitAny [] = error "empty list"
167
waitAny [x] = wait x
168
waitAny (x : xs) = do
169
  c <- newChan
170
  forkIO $ do
171
    x' <- wait x
172
    send c x'
173
  forkIO $ do
174
    y' <- waitAny xs
175
    send c y'
176
  receive c
177
178
-- Check for computation finish
179
-- Should respond as quickly as possible
180
-- Won't work, cause the serverLoop does the job,
181
--   so it is blocked and cannot answer in time
182
pollSimple :: Async a -> IO (Maybe (Status a))
183
pollSimple (Async s) = requestReply s MsgPoll
184
185
poll :: Async a -> IO (Maybe (Status a))
186
poll (Async s) = requestReply s MsgPoll
187
188
-- DEMOS
189
190
fib :: Int -> Int
191
fib x
192
  | x == 0 = 1
193
  | x == 1 = 1
194
  | x < 0 = error ""
195
  | otherwise = (fib (x - 1)) + (fib (x - 2))
196
197
{-
198
demo1 :: IO ()
199
demo1 = do
200
  a <- asyncLazy fib 30
201
  res <- wait a -- continuation goes on, as the value is not used
202
  putStrLn "I got the result"
203
  putStrLn "Here it is:"
204
  putStrLn $ show res -- lazyness only force the actual blocking here
205
206
demo2 :: IO ()
207
demo2 = do
208
  a <- asyncBlockServer fib 30 -- will be eager evaluation at wait
209
  _ <- pollSimple a
210
  res <- wait a -- blocks here, as intended
211
  putStrLn "I got the result"
212
  putStrLn "Here it is:"
213
  putStrLn $ show res
214
-}
215
216
demo3 :: IO ()
217
demo3 = do
218
  a <- asyncTimeout 5 fib 30 -- will be eager evaluation at wait
219
  b <- poll a
220
  putStrLn $ "Poll returned: " ++ show b
221
  res <- wait a -- blocks here, as intended
222
  putStrLn "I got the result"
223
  putStrLn "Here it is:"
224
  putStrLn $ show res
225
226
-- No space
227
228
-- We are runnig aout of teaching
229
230
-- Written form exam
231
-- Dummy exam on the last week
232
-- Different size, and Maybe different difficulty (best guess according to him)
233
234
-- Finish of week7 exercise is expected, though marked [optional]
235
236
-- No idea how many questions
237
-- One TA is on it
238
-- Grading is not based on answer %
239
240
-- on week 8 and anything before exam: nothing planned
241
-- last lecture is on week 7
242
243
-- Exercise 7 is last year's exam
244