Skip to content

Commit 44e48bb

Browse files
cootcoot
committed
io-classes: removed default implementations for MonadSTM
They are exported and reused in `io-sim`.
1 parent 8099faf commit 44e48bb

File tree

3 files changed

+106
-186
lines changed

3 files changed

+106
-186
lines changed

‎io-classes/src/Control/Monad/Class/MonadMVar.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,8 @@
55

66
module Control.Monad.Class.MonadMVar
77
( MonadMVar (..)
8+
-- * Default implementation
9+
-- $default-implementation
810
, MVarDefault
911
, newEmptyMVarDefault
1012
, newMVarDefault
@@ -163,6 +165,13 @@ instance MonadMVar IO where
163165
modifyMVarMasked_ = IO.modifyMVarMasked_
164166
modifyMVarMasked = IO.modifyMVarMasked
165167

168+
--
169+
-- Default implementation
170+
--
171+
--
172+
-- $default-implementation
173+
-- The default implementation is tailored towards pure monads, e.g. `IOSim`.
174+
--
166175

167176
data MVarState m a = MVarEmpty !(Deque (TVar m (Maybe a))) -- ^ blocked on take
168177
| MVarFull a !(Deque (a, TVar m Bool)) -- ^ blocked on put

‎io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs

Lines changed: 69 additions & 186 deletions
Original file line numberDiff line numberDiff line change
@@ -28,23 +28,83 @@ module Control.Monad.Class.MonadSTM.Internal
2828
, MonadInspectSTM (..)
2929
, TraceValue (TraceValue, TraceDynamic, TraceString, DontTrace, traceDynamic, traceString)
3030
, MonadTraceSTM (..)
31-
-- * Default 'TMVar' implementation
31+
-- * MonadThrow aliases
32+
, throwSTM
33+
, catchSTM
34+
-- * Default implementations
35+
-- $default-implementations
36+
--
37+
-- ** Default 'TMVar' implementation
3238
, TMVarDefault (..)
33-
-- * Default 'TBQueue' implementation
39+
, newTMVarDefault
40+
, newEmptyTMVarDefault
41+
, takeTMVarDefault
42+
, tryTakeTMVarDefault
43+
, putTMVarDefault
44+
, tryPutTMVarDefault
45+
, readTMVarDefault
46+
, tryReadTMVarDefault
47+
, swapTMVarDefault
48+
, isEmptyTMVarDefault
49+
, labelTMVarDefault
50+
, traceTMVarDefault
51+
-- ** Default 'TBQueue' implementation
3452
, TQueueDefault (..)
35-
-- * Default 'TBQueue' implementation
53+
, newTQueueDefault
54+
, writeTQueueDefault
55+
, readTQueueDefault
56+
, tryReadTQueueDefault
57+
, isEmptyTQueueDefault
58+
, peekTQueueDefault
59+
, tryPeekTQueueDefault
60+
, flushTQueueDefault
61+
, unGetTQueueDefault
62+
, labelTQueueDefault
63+
-- ** Default 'TBQueue' implementation
3664
, TBQueueDefault (..)
37-
-- * Default 'TArray' implementation
65+
, newTBQueueDefault
66+
, writeTBQueueDefault
67+
, readTBQueueDefault
68+
, tryReadTBQueueDefault
69+
, peekTBQueueDefault
70+
, tryPeekTBQueueDefault
71+
, isEmptyTBQueueDefault
72+
, isFullTBQueueDefault
73+
, lengthTBQueueDefault
74+
, flushTBQueueDefault
75+
, unGetTBQueueDefault
76+
, labelTBQueueDefault
77+
-- ** Default 'TArray' implementation
3878
, TArrayDefault (..)
39-
-- * Default 'TSem' implementation
79+
-- ** Default 'TSem' implementation
4080
, TSemDefault (..)
41-
-- * Default 'TChan' implementation
81+
, newTSemDefault
82+
, waitTSemDefault
83+
, signalTSemDefault
84+
, signalTSemNDefault
85+
, labelTSemDefault
86+
-- ** Default 'TChan' implementation
4287
, TChanDefault (..)
43-
-- * MonadThrow aliases
44-
, throwSTM
45-
, catchSTM
88+
, newTChanDefault
89+
, newBroadcastTChanDefault
90+
, writeTChanDefault
91+
, readTChanDefault
92+
, tryReadTChanDefault
93+
, peekTChanDefault
94+
, tryPeekTChanDefault
95+
, dupTChanDefault
96+
, unGetTChanDefault
97+
, isEmptyTChanDefault
98+
, cloneTChanDefault
99+
, labelTChanDefault
46100
) where
47101

