Skip to content

Commit 0dfb3ab

Browse files
cootcoot
committed
strict-stm: split into submodules
Added missing: * flushTBQueue
1 parent 2d70794 commit 0dfb3ab

File tree

10 files changed

+645
-574
lines changed

10 files changed

+645
-574
lines changed

‎io-classes/src/Control/Concurrent/Class/MonadSTM/TMVar.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,8 @@ module Control.Concurrent.Class.MonadSTM.TMVar
77
type TMVar
88
, newTMVar
99
, newEmptyTMVar
10+
, newTMVarIO
11+
, newEmptyTMVarIO
1012
, takeTMVar
1113
, tryTakeTMVar
1214
, putTMVar

‎strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict.hs

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
-- | This module corresponds to `Control.Concurrent.STM` in "stm" package
2+
--
3+
module Control.Concurrent.Class.MonadSTM.Strict
4+
(module STM)
5+
where
6+
7+
import Control.Monad.Class.MonadSTM as STM
8+
import Control.Concurrent.Class.MonadSTM.Strict.TVar as STM
9+
import Control.Concurrent.Class.MonadSTM.Strict.TMVar as STM
10+
import Control.Concurrent.Class.MonadSTM.Strict.TChan as STM
11+
import Control.Concurrent.Class.MonadSTM.Strict.TQueue as STM
12+
import Control.Concurrent.Class.MonadSTM.Strict.TBQueue as STM
13+
import Control.Concurrent.Class.MonadSTM.Strict.TArray as STM
14+
15+

