Skip to content

Commit 0611cb0

Browse files
MaximilianAlgehedcoot
MaximilianAlgehed
authored and
coot
committed
Some style-guide refactoring
1 parent aa8916e commit 0611cb0

File tree

4 files changed

+154
-79
lines changed

4 files changed

+154
-79
lines changed

‎io-sim/src/Control/Monad/IOSim/Internal.hs

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,6 @@
1414
{-# LANGUAGE RankNTypes #-}
1515
{-# LANGUAGE ScopedTypeVariables #-}
1616
{-# LANGUAGE TypeFamilies #-}
17-
{-# LANGUAGE RecordWildCards #-}
1817

1918
{-# OPTIONS_GHC -Wno-orphans #-}
2019
-- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted')
@@ -507,10 +506,10 @@ schedule !thread@Thread{
507506
let result | Just r <- Map.lookup tid' finished = reasonToStatus r
508507
| Just t <- Map.lookup tid' threads = threadStatus t
509508
| otherwise = error "The impossible happened - tried to loookup thread in state."
510-
reasonToStatus FinishedNormally = ThreadFinished
511-
reasonToStatus FinishedDied = ThreadDied
512-
threadStatus Thread{..} | threadBlocked = ThreadBlocked BlockedOnOther
513-
| otherwise = ThreadRunning
509+
reasonToStatus FinishedNormally = ThreadFinished
510+
reasonToStatus FinishedDied = ThreadDied
511+
threadStatus t | threadBlocked t = ThreadBlocked BlockedOnOther
512+
| otherwise = ThreadRunning
514513

515514
thread' = thread { threadControl = ThreadControl (k result) ctl }
516515
schedule thread' simstate

‎io-sim/src/Control/Monad/IOSimPOR/Internal.hs

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,6 @@
1616
{-# LANGUAGE StandaloneDeriving #-}
1717
{-# LANGUAGE TypeApplications #-}
1818
{-# LANGUAGE TypeFamilies #-}
19-
{-# LANGUAGE RecordWildCards #-}
2019

2120
{-# OPTIONS_GHC -Wno-orphans #-}
2221
-- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted')
@@ -365,10 +364,11 @@ schedule thread@Thread{
365364
let reason = if thrower == ThrowSelf then FinishedNormally else FinishedDied
366365
thread' = thread { threadEffect = effect <> statusWriteEffect tid
367366
}
368-
!trace <- deschedule (Terminated reason) thread' simstate
367+
terminated = Terminated reason
368+
!trace <- deschedule terminated thread' simstate
369369
return $ SimPORTrace time tid tstep tlbl (EventThrow e)
370370
$ SimPORTrace time tid tstep tlbl (EventThreadUnhandled e)
371-
$ SimPORTrace time tid tstep tlbl (EventDeschedule $ Terminated reason)
371+
$ SimPORTrace time tid tstep tlbl (EventDeschedule terminated)
372372
$ trace
373373

374374
Catch action' handler k -> do
@@ -528,9 +528,9 @@ schedule thread@Thread{
528528
thread' = thread { threadControl = ThreadControl (k tid') ctl,
529529
threadNextTId = nextTId + 1,
530530
threadEffect = effect
531-
<> forkEffect tid'
532-
<> statusWriteEffect tid'
533-
<> statusWriteEffect tid
531+
<> forkEffect tid'
532+
<> statusWriteEffect tid'
533+
<> statusWriteEffect tid
534534
}
535535
thread'' = Thread { threadId = tid'
536536
, threadControl = ThreadControl (runIOSim a)
@@ -646,10 +646,10 @@ schedule thread@Thread{
646646
| Just (_, c) <- Map.lookup tid' finished = c
647647
| tid' == tid = vClock
648648
| otherwise = error "The impossible happened"
649-
reasonToStatus FinishedNormally = ThreadFinished
650-
reasonToStatus FinishedDied = ThreadDied
651-
threadStatus Thread{..} | threadBlocked = ThreadBlocked BlockedOnOther
652-
| otherwise = ThreadRunning
649+
reasonToStatus FinishedNormally = ThreadFinished
650+
reasonToStatus FinishedDied = ThreadDied
651+
threadStatus t | threadBlocked t = ThreadBlocked BlockedOnOther
652+
| otherwise = ThreadRunning
653653

654654
thread' = thread { threadControl = ThreadControl (k result) ctl
655655
, threadVClock = vClock `leastUpperBoundVClock` otherVClock

‎io-sim/test/Test/Control/Monad/IOSimPOR.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,6 @@ import Data.List
2828
import Data.Map (Map)
2929
import qualified Data.Map as Map
3030
import Test.QuickCheck
31-
import qualified Debug.Trace as Debug
3231

3332
data Step =
3433
WhenSet Int Int

‎io-sim/test/Test/IOSim.hs

Lines changed: 140 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -146,26 +146,45 @@ tests =
146146
, testProperty "lazy" prop_mfix_lazy
147147
, testProperty "recdata" prop_mfix_recdata
148148
]
149-
-- NOTE: Most of the tests below only work because the io-sim scheduler works the way it does.
149+
-- NOTE: Most of the tests below only work because the io-sim
150+
-- scheduler works the way it does.
150151
, testGroup "ThreadStatus"
151-
[ testProperty "thread status finished (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_finished
152-
, testProperty "thread status finished (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_finished
153-
, testProperty "thread status running (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_running
154-
, testProperty "thread status running (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_running
155-
, testProperty "thread status blocked (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_blocked
156-
, testProperty "thread status blocked (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_blocked
157-
, testProperty "thread status blocked delay (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_blocked_delay
158-
, testProperty "thread status blocked delay (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_blocked_delay
159-
, testProperty "thread status died (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_died
160-
, testProperty "thread status died (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_died
161-
, testProperty "thread status died_own (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_died_own
162-
, testProperty "thread status died_own (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_died_own
163-
, testProperty "thread status yield (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_yield
164-
, testProperty "thread status yield (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_yield
165-
, testProperty "thread status mask (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_mask
166-
, testProperty "thread status mask (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_mask
167-
, testProperty "thread status mask blocked (IOSim)" $ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_mask_blocked
168-
, testProperty "thread status mask blocked (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_mask_blocked
152+
[ testProperty "thread status finished (IOSim)"
153+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_finished
154+
, testProperty "thread status finished (IO)"
155+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_finished
156+
, testProperty "thread status running (IOSim)"
157+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_running
158+
, testProperty "thread status running (IO)"
159+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_running
160+
, testProperty "thread status blocked (IOSim)"
161+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_blocked
162+
, testProperty "thread status blocked (IO)"
163+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_blocked
164+
, testProperty "thread status blocked delay (IOSim)"
165+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_blocked_delay
166+
, testProperty "thread status blocked delay (IO)"
167+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_blocked_delay
168+
, testProperty "thread status died (IOSim)"
169+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_died
170+
, testProperty "thread status died (IO)"
171+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_died
172+
, testProperty "thread status died_own (IOSim)"
173+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_died_own
174+
, testProperty "thread status died_own (IO)"
175+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_died_own
176+
, testProperty "thread status yield (IOSim)"
177+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_yield
178+
, testProperty "thread status yield (IO)"
179+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_yield
180+
, testProperty "thread status mask (IOSim)"
181+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_mask
182+
, testProperty "thread status mask (IO)"
183+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_mask
184+
, testProperty "thread status mask blocked (IOSim)"
185+
$ withMaxSuccess 1 $ runSimOrThrow prop_thread_status_mask_blocked
186+
, testProperty "thread status mask blocked (IO)"
187+
$ withMaxSuccess 1 $ ioProperty prop_thread_status_mask_blocked
169188
]
170189
]
171190

@@ -188,65 +207,117 @@ prop_two_threads_expect_ :: (MonadFork m, MonadThread m)
188207
=> m ()
189208
-> (ThreadStatus -> Property)
190209
-> m Property
191-
prop_two_threads_expect_ target prop = prop_two_threads_expect target (const $ yield) prop
210+
prop_two_threads_expect_ target prop =
211+
prop_two_threads_expect target
212+
(const $ yield)
213+
prop
192214

193-
prop_thread_status_finished :: (MonadFork m, MonadDelay m, MonadThread m) => m Property
215+
prop_thread_status_finished :: (MonadFork m, MonadDelay m, MonadThread m)
216+
=> m Property
194217
prop_thread_status_finished =
195218
prop_two_threads_expect_ (pure ())
196219
(ThreadFinished ===)
197220

198-
prop_thread_status_running :: (MonadFork m, MonadDelay m, MonadThread m) => m Property
221+
prop_thread_status_running :: (MonadFork m, MonadDelay m, MonadThread m)
222+
=> m Property
199223
prop_thread_status_running =
200224
prop_two_threads_expect_ (forever yield)
201225
(ThreadRunning ===)
202226

203-
prop_thread_status_blocked :: (MonadFork m, MonadDelay m, MonadThread m, MonadSTM m) => m Property
227+
prop_thread_status_blocked :: ( MonadFork m
228+
, MonadDelay m
229+
, MonadThread m
230+
, MonadSTM m
231+
)
232+
=> m Property
204233
prop_thread_status_blocked = do
205234
var <- newEmptyTMVarIO
206-
prop_two_threads_expect_ (atomically $ takeTMVar var)
207-
$ \ status -> case status of
208-
ThreadBlocked _ -> property True
209-
_ -> counterexample (show status ++ " /= ThreadBlocked _") False
210-
211-
prop_thread_status_blocked_delay :: (MonadFork m, MonadDelay m, MonadThread m) => m Property
235+
prop_two_threads_expect_
236+
(atomically $ takeTMVar var)
237+
$ \ status -> case status of
238+
ThreadBlocked _ -> property True
239+
_ ->
240+
counterexample (show status ++ " /= ThreadBlocked _")
241+
False
242+
243+
prop_thread_status_blocked_delay :: (MonadFork m, MonadDelay m, MonadThread m)
244+
=> m Property
212245
prop_thread_status_blocked_delay =
213-
prop_two_threads_expect_ (threadDelay 1)
214-
$ \ status -> case status of
215-
ThreadBlocked _ -> property True
216-
_ -> counterexample (show status ++ " /= ThreadBlocked _") False
217-
218-
prop_thread_status_died :: (MonadFork m, MonadThrow m, MonadDelay m, MonadThread m) => m Property
246+
prop_two_threads_expect_
247+
(threadDelay 1)
248+
$ \ status -> case status of
249+
ThreadBlocked _ -> property True
250+
_ ->
251+
counterexample (show status ++ " /= ThreadBlocked _")
252+
False
253+
254+
prop_thread_status_died :: ( MonadFork m
255+
, MonadThrow m
256+
, MonadDelay m
257+
, MonadThread m
258+
)
259+
=> m Property
219260
prop_thread_status_died =
220261
prop_two_threads_expect (forever yield)
221262
(\tid -> do throwTo tid DivideByZero; yield)
222263
(ThreadDied ===)
223264

224-
prop_thread_status_died_own :: (MonadFork m, MonadThrow m, MonadDelay m, MonadThread m) => m Property
265+
prop_thread_status_died_own :: ( MonadFork m
266+
, MonadThrow m
267+
, MonadDelay m
268+
, MonadThread m
269+
)
270+
=> m Property
225271
prop_thread_status_died_own = do
226272
prop_two_threads_expect_ (throwIO DivideByZero)
227273
(ThreadFinished ===)
228274

229-
prop_thread_status_yield :: (MonadFork m, MonadThrow m, MonadDelay m, MonadThread m, MonadSTM m) => m Property
275+
prop_thread_status_yield :: ( MonadFork m
276+
, MonadThrow m
277+
, MonadDelay m
278+
, MonadThread m
279+
, MonadSTM m
280+
)
281+
=> m Property
230282
prop_thread_status_yield = do
231283
var <- newEmptyTMVarIO
232-
prop_two_threads_expect (do atomically (putTMVar var ()); forever yield)
233-
(const $ atomically (takeTMVar var))
234-
(ThreadRunning ===)
235-
236-
prop_thread_status_mask :: (MonadFork m, MonadThrow m, MonadDelay m, MonadThread m, MonadSTM m, MonadMask m) => m Property
284+
prop_two_threads_expect
285+
(do atomically (putTMVar var ()); forever yield)
286+
(const $ atomically (takeTMVar var))
287+
(ThreadRunning ===)
288+
289+
prop_thread_status_mask :: ( MonadFork m
290+
, MonadThrow m
291+
, MonadDelay m
292+
, MonadThread m
293+
, MonadSTM m
294+
, MonadMask m
295+
)
296+
=> m Property
237297
prop_thread_status_mask = do
238298
var <- newEmptyTMVarIO
239-
prop_two_threads_expect (mask_ (do atomically (putTMVar var ()); yield) >> forever yield)
240-
(\tid -> do atomically (takeTMVar var); throwTo tid DivideByZero; yield)
241-
(ThreadFinished ===)
242-
243-
prop_thread_status_mask_blocked :: (MonadFork m, MonadThrow m, MonadThread m, MonadMask m) => m Property
299+
prop_two_threads_expect
300+
(mask_ (do atomically (putTMVar var ()); yield) >> forever yield)
301+
(\tid -> do atomically (takeTMVar var)
302+
throwTo tid DivideByZero
303+
yield)
304+
(ThreadFinished ===)
305+
306+
prop_thread_status_mask_blocked :: ( MonadFork m
307+
, MonadThrow m
308+
, MonadThread m
309+
, MonadMask m
310+
)
311+
=> m Property
244312
prop_thread_status_mask_blocked = do
245313
helper <- forkIO $ mask_ (forever yield)
246-
prop_two_threads_expect_ (throwTo helper DivideByZero)
247-
$ \ status -> case status of
248-
ThreadBlocked _ -> property True
249-
_ -> counterexample (show status ++ " /= ThreadBlocked _") False
314+
prop_two_threads_expect_
315+
(throwTo helper DivideByZero)
316+
$ \ status -> case status of
317+
ThreadBlocked _ -> property True
318+
_ ->
319+
counterexample (show status ++ " /= ThreadBlocked _")
320+
False
250321

251322
--
252323
-- Read/Write graph
@@ -367,12 +438,13 @@ test_timers xs =
367438
countUnique [] = 0
368439
countUnique (a:as) =
369440
let as' = filter (== a) as
370-
in 1 + countUnique as'
441+
in 1 + countUnique as'
371442

372443
lbl :: Eq a => [a] -> String
373444
lbl as =
374-
let p = (if null as then 0 else (100 * countUnique as) `div` length as) `mod` 10 * 10
375-
in show p ++ "% unique"
445+
let p = (if null as then 0 else (100 * countUnique as) `div` length as)
446+
`mod` 10 * 10
447+
in show p ++ "% unique"
376448

377449
experiment :: Probe m (DiffTime, Int) -> m ()
378450
experiment p = do
@@ -399,7 +471,7 @@ test_timers xs =
399471
sortFn :: DiffTime -> DiffTime -> Ordering
400472
sortFn a b | a >= 0 && b >= 0 = a `compare` b
401473
| a < 0 && b < 0 = EQ
402-
| otherwise = a `compare` b
474+
| otherwise = a `compare` b
403475

404476
prop_timers_ST :: TestMicro -> Property
405477
prop_timers_ST (TestMicro xs) =
@@ -450,12 +522,12 @@ prop_fork_order_IO = ioProperty . test_fork_order
450522

451523

452524
test_threadId_order :: forall m.
453-
( MonadFork m
454-
, MonadSTM m
455-
, MonadTimer m
456-
)
457-
=> Positive Int
458-
-> m Property
525+
( MonadFork m
526+
, MonadSTM m
527+
, MonadTimer m
528+
)
529+
=> Positive Int
530+
-> m Property
459531
test_threadId_order = \(Positive n) -> do
460532
isValid n <$> (forM [1..n] (const experiment))
461533
where
@@ -490,7 +562,7 @@ test_wakeup_order :: ( MonadFork m
490562
, MonadSTM m
491563
, MonadTimer m
492564
)
493-
=> m Property
565+
=> m Property
494566
test_wakeup_order = do
495567
v <- newTVarIO False
496568
wakupOrder <-
@@ -1154,7 +1226,12 @@ prop_stm_referenceM (SomeTerm _tyrep t) = do
11541226
-- | Check that 'timeout' does not deadlock when executed with asynchronous
11551227
-- exceptions uninterruptibly masked.
11561228
--
1157-
prop_timeout_no_deadlockM :: forall m. ( MonadFork m, MonadSTM m, MonadTimer m, MonadMask m )
1229+
prop_timeout_no_deadlockM :: forall m.
1230+
( MonadFork m
1231+
, MonadSTM m
1232+
, MonadTimer m
1233+
, MonadMask m
1234+
)
11581235
=> m Bool
11591236
prop_timeout_no_deadlockM = do
11601237
v <- registerDelay' 0.01

0 commit comments

Comments
 (0)