102+
-- $default-implementations
103+
--
104+
-- The default implementations are based on a `TVar` defined in the class. They
105+
-- are tailored towards `IOSim` rather than instances which would like to derive
106+
-- from `IO` or monad transformers.
107+
48108
import Prelude hiding (read)
49109

50110
import qualified Control.Concurrent.STM.TArray as STM
@@ -192,14 +252,6 @@ class (Monad m, Monad (STM m)) => MonadSTM m where
192252
-- default implementations
193253
--
194254

195-
default newTMVar :: TMVar m ~ TMVarDefault m
196-
=> a -> STM m (TMVar m a)
197-
newTMVar = newTMVarDefault
198-
199-
default newEmptyTMVar :: TMVar m ~ TMVarDefault m
200-
=> STM m (TMVar m a)
201-
newEmptyTMVar = newEmptyTMVarDefault
202-
203255
newTVarIO = atomically . newTVar
204256
readTVarIO = atomically . readTVar
205257
newTMVarIO = atomically . newTMVar
@@ -209,175 +261,6 @@ class (Monad m, Monad (STM m)) => MonadSTM m where
209261
newTChanIO = atomically newTChan
210262
newBroadcastTChanIO = atomically newBroadcastTChan
211263

212-
default takeTMVar :: TMVar m ~ TMVarDefault m
213-
=> TMVar m a -> STM m a
214-
takeTMVar = takeTMVarDefault
215-
216-
default tryTakeTMVar :: TMVar m ~ TMVarDefault m
217-
=> TMVar m a -> STM m (Maybe a)
218-
tryTakeTMVar = tryTakeTMVarDefault
219-
220-
default putTMVar :: TMVar m ~ TMVarDefault m => TMVar m a -> a -> STM m ()
221-
putTMVar = putTMVarDefault
222-
223-
default tryPutTMVar :: TMVar m ~ TMVarDefault m => TMVar m a -> a -> STM m Bool
224-
tryPutTMVar = tryPutTMVarDefault
225-
226-
default readTMVar :: TMVar m ~ TMVarDefault m
227-
=> TMVar m a -> STM m a
228-
readTMVar = readTMVarDefault
229-
230-
default tryReadTMVar :: TMVar m ~ TMVarDefault m
231-
=> TMVar m a -> STM m (Maybe a)
232-
tryReadTMVar = tryReadTMVarDefault
233-
234-
default swapTMVar :: TMVar m ~ TMVarDefault m
235-
=> TMVar m a -> a -> STM m a
236-
swapTMVar = swapTMVarDefault
237-
238-
default isEmptyTMVar :: TMVar m ~ TMVarDefault m
239-
=> TMVar m a -> STM m Bool
240-
isEmptyTMVar = isEmptyTMVarDefault
241-
242-
default newTQueue :: TQueue m ~ TQueueDefault m
243-
=> STM m (TQueue m a)
244-
newTQueue = newTQueueDefault
245-
246-
default writeTQueue :: TQueue m ~ TQueueDefault m
247-
=> TQueue m a -> a -> STM m ()
248-
writeTQueue = writeTQueueDefault
249-
250-
default readTQueue :: TQueue m ~ TQueueDefault m
251-
=> TQueue m a -> STM m a
252-
readTQueue = readTQueueDefault
253-
254-
default tryReadTQueue :: TQueue m ~ TQueueDefault m
255-
=> TQueue m a -> STM m (Maybe a)
256-
tryReadTQueue = tryReadTQueueDefault
257-
258-
default isEmptyTQueue :: TQueue m ~ TQueueDefault m
259-
=> TQueue m a -> STM m Bool
260-
isEmptyTQueue = isEmptyTQueueDefault
261-
262-
default unGetTQueue :: TQueue m ~ TQueueDefault m
263-
=> TQueue m a -> a -> STM m ()
264-
unGetTQueue = unGetTQueueDefault
265-
266-
default peekTQueue :: TQueue m ~ TQueueDefault m
267-
=> TQueue m a -> STM m a
268-
peekTQueue = peekTQueueDefault
269-
270-
default tryPeekTQueue :: TQueue m ~ TQueueDefault m
271-
=> TQueue m a -> STM m (Maybe a)
272-
tryPeekTQueue = tryPeekTQueueDefault
273-
274-
default flushTQueue :: TQueue m ~ TQueueDefault m
275-
=> TQueue m a -> STM m [a]
276-
flushTQueue = flushTQueueDefault
277-
278-
default newTBQueue :: TBQueue m ~ TBQueueDefault m
279-
=> Natural -> STM m (TBQueue m a)
280-
newTBQueue = newTBQueueDefault
281-
282-
default writeTBQueue :: TBQueue m ~ TBQueueDefault m
283-
=> TBQueue m a -> a -> STM m ()
284-
writeTBQueue = writeTBQueueDefault
285-
286-
default readTBQueue :: TBQueue m ~ TBQueueDefault m
287-
=> TBQueue m a -> STM m a
288-
readTBQueue = readTBQueueDefault
289-
290-
default tryReadTBQueue :: TBQueue m ~ TBQueueDefault m
291-
=> TBQueue m a -> STM m (Maybe a)
292-
tryReadTBQueue = tryReadTBQueueDefault
293-
294-
default isEmptyTBQueue :: TBQueue m ~ TBQueueDefault m
295-
=> TBQueue m a -> STM m Bool
296-
isEmptyTBQueue = isEmptyTBQueueDefault
297-
298-
default peekTBQueue :: TBQueue m ~ TBQueueDefault m
299-
=> TBQueue m a -> STM m a
300-
peekTBQueue = peekTBQueueDefault
301-
302-
default tryPeekTBQueue :: TBQueue m ~ TBQueueDefault m
303-
=> TBQueue m a -> STM m (Maybe a)
304-
tryPeekTBQueue = tryPeekTBQueueDefault
305-
306-
default isFullTBQueue :: TBQueue m ~ TBQueueDefault m
307-
=> TBQueue m a -> STM m Bool
308-
isFullTBQueue = isFullTBQueueDefault
309-
310-
default lengthTBQueue :: TBQueue m ~ TBQueueDefault m
311-
=> TBQueue m a -> STM m Natural
312-
lengthTBQueue = lengthTBQueueDefault
313-
314-
default flushTBQueue :: TBQueue m ~ TBQueueDefault m
315-
=> TBQueue m a -> STM m [a]
316-
flushTBQueue = flushTBQueueDefault
317-
318-
default unGetTBQueue :: TBQueue m ~ TBQueueDefault m
319-
=> TBQueue m a -> a -> STM m ()
320-
unGetTBQueue = unGetTBQueueDefault
321-
322-
default newTSem :: TSem m ~ TSemDefault m
323-
=> Integer -> STM m (TSem m)
324-
newTSem = newTSemDefault
325-
326-
default waitTSem :: TSem m ~ TSemDefault m
327-
=> TSem m -> STM m ()
328-
waitTSem = waitTSemDefault
329-
330-
default signalTSem :: TSem m ~ TSemDefault m
331-
=> TSem m -> STM m ()
332-
signalTSem = signalTSemDefault
333-
334-
default signalTSemN :: TSem m ~ TSemDefault m
335-
=> Natural -> TSem m -> STM m ()
336-
signalTSemN = signalTSemNDefault
337-
338-
default newTChan :: TChan m ~ TChanDefault m
339-
=> STM m (TChan m a)
340-
newTChan = newTChanDefault
341-
342-
default newBroadcastTChan :: TChan m ~ TChanDefault m
343-
=> STM m (TChan m a)
344-
newBroadcastTChan = newBroadcastTChanDefault
345-
346-
default writeTChan :: TChan m ~ TChanDefault m
347-
=> TChan m a -> a -> STM m ()
348-
writeTChan = writeTChanDefault
349-
350-
default readTChan :: TChan m ~ TChanDefault m
351-
=> TChan m a -> STM m a
352-
readTChan = readTChanDefault
353-
354-
default tryReadTChan :: TChan m ~ TChanDefault m
355-
=> TChan m a -> STM m (Maybe a)
356-
tryReadTChan = tryReadTChanDefault
357-
358-
default peekTChan :: TChan m ~ TChanDefault m
359-
=> TChan m a -> STM m a
360-
peekTChan = peekTChanDefault
361-
362-
default tryPeekTChan :: TChan m ~ TChanDefault m
363-
=> TChan m a -> STM m (Maybe a)
364-
tryPeekTChan = tryPeekTChanDefault
365-
366-
default dupTChan :: TChan m ~ TChanDefault m
367-
=> TChan m a -> STM m (TChan m a)
368-
dupTChan = dupTChanDefault
369-
370-
default unGetTChan :: TChan m ~ TChanDefault m
371-
=> TChan m a -> a -> STM m ()
372-
unGetTChan = unGetTChanDefault
373-
374-
default isEmptyTChan :: TChan m ~ TChanDefault m
375-
=> TChan m a -> STM m Bool
376-
isEmptyTChan = isEmptyTChanDefault
377-
378-
default cloneTChan :: TChan m ~ TChanDefault m
379-
=> TChan m a -> STM m (TChan m a)
380-
cloneTChan = cloneTChanDefault
381264