‎strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs

Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE ExplicitNamespaces #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE MultiParamTypeClasses #-}
8+
{-# LANGUAGE UndecidableInstances #-}
9+
10+
-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package
11+
--
12+
module Control.Concurrent.Class.MonadSTM.Strict.TArray
13+
( StrictTArray
14+
, LazyTArray
15+
, toLazyTArray
16+
, fromLazyTArray
17+
) where
18+
19+
20+
import qualified Control.Concurrent.Class.MonadSTM.TArray as Lazy
21+
22+
import Data.Array.Base (MArray (..))
23+
24+
25+
type LazyTArray m = Lazy.TArray m
26+
27+
newtype StrictTArray m i e = StrictTArray { toLazyTArray :: LazyTArray m i e }
28+
29+
fromLazyTArray :: LazyTArray m i e -> StrictTArray m i e
30+
fromLazyTArray = StrictTArray
31+
32+
instance ( MArray (Lazy.TArray m) e stm
33+
, Monad stm
34+
)
35+
=> MArray (StrictTArray m) e stm where
36+
getBounds (StrictTArray arr) = getBounds arr
37+
newArray b !e = StrictTArray <$> newArray b e
38+
newArray_ b = StrictTArray <$> newArray_ b
39+
unsafeRead (StrictTArray arr) i = unsafeRead arr i
40+
unsafeWrite (StrictTArray arr) i !e = unsafeWrite arr i e
41+
getNumElements (StrictTArray arr) = getNumElements arr
42+

‎strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs

Lines changed: 101 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,101 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE ExplicitNamespaces #-}
4+
{-# LANGUAGE GADTs #-}
5+
6+
-- | This module corresponds to `Control.Concurrent.STM.TBQueue` in "stm" package
7+
--
8+
module Control.Concurrent.Class.MonadSTM.Strict.TBQueue
9+
( -- * MonadSTM
10+
StrictTBQueue
11+
, LazyTBQueue
12+
, toLazyTBQueue
13+
, fromLazyTBQueue
14+
, newTBQueue
15+
, newTBQueueIO
16+
, readTBQueue
17+
, tryReadTBQueue
18+
, peekTBQueue
19+
, tryPeekTBQueue
20+
, flushTBQueue
21+
, writeTBQueue
22+
, lengthTBQueue
23+
, isEmptyTBQueue
24+
, isFullTBQueue
25+
, unGetTBQueue
26+
-- * MonadLabelledSTM
27+
, labelTBQueue
28+
, labelTBQueueIO
29+
-- * MonadTraceSTM
30+
, traceTBQueue
31+
, traceTBQueueIO
32+
) where
33+
34+
35+
import qualified Control.Concurrent.Class.MonadSTM.TBQueue as Lazy
36+
import Control.Monad.Class.MonadSTM
37+
38+
import Numeric.Natural (Natural)
39+
40+
41+
type LazyTBQueue m = Lazy.TBQueue m
42+
43+
newtype StrictTBQueue m a = StrictTBQueue { toLazyTBQueue :: LazyTBQueue m a }
44+
45+
fromLazyTBQueue :: LazyTBQueue m a -> StrictTBQueue m a
46+
fromLazyTBQueue = StrictTBQueue
47+
48+
labelTBQueue :: MonadLabelledSTM m => StrictTBQueue m a -> String -> STM m ()
49+
labelTBQueue (StrictTBQueue queue) = Lazy.labelTBQueue queue
50+
51+
labelTBQueueIO :: MonadLabelledSTM m => StrictTBQueue m a -> String -> m ()
52+
labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue
53+
54+
traceTBQueue :: MonadTraceSTM m
55+
=> proxy m
56+
-> StrictTBQueue m a
57+
-> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
58+
-> STM m ()
59+
traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue
60+
61+
traceTBQueueIO :: MonadTraceSTM m
62+
=> StrictTBQueue m a
63+
-> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)
64+
-> m ()
65+
traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue
66+
67+
newTBQueue :: MonadSTM m => Natural -> STM m (StrictTBQueue m a)
68+
newTBQueue n = StrictTBQueue <$> Lazy.newTBQueue n
69+
70+
newTBQueueIO :: MonadSTM m => Natural -> m (StrictTBQueue m a)
71+
newTBQueueIO = atomically . newTBQueue
72+
73+
readTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a
74+
readTBQueue = Lazy.readTBQueue . toLazyTBQueue
75+
76+
tryReadTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a)
77+
tryReadTBQueue = Lazy.tryReadTBQueue . toLazyTBQueue
78+
79+
peekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a
80+
peekTBQueue = Lazy.peekTBQueue . toLazyTBQueue
81+
82+
tryPeekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a)
83+
tryPeekTBQueue = Lazy.tryPeekTBQueue . toLazyTBQueue
84+
85+
flushTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m [a]
86+
flushTBQueue = Lazy.flushTBQueue . toLazyTBQueue
87+
88+
writeTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m ()
89+
writeTBQueue (StrictTBQueue tqueue) !a = Lazy.writeTBQueue tqueue a
90+
91+
lengthTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Natural
92+
lengthTBQueue = Lazy.lengthTBQueue . toLazyTBQueue
93+
94+
isEmptyTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Bool
95+
isEmptyTBQueue = Lazy.isEmptyTBQueue . toLazyTBQueue
96+
97+
isFullTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Bool
98+
isFullTBQueue = Lazy.isFullTBQueue . toLazyTBQueue
99+
100+
unGetTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m ()
101+
unGetTBQueue (StrictTBQueue queue) !a = Lazy.unGetTBQueue queue a

‎strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs

