Skip to content

Commit f8533f0

Browse files
hyperthunkhyperthunk
committed
fiddle around with the lack of a MonadFail in the stack...
1 parent 082d5b5 commit f8533f0

File tree

5 files changed

+106
-52
lines changed

5 files changed

+106
-52
lines changed

‎distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hs

Lines changed: 61 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -169,8 +169,11 @@ testUnclosure TestTransport{..} rtable = do
169169
node <- newLocalNode testTransport rtable
170170
done <- newEmptyMVar
171171
forkProcess node $ do
172-
120 <- join . unClosure $ factorialClosure 5
172+
i <- join . unClosure $ factorialClosure 5
173173
liftIO $ putMVar done ()
174+
if i == 720
175+
then return ()
176+
else error "Something went horribly wrong"
174177
takeMVar done
175178

176179
testBind :: TestTransport -> RemoteTable -> Assertion
@@ -180,8 +183,11 @@ testBind TestTransport{..} rtable = do
180183
runProcess node $ do
181184
us <- getSelfPid
182185
join . unClosure $ sendFac 6 us
183-
(720 :: Int) <- expect
186+
(i :: Int) <- expect
184187
liftIO $ putMVar done ()
188+
if i == 720
189+
then return ()
190+
else error "Something went horribly wrong"
185191
takeMVar done
186192

187193
testSendPureClosure :: TestTransport -> RemoteTable -> Assertion
@@ -194,7 +200,7 @@ testSendPureClosure TestTransport{..} rtable = do
194200
addr <- forkProcess node $ do
195201
cl <- expect
196202
fn <- unClosure cl :: Process (Int -> Int)
197-
13 <- return $ fn 6
203+
(_ :: Int) <- return $ fn 6
198204
liftIO $ putMVar serverDone ()
199205
putMVar serverAddr addr
200206

@@ -218,8 +224,11 @@ testSendIOClosure TestTransport{..} rtable = do
218224
liftIO $ do
219225
someMVar <- newEmptyMVar
220226
io someMVar
221-
5 <- readMVar someMVar
227+
i <- readMVar someMVar
222228
putMVar serverDone ()
229+
if i == 5
230+
then return ()
231+
else error "Something went horribly wrong"
223232
putMVar serverAddr addr
224233

