Skip to content

Commit d09bc0e

Browse files
cootcoot
committed
si-timers: added convenient type aliases
* MonadDelay * MonadTimer
1 parent 0731d6f commit d09bc0e

File tree

4 files changed

+33
-43
lines changed

4 files changed

+33
-43
lines changed

‎io-sim/test/Test/Control/Monad/Class/MonadMVar.hs

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,6 @@ putMVar_fairness_property
7979
( MonadAsync m
8080
, MonadDelay m
8181
, MonadMVar m
82-
, MonadMonotonicTime m
8382
)
8483
=> Int -- ^ number of threads
8584
-> m Bool
@@ -106,7 +105,6 @@ unit_putMVar_blocks_on_full
106105
:: ( MonadFork m
107106
, MonadDelay m
108107
, MonadMVar m
109-
, MonadMonotonicTime m
110108
)
111109
=> m Bool
112110
unit_putMVar_blocks_on_full = do
@@ -141,7 +139,6 @@ takeMVar_fairness_property
141139
( MonadAsync m
142140
, MonadDelay m
143141
, MonadMVar m
144-
, MonadMonotonicTime m
145142
, Eq (Async m Int)
146143
)
147144
=> Int -- ^ number of threads
@@ -164,7 +161,6 @@ unit_takeMVar_blocks_on_empty
164161
:: ( MonadFork m
165162
, MonadDelay m
166163
, MonadMVar m
167-
, MonadMonotonicTime m
168164
)
169165
=> m Bool
170166
unit_takeMVar_blocks_on_empty = do

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

Lines changed: 9 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -255,7 +255,6 @@ prop_thread_status_blocked = do
255255

256256
prop_thread_status_blocked_delay :: ( MonadFork m
257257
, MonadDelay m
258-
, MonadMonotonicTime m
259258
)
260259
=> m Property
261260
prop_thread_status_blocked_delay =
@@ -427,9 +426,8 @@ instance Arbitrary TestMicro where
427426
shrink (TestMicro rs) = [ TestMicro rs' | rs' <- shrinkList (const []) rs ]
428427