Lines changed: 70 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,70 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE ExplicitNamespaces #-}
4+
{-# LANGUAGE GADTs #-}
5+
{-# LANGUAGE NamedFieldPuns #-}
6+
7+
-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package
8+
--
9+
module Control.Concurrent.Class.MonadSTM.Strict.TChan
10+
( StrictTChan
11+
, LazyTChan
12+
, toLazyTChan
13+
, fromLazyTChan
14+
, newTChan
15+
, newBroadcastTChan
16+
, writeTChan
17+
, readTChan
18+
, tryReadTChan
19+
, peekTChan
20+
, tryPeekTChan
21+
, dupTChan
22+
, unGetTChan
23+
, isEmptyTChan
24+
, cloneTChan
25+
) where
26+
27+
28+
import qualified Control.Concurrent.Class.MonadSTM.TChan as Lazy
29+
import Control.Monad.Class.MonadSTM
30+
31+
32+
type LazyTChan m = Lazy.TChan m
33+
34+
newtype StrictTChan m a = StrictTChan { toLazyTChan :: LazyTChan m a }
35+
36+
fromLazyTChan :: LazyTChan m a -> StrictTChan m a
37+
fromLazyTChan = StrictTChan
38+
39+
newTChan :: MonadSTM m => STM m (StrictTChan m a)
40+
newTChan = StrictTChan <$> Lazy.newTChan
41+
42+
newBroadcastTChan :: MonadSTM m => STM m (StrictTChan m a)
43+
newBroadcastTChan = StrictTChan <$> Lazy.newBroadcastTChan
44+
45+
writeTChan :: MonadSTM m => StrictTChan m a -> a -> STM m ()
46+
writeTChan (StrictTChan chan) !a = Lazy.writeTChan chan a
47+
48+
readTChan :: MonadSTM m => StrictTChan m a -> STM m a
49+
readTChan = Lazy.readTChan . toLazyTChan
50+
51+
tryReadTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a)
52+
tryReadTChan = Lazy.tryReadTChan . toLazyTChan
53+
54+
peekTChan :: MonadSTM m => StrictTChan m a -> STM m a
55+
peekTChan = Lazy.peekTChan . toLazyTChan
56+
57+
tryPeekTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a)
58+
tryPeekTChan = Lazy.tryPeekTChan . toLazyTChan
59+
60+
dupTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a)
61+
dupTChan = fmap fromLazyTChan . Lazy.dupTChan . toLazyTChan
62+
63+
unGetTChan :: MonadSTM m => StrictTChan m a -> a -> STM m ()
64+
unGetTChan (StrictTChan chan) !a = Lazy.unGetTChan chan a
65+
66+
isEmptyTChan :: MonadSTM m => StrictTChan m a -> STM m Bool
67+
isEmptyTChan = Lazy.isEmptyTChan . toLazyTChan
68+
69+
cloneTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a)
70+
cloneTChan = fmap fromLazyTChan . Lazy.cloneTChan . toLazyTChan

‎strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs

