1+ {-# LANGUAGE BangPatterns #-}
2+ {-# LANGUAGE CPP #-}
3+ {-# LANGUAGE TupleSections #-}
4+ {-# LANGUAGE TypeFamilies #-}
5+ {-# LANGUAGE TypeOperators #-}
6+
7+ -- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package.
8+ --
9+ -- Use "Control.Concurrent.Class.MonadMVar.Strict" as a drop-in replacement for
10+ -- the current module in case you do /not/ want to check invariants on the
11+ -- values inside 'StrictMVar's.
12+ module Control.Concurrent.Class.MonadMVar.Strict.Checked
13+ ( -- * StrictMVar
14+ StrictMVar
15+ , LazyMVar
16+ , castStrictMVar
17+ , toLazyMVar
18+ , fromLazyMVar
19+ , newEmptyMVar
20+ , newEmptyMVarWithInvariant
21+ , newMVar
22+ , newMVarWithInvariant
23+ , takeMVar
24+ , putMVar
25+ , readMVar
26+ , swapMVar
27+ , tryTakeMVar
28+ , tryPutMVar
29+ , isEmptyMVar
30+ , withMVar
31+ , withMVarMasked
32+ , modifyMVar_
33+ , modifyMVar
34+ , modifyMVarMasked_
35+ , modifyMVarMasked
36+ , tryReadMVar
37+ -- * Re-exports
38+ , MonadMVar
39+ ) where
40+
41+ import Control.Concurrent.Class.MonadMVar (MonadMVar )
42+ import qualified Control.Concurrent.Class.MonadMVar as Lazy
43+ import GHC.Stack (HasCallStack )
44+
45+ --
46+ -- StrictMVar
47+ --
48+
49+ type LazyMVar m = Lazy. MVarm
50+
51+ -- | A strict MVar with invariant checking.
52+ --
53+ -- There is a weaker invariant for a 'StrictMVar' than for a 'StrictTVar' (see
54+ -- the @strict-stm@ package): although all functions that modify the
55+ -- 'StrictMVar' check the invariant, we do /not/ guarantee that the value inside
56+ -- the 'StrictMVar' always satisfies the invariant. Instead, we /do/ guarantee
57+ -- that if the 'StrictMVar' is updated with a value that does not satisfy the
58+ -- invariant, an exception is thrown. The reason for this weaker guarantee is
59+ -- that leaving an 'MVar' empty can lead to very hard to debug "blocked
60+ -- indefinitely" problems.
61+ data StrictMVar m a = StrictMVar {
62+ -- | The invariant that is checked whenever the 'StrictMVar' is updated.
63+ invariant :: ! (a -> Maybe String
64+ , mvar :: ! (LazyMVar m a )
65+ }
66+
67+ castStrictMVar :: LazyMVar m ~ LazyMVar n
68+ => StrictMVar m a -> StrictMVar n a
69+ castStrictMVar v = StrictMVar (invariant v) (mvar v)
70+
71+ -- | Get the underlying @MVar@
72+ --
73+ -- Since we obviously can not guarantee that updates to this 'LazyMVar' will be
74+ -- strict, this should be used with caution.
75+ --
76+ -- Similarly, we can not guarantee that updates to this 'LazyMVar' do not break
77+ -- the original invariant that the 'StrictMVar' held.
78+ toLazyMVar :: StrictMVar m a -> LazyMVar m a
79+ toLazyMVar = mvar
80+
81+ -- | Create a 'StrictMVar' from a 'LazyMVar'
82+ --
83+ -- It is not guaranteed that the 'LazyMVar' contains a value that is in WHNF, so
84+ -- there is no guarantee that the resulting 'StrictMVar' contains a value that
85+ -- is in WHNF. This should be used with caution.
86+ --
87+ -- The resulting 'StrictMVar' has a trivial invariant.
88+ fromLazyMVar :: Lazy. MVarm a -> StrictMVar m a
89+ fromLazyMVar = StrictMVar (const Nothing )
90+
91+ newEmptyMVar :: MonadMVar m => m (StrictMVar m a )
92+ newEmptyMVar = fromLazyMVar <$> Lazy. newEmptyMVar
93+
94+ newEmptyMVarWithInvariant :: MonadMVar m
95+ => (a -> Maybe String
96+ -> m (StrictMVar m a )
97+ newEmptyMVarWithInvariant inv = StrictMVar inv <$> Lazy. newEmptyMVar
98+
99+ newMVar :: MonadMVar m => a -> m (StrictMVar m a )
100+ newMVar ! a = fromLazyMVar <$> Lazy. newMVar a
101+
102+ newMVarWithInvariant :: MonadMVar m
103+ => (a -> Maybe String
104+ -> a
105+ -> m (StrictMVar m a )
106+ newMVarWithInvariant inv ! a =
107+ checkInvariant (inv a) $
108+ StrictMVar inv <$> Lazy. newMVar a
109+
110+ takeMVar :: MonadMVar m => StrictMVar m a -> m a
111+ takeMVar = Lazy. takeMVar . mvar
112+
113+ putMVar :: MonadMVar m => StrictMVar m a -> a -> m ()
114+ putMVar v ! a = do
115+ Lazy. putMVar (mvar v) a
116+ checkInvariant (invariant v a) $ pure ()
117+
118+ readMVar :: MonadMVar m => StrictMVar m a -> m a
119+ readMVar v = Lazy. readMVar (mvar v)
120+
121+ swapMVar :: MonadMVar m => StrictMVar m a -> a -> m a
122+ swapMVar v ! a = do
123+ oldValue <- Lazy. swapMVar (mvar v) a
124+ checkInvariant (invariant v a) $ pure oldValue
125+
126+ tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a )
127+ tryTakeMVar v = Lazy. tryTakeMVar (mvar v)
128+
129+ tryPutMVar :: MonadMVar m => StrictMVar m a -> a -> m Bool
130+ tryPutMVar v ! a = do
131+ didPut <- Lazy. tryPutMVar (mvar v) a
132+ checkInvariant (invariant v a) $ pure didPut
133+
134+ isEmptyMVar :: MonadMVar m => StrictMVar m a -> m Bool
135+ isEmptyMVar v = Lazy. isEmptyMVar (mvar v)
136+
137+ withMVar :: MonadMVar m => StrictMVar m a -> (a -> m b ) -> m b
138+ withMVar v = Lazy. withMVar (mvar v)
139+
140+ withMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m b ) -> m b
141+ withMVarMasked v = Lazy. withMVarMasked (mvar v)
142+
143+ -- | 'modifyMVar_' is defined in terms of 'modifyMVar'.
144+ modifyMVar_ :: MonadMVar m => StrictMVar m a -> (a -> m a ) -> m ()
145+ modifyMVar_ v io = modifyMVar v io'
146+ where io' a = (,() ) <$> io a
147+
148+ modifyMVar :: MonadMVar m => StrictMVar m a -> (a -> m (a ,b )) -> m b
149+ modifyMVar v io = do
150+ (a', b) <- Lazy. modifyMVar (mvar v) io'
151+ checkInvariant (invariant v a') $ pure b
152+ where
153+ io' a = do
154+ (! a', b) <- io a
155+ -- Returning @a'@ along with @b@ allows us to check the invariant /after/
156+ -- filling in the MVar.
157+ pure (a' , (a', b))
158+
159+ -- | 'modifyMVarMasked_' is defined in terms of 'modifyMVarMasked'.
160+ modifyMVarMasked_ :: MonadMVar m => StrictMVar m a -> (a -> m a ) -> m ()
161+ modifyMVarMasked_ v io = modifyMVar v io'
162+ where io' a = (,() ) <$> io a
163+
164+ modifyMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m (a ,b )) -> m b
165+ modifyMVarMasked v io = do
166+ (a', b) <- Lazy. modifyMVar (mvar v) io'
167+ checkInvariant (invariant v a') $ pure b
168+ where
169+ io' a = do
170+ (! a', b) <- io a
171+ -- Returning @a'@ along with @b@ allows us to check the invariant /after/
172+ -- filling in the MVar.
173+ pure (a', (a', b))
174+
175+ tryReadMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a )
176+ tryReadMVar v = Lazy. tryReadMVar (mvar v)
177+
178+ --
179+ -- Dealing with invariants
180+ --
181+
182+ -- | Check invariant
183+ --
184+ -- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an
185+ -- error @err@ if @mErr == Just err@.
186+ checkInvariant :: HasCallStack => Maybe String -> a -> a
187+ checkInvariant Nothing k = k
188+ checkInvariant (Just err) _ = error $ " StrictMVar invariant violation: " ++ err
0 commit comments