429428
test_timers :: forall m.
430-
( MonadFork m
429+
( MonadDelay m
431430
, MonadTimer m
432-
, MonadMonotonicTime m
433431
)
434432
=> [DiffTime]
435433
-> m Property
@@ -492,9 +490,7 @@ prop_timers_IO = ioProperty . test_timers
492490
--
493491

494492
test_fork_order :: forall m.
495-
( MonadFork m
496-
, MonadTimer m
497-
)
493+
MonadTimer m
498494
=> Positive Int
499495
-> m Property
500496
test_fork_order = \(Positive n) -> isValid n <$> withProbe (experiment n)
@@ -523,9 +519,7 @@ prop_fork_order_IO = ioProperty . test_fork_order
523519

524520

525521
test_threadId_order :: forall m.
526-
( MonadFork m
527-
, MonadTimer m
528-
)
522+
MonadTimer m
529523
=> Positive Int
530524
-> m Property
531525
test_threadId_order = \(Positive n) -> do
@@ -558,9 +552,8 @@ prop_wakeup_order_ST = runSimOrThrow $ test_wakeup_order
558552

559553
--prop_wakeup_order_IO = ioProperty test_wakeup_order
560554

561-
test_wakeup_order :: ( MonadFork m
555+
test_wakeup_order :: ( MonadDelay m
562556
, MonadTimer m
563-
, MonadMonotonicTime m
564557
)
565558
=> m Property
566559
test_wakeup_order = do
@@ -614,9 +607,7 @@ prop_mfix_purity_2 as =
614607
as' = getPositive `map` as
615608

616609
-- recursive sum using 'threadDelay'
617-
recDelay :: ( MonadMonotonicTime m
618-
, MonadDelay m
619-
)
610+
recDelay :: MonadDelay m
620611
=> ([Int] -> m Time)
621612
-> [Int] -> m Time
622613
recDelay = \rec_ bs ->
@@ -1247,10 +1238,9 @@ prop_stm_referenceM (SomeTerm _tyrep t) = do
12471238
-- exceptions uninterruptibly masked.
12481239
--
12491240
prop_timeout_no_deadlockM :: forall m.
1250-
( MonadFork m
1241+
( MonadDelay m
12511242
, MonadTimer m
12521243
, MonadMask m
1253-
, MonadMonotonicTime m
12541244
)
12551245
=> m Bool
12561246
prop_timeout_no_deadlockM = do
@@ -1450,9 +1440,8 @@ unit_catch_throwTo_masking_state_ST ms =
14501440
--
14511441
prop_catch_throwTo_masking_state_async :: forall m.
14521442
( MonadDelay m
1453-
, MonadFork m
1443+
, MonadFork m
14541444
, MonadMaskingState m
1455-
, MonadMonotonicTime m
14561445
, MonadSTM m
14571446
)
14581447
=> MaskingState -> m Property
@@ -1490,9 +1479,8 @@ unit_catch_throwTo_masking_state_async_ST ms =
14901479
--
14911480
prop_catch_throwTo_masking_state_async_mayblock :: forall m.
14921481
( MonadDelay m
1493-
, MonadFork m
1482+
, MonadFork m
14941483
, MonadMaskingState m
1495-
, MonadMonotonicTime m
14961484
, MonadSTM m
14971485
)
14981486
=> MaskingState -> m Property
@@ -1574,9 +1562,7 @@ prop_registerDelayCancellable (DelayWithCancel delay mbCancel) =
15741562
Left {} -> counterexample (ppTrace trace) False
15751563
Right r -> counterexample (ppTrace trace) r
15761564
where
1577-
sim :: ( MonadFork m
1578-
, MonadMonotonicTime m
1579-
, MonadTimeout m
1565+
sim :: ( MonadDelay m
15801566
, MonadTimer m
15811567
)
15821568
=> m Bool

‎si-timers/si-timers.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ library
4545
default-language: Haskell2010
4646
other-extensions: BangPatterns,
4747
CPP,
48+
ConstraintKinds,
4849
ExistentialQuantification,
4950
FlexibleInstances,
5051
GADTSyntax,

‎si-timers/src/Control/Monad/Class/MonadTimer/SI.hs

Lines changed: 23 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE ConstraintKinds #-}
12
{-# LANGUAGE NumericUnderscores #-}
23
{-# LANGUAGE ScopedTypeVariables #-}
34

@@ -7,17 +8,18 @@ module Control.Monad.Class.MonadTimer.SI
78
, registerDelay
89
, registerDelayCancellable
910
, timeout
11+
-- * Type classes
12+
, MonadDelay
13+
, MonadTimer
1014
-- * Auxiliary functions
1115
, diffTimeToMicrosecondsAsInt
1216
, microsecondsAsIntToDiffTime
1317
-- * Re-exports
1418
, DiffTime
15-
, MonadDelay
1619
, MonadFork
1720
, MonadMonotonicTime
1821
, MonadTime
1922
, MonadTimeout
20-
, MonadTimer
2123
, TimeoutState (..)
2224
) where
2325

@@ -26,7 +28,6 @@ import Control.Exception (assert)
2628
import Control.Monad (when)
2729
import Control.Monad.Class.MonadFork
2830
import Control.Monad.Class.MonadTime.SI
29-
import Control.Monad.Class.MonadTimer (MonadDelay, MonadTimer)
3031
import qualified Control.Monad.Class.MonadTimer as MonadTimer
3132
import Control.Monad.Class.MonadTimer.NonStandard
3233

@@ -53,16 +54,20 @@ diffTimeToMicrosecondsAsInt d =
5354
microsecondsAsIntToDiffTime :: Int -> DiffTime
5455
microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral
5556

57+
-- | This is a convenient type alias which captures constraints of
58+
-- `threadDelay`.
59+
--
60+
type MonadDelay m = ( MonadTimer.MonadDelay m
61+
, MonadMonotonicTime m
62+
)
5663

5764
-- | Thread delay. When the delay is smaller than what `Int` can represent it
5865
-- will use the `Control.Monad.Class.MonadTimer.threadDelay` (e.g. for the `IO`
5966
-- monad it will use `Control.Concurrent.threadDelay`); otherwise it will
6067
-- recursively call `Control.Monad.Class.MonadTimer.threadDelay`.
6168
--
6269
threadDelay :: forall m.
63-
( MonadDelay m
64-
, MonadMonotonicTime m
65-
)
70+
MonadDelay m
6671
=> DiffTime -> m ()
6772
threadDelay d | d <= maxDelay =
6873
MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d)
@@ -91,17 +96,22 @@ threadDelay d = do
9196
d' = u `diffTime` c
9297

9398

99+
-- | This is a convenient type alias which captures constraints of
100+
-- `registerDelay` and `registerDelayCancellable`.
101+
--
102+
type MonadTimer m = ( MonadFork m
103+
, MonadMonotonicTime m
104+
, MonadTimer.MonadTimer m
105+
, MonadTimeout m
106+
)
107+
94108
-- | Like 'GHC.Conc.registerDelay' but safe on 32-bit systems. When the delay
95109
-- is larger than what `Int` can represent it will fork a thread which will
96110
-- write to the returned 'TVar' once the delay has passed. When the delay is
97111
-- small enough it will use the `MonadTimer`'s `registerDelay` (e.g. for `IO`
98112
-- monad it will use the `GHC`'s `GHC.Conc.registerDelay`).
99113
--
100-
registerDelay :: ( MonadFork m
101-
, MonadMonotonicTime m
102-
, MonadTimeout m
103-
, MonadTimer m
104-
)
114+
registerDelay :: MonadTimer m
105115
=> DiffTime -> m (TVar m Bool)
106116
registerDelay d
107117
| d <= maxDelay =
@@ -151,10 +161,7 @@ defaultRegisterDelay d = do
151161
-- support native timer manager).
152162
--
153163
registerDelayCancellable :: forall m.
154-
( MonadFork m
155-
, MonadMonotonicTime m
156-
, MonadTimeout m
157-
)
164+
MonadTimer m
158165
=> DiffTime
159166
-> m (STM m TimeoutState, m ())
160167

@@ -221,5 +228,5 @@ registerDelayCancellable d = do
221228
-- | Run IO action within a timeout.
222229
--
223230
-- TODO: not safe on 32-bit systems.
224-
timeout :: MonadTimer m => DiffTime -> m a -> m (Maybe a)
231+
timeout :: MonadTimer.MonadTimer m => DiffTime -> m a -> m (Maybe a)
225232
timeout = MonadTimer.timeout . diffTimeToMicrosecondsAsInt

0 commit comments

Comments
 (0)