225234
forkIO $ do
@@ -248,8 +257,10 @@ testSendProcClosure TestTransport{..} rtable = do
248257
runProcess node $ do
249258
pid <- getSelfPid
250259
send theirAddr (cpSend $(mkStatic 'sdictInt) pid)
251-
5 <- expect :: Process Int
252-
liftIO $ putMVar clientDone ()
260+
i <- expect :: Process Int
261+
if i == 5
262+
then liftIO $ putMVar clientDone ()
263+
else error "Something went horribly wrong"
253264

254265
takeMVar clientDone
255266

@@ -269,8 +280,9 @@ testSpawn TestTransport{..} rtable = do
269280
pid <- getSelfPid
270281
pid' <- spawn nid (sendPidClosure pid)
271282
pid'' <- expect
272-
True <- return $ pid' == pid''
273-
liftIO $ putMVar clientDone ()
283+
if pid' == pid''
284+
then liftIO $ putMVar clientDone ()
285+
else error "Something went horribly wrong"
274286

275287
takeMVar clientDone
276288

@@ -294,8 +306,9 @@ testSpawnRace TestTransport{..} rtable = do
294306
spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid
295307
pid' <- expect :: Process ProcessId
296308
pid'' <- expect :: Process ProcessId
297-
True <- return $ pid' == pid''
298-
return ()
309+
if pid' == pid''
310+
then return ()
311+
else error "Something went horribly wrong"
299312

300313
where
301314

@@ -332,8 +345,10 @@ testCall TestTransport{..} rtable = do
332345
node <- newLocalNode testTransport rtable
333346
nid <- readMVar serverNodeAddr
334347
runProcess node $ do
335-
(120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
336-
liftIO $ putMVar clientDone ()
348+
(a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)
349+
if a == 120
350+
then liftIO $ putMVar clientDone ()
351+
else error "something went horribly wrong"
337352

338353
takeMVar clientDone
339354

@@ -350,8 +365,10 @@ testCallBind TestTransport{..} rtable = do
350365
node <- newLocalNode testTransport rtable
351366
nid <- readMVar serverNodeAddr
352367
runProcess node $ do
353-
(120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
354-
liftIO $ putMVar clientDone ()
368+
(a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)
369+
if a == 120
370+
then liftIO $ putMVar clientDone ()
371+
else error "Something went horribly wrong"
355372

356373
takeMVar clientDone
357374

@@ -362,9 +379,11 @@ testSeq TestTransport{..} rtable = do
362379
runProcess node $ do
363380
us <- getSelfPid
364381
join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us
365-
120 :: Int <- expect
366-
720 :: Int <- expect
367-
liftIO $ putMVar done ()
382+
a :: Int <- expect
383+
b :: Int <- expect
384+
if a == 120 && b == 720
385+
then liftIO $ putMVar done ()
386+
else error "Something went horribly wrong"
368387
takeMVar done
369388

370389
-- Test 'spawnSupervised'
@@ -407,12 +426,15 @@ testSpawnSupervised TestTransport{..} rtable = do
407426
liftIO $ putMVar linkUp ()
408427
-- because monitor message was sent before message to process
409428
-- we hope that it will be processed before
410-
ProcessMonitorNotification ref' pid' (DiedException e) <- expect
411-
True <- return $ ref' == ref
412-
&& pid' == child
413-
&& e == show (ProcessLinkException super (DiedException (show supervisorDeath)))
414-
liftIO $ putMVar thirdProcessDone ()
415-
429+
res <- expect
430+
case res of
431+
(ProcessMonitorNotification ref' pid' (DiedException e)) ->
432+
if (ref' == ref && pid' == child &&
433+
e == show (ProcessLinkException super
434+
(DiedException (show supervisorDeath))))
435+
then liftIO $ putMVar thirdProcessDone ()
436+
else error "Something went horribly wrong"
437+
_ -> error "Something went horribly wrong"
416438
takeMVar thirdProcessDone
417439
where
418440
supervisorDeath :: IOException
@@ -426,8 +448,10 @@ testSpawnInvalid TestTransport{..} rtable = do
426448
(pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)
427449
ProcessMonitorNotification ref' pid' _reason <- expect
428450
-- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
429-
True <- return $ ref' == ref && pid == pid'
430-
liftIO $ putMVar done ()
451+
res <- return $ ref' == ref && pid == pid'
452+
if res == True
453+
then liftIO $ putMVar done ()
454+
else error "Something went horribly wrong"
431455
takeMVar done
432456

433457
testClosureExpect :: TestTransport -> RemoteTable -> Assertion
@@ -439,8 +463,10 @@ testClosureExpect TestTransport{..} rtable = do
439463
us <- getSelfPid
440464
them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us
441465
send them (1234 :: Int)
442-
(1234 :: Int) <- expect
443-
liftIO $ putMVar done ()
466+
(res :: Int) <- expect
467+
if res == 1234
468+
then liftIO $ putMVar done ()
469+
else error "Something went horribly wrong"
444470
takeMVar done
445471

446472
testSpawnChannel :: TestTransport -> RemoteTable -> Assertion
@@ -465,8 +491,10 @@ testTDict TestTransport{..} rtable = do
465491
done <- newEmptyMVar
466492
[node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable
467493
forkProcess node1 $ do
468-
True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
469-
liftIO $ putMVar done ()
494+
res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))
495+
if res == True
496+
then liftIO $ putMVar done ()
497+
else error "Something went horribly wrong..."
470498
takeMVar done
471499

472500
testFib :: TestTransport -> RemoteTable -> Assertion
@@ -503,9 +531,12 @@ testSpawnReconnect testtrans@TestTransport{..} rtable = do
503531
liftIO $ threadDelay 100000
504532

505533
count <- liftIO $ takeMVar iv
506-
True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
534+
res <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'
507535

508536
liftIO $ putMVar done ()
537+
if res /= True
538+
then error "Something went horribly wrong"
539+
else return ()
509540

510541
takeMVar done
511542

‎distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hs

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,7 @@ import Test.Framework.Providers.HUnit (testCase)
2929

3030
testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
3131
testLocalDeadProcessInfo result = do
32-
pid <- spawnLocal $ do "finish" <- expect; return ()
32+
pid <- spawnLocal $ do (_ :: String) <- expect; return ()
3333
mref <- monitor pid
3434
send pid "finish"
3535
_ <- receiveWait [
@@ -52,8 +52,10 @@ testLocalLiveProcessInfo result = do
5252
link self
5353
mRef <- monitor self
5454
stash mon mRef
55-
"die" <- expect
56-
return ()
55+
res <- expect
56+
case res of
57+
"die" -> return ()
58+
_ -> die $ "unexpected message received: " ++ res
5759

5860
monRef <- liftIO $ takeMVar mon
5961

@@ -84,9 +86,9 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do
8486
-- our send op shouldn't overtake link or monitor requests AFAICT
8587
-- so a little table tennis should get us synchronised properly
8688
send serverPid (self, "ping")
87-
"pong" <- expect
89+
pong <- expect
8890
pInfo <- getProcessInfo serverPid
89-
stash result $ pInfo /= Nothing
91+
stash result $ pong == "pong" && pInfo /= Nothing
9092
where
9193
launchRemote :: MVar ProcessId -> IO ()
9294
launchRemote locMV = do
@@ -97,8 +99,10 @@ testRemoteLiveProcessInfo TestTransport{..} node1 = do
9799
_ <- receiveWait [
98100
match (\(pid, "ping") -> send pid "pong")
99101
]
100-
"stop" <- expect
101-
return ()
102+
res <- expect
103+
case res of
104+
"stop" -> return ()
105+
_ -> die $ "unexpected message received: " ++ res
102106
return ()
103107

104108
withActiveRemote :: LocalNode

‎distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs

Lines changed: 23 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -125,9 +125,11 @@ testTraceSending result = do
125125
(\ev ->
126126
case ev of
127127
(MxSent to from msg) -> do
128-
(Just s) <- unwrapMessage msg :: Process (Maybe String)
129-
stash res (to == pid && from == self && s == "hello there")
130-
stash res (to == pid && from == self)
128+
mS <- unwrapMessage msg :: Process (Maybe String)
129+
case mS of
130+
(Just s) -> do stash res (to == pid && from == self && s == "hello there")
131+
stash res (to == pid && from == self)
132+
_ -> die "failed state invariant, message type unmatched..."
131133
_ ->
132134
return ()) $ do
133135
send pid "hello there"
@@ -246,12 +248,8 @@ testRemoteTraceRelay TestTransport{..} result =
246248
-- Here we set up that relay, and then wait for a signal
247249
-- that the tracer (on node1) has seen the expected
248250
-- MxSpawned message, at which point we're finished
249-
(Just log') <- whereis "logger"
250-
pid <- liftIO $ forkProcess node2 $ do
251-
logRelay <- spawnLocal $ relay log'
252-
reregister "logger" logRelay
253-
getSelfNode >>= stash mvNid >> (expect :: Process ())
254251

252+
pid <- splinchLogger node2 mvNid
255253
nid <- liftIO $ takeMVar mvNid
256254
mref <- monitor pid
257255
observedPid <- liftIO $ newEmptyMVar
@@ -291,6 +289,17 @@ testRemoteTraceRelay TestTransport{..} result =
291289
-- and just to be polite...
292290
liftIO $ closeLocalNode node2
293291

292+
where
293+
splinchLogger n2 mv = do
294+
mLog <- whereis "logger"
295+
case mLog of
296+
Nothing -> die "no logger registered"
297+
Just log' -> do liftIO $ forkProcess n2 $ do
298+
logRelay <- spawnLocal $ relay log'
299+
reregister "logger" logRelay
300+
getSelfNode >>= stash mv >> (expect :: Process ())
301+
302+
294303
-- | Sets the value of an environment variable while executing the given IO
295304
-- computation and restores the preceeding value upon completion.
296305
withEnv :: String -> String -> IO a -> IO a
@@ -319,9 +328,12 @@ testSystemLoggerMsg t action interestingMessage =
319328
-- Wait for the trace message.
320329
receiveWait [ matchIf interestingMessage' $ const $ return () ]
321330
-- Only one interesting message should arrive.
322-
Nothing <- receiveTimeout 100000
323-
[ matchIf interestingMessage' $ const $ return () ]
324-
return ()
331+
expectedTimeout <- receiveTimeout
332+
100000
333+
[ matchIf interestingMessage' $ const $ return () ]
334+
case expectedTimeout of
335+
Nothing -> return ()
336+
Just _ -> die "Unexpected message arrived..."
325337

326338

327339
-- | Tests that one and only one trace message is produced when a message is

‎src/Control/Distributed/Process/Internal/Primitives.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -400,8 +400,10 @@ newtype Match b = Match { unMatch :: MatchOn Message (Process b) }
400400
receiveWait :: [Match b] -> Process b
401401
receiveWait ms = do
402402
queue <- processQueue <$> ask
403-
Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)
404-
proc
403+
mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)
404+
case mProc of
405+
Just proc' -> proc'
406+
Nothing -> error "Well... That wasn't supposed to happen! o_O"
405407

406408
-- | Like 'receiveWait' but with a timeout.
407409
--

‎src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ import Control.Distributed.Process.Internal.Primitives
3333
( whereis
3434
, newChan
3535
, receiveChan
36+
, die
3637
)
3738
import Control.Distributed.Process.Management.Internal.Trace.Types
3839
( TraceArg(..)
@@ -168,6 +169,10 @@ withRegisteredTracer act = do
168169
withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp
169170
currentTracer <- receiveChan rp
170171
case currentTracer of
171-
Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }
172+
Nothing -> do mTP <- whereis "tracer.initial"
173+
-- NB: this should NOT ever happen, but forcing pattern matches
174+
-- is not considered cool in later versions of MonadFail
175+
case mTP of
176+
Just p' -> act p'
177+
Nothing -> die "Initial Tracer Name Not Registered"
172178
(Just p) -> act p
173-

0 commit comments

Comments
 (0)