Lines changed: 120 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,120 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE ExplicitNamespaces #-}
4+
{-# LANGUAGE GADTs #-}
5+
6+
-- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package
7+
--
8+
module Control.Concurrent.Class.MonadSTM.Strict.TMVar
9+
( -- * StrictTMVar
10+
StrictTMVar
11+
, LazyTMVar
12+
, toLazyTMVar
13+
, fromLazyTMVar
14+
, castStrictTMVar
15+
, newTMVar
16+
, newEmptyTMVar
17+
, newTMVarIO
18+
, newEmptyTMVarIO
19+
, takeTMVar
20+
, tryTakeTMVar
21+
, putTMVar
22+
, tryPutTMVar
23+
, readTMVar
24+
, tryReadTMVar
25+
, swapTMVar
26+
, isEmptyTMVar
27+
-- * deprecated api
28+
, newTMVarM
29+
, newEmptyTMVarM
30+
-- * MonadLabelledSTM
31+
, labelTMVar
32+
, labelTMVarIO
33+
-- * MonadTraceSTM
34+
, traceTMVar
35+
, traceTMVarIO
36+
) where
37+
38+
39+
import qualified Control.Concurrent.Class.MonadSTM.TMVar as Lazy
40+
import Control.Monad.Class.MonadSTM
41+
42+
43+
type LazyTMVar m = Lazy.TMVar m
44+
45+
-- | 'TMVar' that keeps its value in WHNF at all times
46+
--
47+
-- Does not support an invariant: if the invariant would not be satisfied,
48+
-- we would not be able to put a value into an empty TMVar, which would lead
49+
-- to very hard to debug bugs where code is blocked indefinitely.
50+
newtype StrictTMVar m a = StrictTMVar { toLazyTMVar :: LazyTMVar m a }
51+
52+
fromLazyTMVar :: LazyTMVar m a -> StrictTMVar m a
53+
fromLazyTMVar = StrictTMVar
54+
55+
labelTMVar :: MonadLabelledSTM m => StrictTMVar m a -> String -> STM m ()
56+
labelTMVar (StrictTMVar tvar) = Lazy.labelTMVar tvar
57+
58+
labelTMVarIO :: MonadLabelledSTM m => StrictTMVar m a -> String -> m ()
59+
labelTMVarIO v = atomically . labelTMVar v
60+
61+
traceTMVar :: MonadTraceSTM m
62+
=> proxy m
63+
-> StrictTMVar m a
64+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
65+
-> STM m ()
66+
traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var
67+
68+
traceTMVarIO :: MonadTraceSTM m
69+
=> StrictTMVar m a
70+
-> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)
71+
-> m ()
72+
traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var
73+
74+
castStrictTMVar :: LazyTMVar m ~ LazyTMVar n
75+
=> StrictTMVar m a -> StrictTMVar n a
76+
castStrictTMVar (StrictTMVar var) = StrictTMVar var
77+
78+
newTMVar :: MonadSTM m => a -> STM m (StrictTMVar m a)
79+
newTMVar !a = StrictTMVar <$> Lazy.newTMVar a
80+
81+
newTMVarIO :: MonadSTM m => a -> m (StrictTMVar m a)
82+
newTMVarIO !a = StrictTMVar <$> Lazy.newTMVarIO a
83+
84+
newTMVarM :: MonadSTM m => a -> m (StrictTMVar m a)
85+
newTMVarM = newTMVarIO
86+
{-# DEPRECATED newTMVarM "Use newTVarIO" #-}
87+
88+
newEmptyTMVar :: MonadSTM m => STM m (StrictTMVar m a)
89+
newEmptyTMVar = StrictTMVar <$> Lazy.newEmptyTMVar
90+
91+
newEmptyTMVarIO :: MonadSTM m => m (StrictTMVar m a)
92+
newEmptyTMVarIO = StrictTMVar <$> Lazy.newEmptyTMVarIO
93+
94+
newEmptyTMVarM :: MonadSTM m => m (StrictTMVar m a)
95+
newEmptyTMVarM = newEmptyTMVarIO
96+
{-# DEPRECATED newEmptyTMVarM "Use newEmptyTMVarIO" #-}
97+
98+
takeTMVar :: MonadSTM m => StrictTMVar m a -> STM m a
99+
takeTMVar (StrictTMVar tmvar) = Lazy.takeTMVar tmvar
100+
101+
tryTakeTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)
102+
tryTakeTMVar (StrictTMVar tmvar) = Lazy.tryTakeTMVar tmvar
103+
104+
putTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m ()
105+
putTMVar (StrictTMVar tmvar) !a = Lazy.putTMVar tmvar a
106+
107+
tryPutTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m Bool
108+
tryPutTMVar (StrictTMVar tmvar) !a = Lazy.tryPutTMVar tmvar a
109+
110+
readTMVar :: MonadSTM m => StrictTMVar m a -> STM m a
111+
readTMVar (StrictTMVar tmvar) = Lazy.readTMVar tmvar
112+
113+
tryReadTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)
114+
tryReadTMVar (StrictTMVar tmvar) = Lazy.tryReadTMVar tmvar
115+
116+
swapTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m a
117+
swapTMVar (StrictTMVar tmvar) !a = Lazy.swapTMVar tmvar a
118+
119+
isEmptyTMVar :: MonadSTM m => StrictTMVar m a -> STM m Bool
120+
isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar

0 commit comments

Comments
 (0)