382265

383266
stateTVarDefault :: MonadSTM m => TVar m s -> (s -> (a, s)) -> STM m a

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

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -491,6 +491,17 @@ instance MonadSTM (IOSim s) where
491491
retry = STM $ oneShot $ \_ -> Retry
492492
orElse a b = STM $ oneShot $ \k -> OrElse (runSTM a) (runSTM b) k
493493

494+
newTMVar = MonadSTM.newTMVarDefault
495+
newEmptyTMVar = MonadSTM.newEmptyTMVarDefault
496+
takeTMVar = MonadSTM.takeTMVarDefault
497+
tryTakeTMVar = MonadSTM.tryTakeTMVarDefault
498+
putTMVar = MonadSTM.putTMVarDefault
499+
tryPutTMVar = MonadSTM.tryPutTMVarDefault
500+
readTMVar = MonadSTM.readTMVarDefault
501+
tryReadTMVar = MonadSTM.tryReadTMVarDefault
502+
swapTMVar = MonadSTM.swapTMVarDefault
503+
isEmptyTMVar = MonadSTM.isEmptyTMVarDefault
504+
494505
newTQueue = newTQueueDefault
495506
readTQueue = readTQueueDefault
496507
tryReadTQueue = tryReadTQueueDefault
@@ -513,6 +524,23 @@ instance MonadSTM (IOSim s) where
513524
isFullTBQueue = isFullTBQueueDefault
514525
unGetTBQueue = unGetTBQueueDefault
515526

527+
newTSem = MonadSTM.newTSemDefault
528+
waitTSem = MonadSTM.waitTSemDefault
529+
signalTSem = MonadSTM.signalTSemDefault
530+
signalTSemN = MonadSTM.signalTSemNDefault
531+
532+
newTChan = MonadSTM.newTChanDefault
533+
newBroadcastTChan = MonadSTM.newBroadcastTChanDefault
534+
writeTChan = MonadSTM.writeTChanDefault
535+
readTChan = MonadSTM.readTChanDefault
536+
tryReadTChan = MonadSTM.tryReadTChanDefault
537+
peekTChan = MonadSTM.peekTChanDefault
538+
tryPeekTChan = MonadSTM.tryPeekTChanDefault
539+
dupTChan = MonadSTM.dupTChanDefault
540+
unGetTChan = MonadSTM.unGetTChanDefault
541+
isEmptyTChan = MonadSTM.isEmptyTChanDefault
542+
cloneTChan = MonadSTM.cloneTChanDefault
543+
516544
instance MonadInspectSTM (IOSim s) where
517545
type InspectMonad (IOSim s) = ST s
518546
inspectTVar _ TVar { tvarCurrent } = readSTRef tvarCurrent

0 commit comments

Comments
 (0)