packages feed

strict-stm (empty) → 1.0.0.0

raw patch · 12 files changed

+965/−0 lines, 12 filesdep +arraydep +basedep +io-classes

Dependencies added: array, base, io-classes, stm

Files

+ CHANGELOG.md view
@@ -0,0 +1,17 @@+# Changelog++## 1.0.0.0++## 0.6.0.0++## 0.5.0.0++## 0.4.0.0++## 0.3.0.0++* split modules in a similar way that the `stm` package is.+* added `StrictTChan`, `TSem` and `StrictTArray`+* added `unGetTQueue` & `unGetTBQueue`+* added `StrictTQueue` & `StrictTBQueue`+* support `ghc-9.2` & `ghc-9.4`
+ LICENSE view
@@ -0,0 +1,177 @@++                                 Apache License+                           Version 2.0, January 2004+                        http://www.apache.org/licenses/++   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++   1. Definitions.++      "License" shall mean the terms and conditions for use, reproduction,+      and distribution as defined by Sections 1 through 9 of this document.++      "Licensor" shall mean the copyright owner or entity authorized by+      the copyright owner that is granting the License.++      "Legal Entity" shall mean the union of the acting entity and all+      other entities that control, are controlled by, or are under common+      control with that entity. For the purposes of this definition,+      "control" means (i) the power, direct or indirect, to cause the+      direction or management of such entity, whether by contract or+      otherwise, or (ii) ownership of fifty percent (50%) or more of the+      outstanding shares, or (iii) beneficial ownership of such entity.++      "You" (or "Your") shall mean an individual or Legal Entity+      exercising permissions granted by this License.++      "Source" form shall mean the preferred form for making modifications,+      including but not limited to software source code, documentation+      source, and configuration files.++      "Object" form shall mean any form resulting from mechanical+      transformation or translation of a Source form, including but+      not limited to compiled object code, generated documentation,+      and conversions to other media types.++      "Work" shall mean the work of authorship, whether in Source or+      Object form, made available under the License, as indicated by a+      copyright notice that is included in or attached to the work+      (an example is provided in the Appendix below).++      "Derivative Works" shall mean any work, whether in Source or Object+      form, that is based on (or derived from) the Work and for which the+      editorial revisions, annotations, elaborations, or other modifications+      represent, as a whole, an original work of authorship. For the purposes+      of this License, Derivative Works shall not include works that remain+      separable from, or merely link (or bind by name) to the interfaces of,+      the Work and Derivative Works thereof.++      "Contribution" shall mean any work of authorship, including+      the original version of the Work and any modifications or additions+      to that Work or Derivative Works thereof, that is intentionally+      submitted to Licensor for inclusion in the Work by the copyright owner+      or by an individual or Legal Entity authorized to submit on behalf of+      the copyright owner. For the purposes of this definition, "submitted"+      means any form of electronic, verbal, or written communication sent+      to the Licensor or its representatives, including but not limited to+      communication on electronic mailing lists, source code control systems,+      and issue tracking systems that are managed by, or on behalf of, the+      Licensor for the purpose of discussing and improving the Work, but+      excluding communication that is conspicuously marked or otherwise+      designated in writing by the copyright owner as "Not a Contribution."++      "Contributor" shall mean Licensor and any individual or Legal Entity+      on behalf of whom a Contribution has been received by Licensor and+      subsequently incorporated within the Work.++   2. Grant of Copyright License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      copyright license to reproduce, prepare Derivative Works of,+      publicly display, publicly perform, sublicense, and distribute the+      Work and such Derivative Works in Source or Object form.++   3. Grant of Patent License. Subject to the terms and conditions of+      this License, each Contributor hereby grants to You a perpetual,+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable+      (except as stated in this section) patent license to make, have made,+      use, offer to sell, sell, import, and otherwise transfer the Work,+      where such license applies only to those patent claims licensable+      by such Contributor that are necessarily infringed by their+      Contribution(s) alone or by combination of their Contribution(s)+      with the Work to which such Contribution(s) was submitted. If You+      institute patent litigation against any entity (including a+      cross-claim or counterclaim in a lawsuit) alleging that the Work+      or a Contribution incorporated within the Work constitutes direct+      or contributory patent infringement, then any patent licenses+      granted to You under this License for that Work shall terminate+      as of the date such litigation is filed.++   4. Redistribution. You may reproduce and distribute copies of the+      Work or Derivative Works thereof in any medium, with or without+      modifications, and in Source or Object form, provided that You+      meet the following conditions:++      (a) You must give any other recipients of the Work or+          Derivative Works a copy of this License; and++      (b) You must cause any modified files to carry prominent notices+          stating that You changed the files; and++      (c) You must retain, in the Source form of any Derivative Works+          that You distribute, all copyright, patent, trademark, and+          attribution notices from the Source form of the Work,+          excluding those notices that do not pertain to any part of+          the Derivative Works; and++      (d) If the Work includes a "NOTICE" text file as part of its+          distribution, then any Derivative Works that You distribute must+          include a readable copy of the attribution notices contained+          within such NOTICE file, excluding those notices that do not+          pertain to any part of the Derivative Works, in at least one+          of the following places: within a NOTICE text file distributed+          as part of the Derivative Works; within the Source form or+          documentation, if provided along with the Derivative Works; or,+          within a display generated by the Derivative Works, if and+          wherever such third-party notices normally appear. The contents+          of the NOTICE file are for informational purposes only and+          do not modify the License. You may add Your own attribution+          notices within Derivative Works that You distribute, alongside+          or as an addendum to the NOTICE text from the Work, provided+          that such additional attribution notices cannot be construed+          as modifying the License.++      You may add Your own copyright statement to Your modifications and+      may provide additional or different license terms and conditions+      for use, reproduction, or distribution of Your modifications, or+      for any such Derivative Works as a whole, provided Your use,+      reproduction, and distribution of the Work otherwise complies with+      the conditions stated in this License.++   5. Submission of Contributions. Unless You explicitly state otherwise,+      any Contribution intentionally submitted for inclusion in the Work+      by You to the Licensor shall be under the terms and conditions of+      this License, without any additional terms or conditions.+      Notwithstanding the above, nothing herein shall supersede or modify+      the terms of any separate license agreement you may have executed+      with Licensor regarding such Contributions.++   6. Trademarks. This License does not grant permission to use the trade+      names, trademarks, service marks, or product names of the Licensor,+      except as required for reasonable and customary use in describing the+      origin of the Work and reproducing the content of the NOTICE file.++   7. Disclaimer of Warranty. Unless required by applicable law or+      agreed to in writing, Licensor provides the Work (and each+      Contributor provides its Contributions) on an "AS IS" BASIS,+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+      implied, including, without limitation, any warranties or conditions+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+      PARTICULAR PURPOSE. You are solely responsible for determining the+      appropriateness of using or redistributing the Work and assume any+      risks associated with Your exercise of permissions under this License.++   8. Limitation of Liability. In no event and under no legal theory,+      whether in tort (including negligence), contract, or otherwise,+      unless required by applicable law (such as deliberate and grossly+      negligent acts) or agreed to in writing, shall any Contributor be+      liable to You for damages, including any direct, indirect, special,+      incidental, or consequential damages of any character arising as a+      result of this License or out of the use or inability to use the+      Work (including but not limited to damages for loss of goodwill,+      work stoppage, computer failure or malfunction, or any and all+      other commercial damages or losses), even if such Contributor+      has been advised of the possibility of such damages.++   9. Accepting Warranty or Additional Liability. While redistributing+      the Work or Derivative Works thereof, You may choose to offer,+      and charge a fee for, acceptance of support, warranty, indemnity,+      or other liability obligations and/or rights consistent with this+      License. However, in accepting such obligations, You may act only+      on Your own behalf and on Your sole responsibility, not on behalf+      of any other Contributor, and only if You agree to indemnify,+      defend, and hold each Contributor harmless for any liability+      incurred by, or claims asserted against, such Contributor by reason+      of your accepting any such warranty or additional liability.++   END OF TERMS AND CONDITIONS
+ NOTICE view
@@ -0,0 +1,14 @@+Copyright 2019-2023 Input Output Global Inc (IOG)++   Licensed under the Apache License, Version 2.0 (the "License");+   you may not use this file except in compliance with the License.+   You may obtain a copy of the License at++       http://www.apache.org/licenses/LICENSE-2.0++   Unless required by applicable law or agreed to in writing, software+   distributed under the License is distributed on an "AS IS" BASIS,+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+   See the License for the specific language governing permissions and+   limitations under the License.+
+ README.md view
@@ -0,0 +1,18 @@+# Strict Software Transaction Memory++The `strict-stm` package provides a strict interface to software transaction+memory.  It builds on top of [`io-classes`] and thus it provides the interface+for both [`stm`] as well as [`io-sim`].++# Novel testing / space-leak elimination approach++The strict interface provides a novel way of testing/eliminating space-leaks+which might lurk in `stm` shared mutable variables.  Together with the+[`nothunks`] library it was successfully used to eliminate and keep a large+system ([`cardano-node`]) space leak free.++[`cardano-node`]: https://www.github.com/input-output-hk/cardano-node+[`io-classes`]: https://hackage.haskell.org/package/io-classes+[`io-sim`]: https://hackage.haskell.org/package/io-sim+[`nothunks`]: https://hackage.haskell.org/package/nothunks+[`stm`]: https://hackage.haskell.org/package/stm
+ src/Control/Concurrent/Class/MonadSTM/Strict.hs view
@@ -0,0 +1,19 @@+-- | This module corresponds to `Control.Concurrent.STM` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict+  (module STM)+  where++import           Control.Monad.Class.MonadSTM                     as STM hiding ( traceTVar, traceTVarIO,+                                                                                  traceTMVar, traceTMVarIO,+                                                                                  traceTQueue, traceTQueueIO,+                                                                                  traceTBQueue, traceTBQueueIO+                                                                                )+import           Control.Concurrent.Class.MonadSTM.Strict.TVar    as STM+import           Control.Concurrent.Class.MonadSTM.Strict.TMVar   as STM+import           Control.Concurrent.Class.MonadSTM.Strict.TChan   as STM+import           Control.Concurrent.Class.MonadSTM.Strict.TQueue  as STM+import           Control.Concurrent.Class.MonadSTM.Strict.TBQueue as STM+import           Control.Concurrent.Class.MonadSTM.Strict.TArray  as STM++
+ src/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ExplicitNamespaces    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-}++-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TArray+  ( StrictTArray+  , LazyTArray+  , toLazyTArray+  , fromLazyTArray+  ) where+++import qualified Control.Concurrent.Class.MonadSTM.TArray as Lazy++import           Data.Array.Base (MArray (..))+++type LazyTArray  m = Lazy.TArray m++newtype StrictTArray m i e = StrictTArray { toLazyTArray :: LazyTArray m i e }++fromLazyTArray :: LazyTArray m i e -> StrictTArray m i e+fromLazyTArray = StrictTArray++instance ( MArray (Lazy.TArray m) e stm+         , Monad stm+         )+      => MArray (StrictTArray m) e stm where+    getBounds (StrictTArray arr) = getBounds arr+    newArray  b !e = StrictTArray <$> newArray b e+    newArray_ b    = StrictTArray <$> newArray_ b+    unsafeRead     (StrictTArray arr) i    = unsafeRead arr i+    unsafeWrite    (StrictTArray arr) i !e = unsafeWrite arr i e+    getNumElements (StrictTArray arr)      = getNumElements arr+
+ src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE TypeOperators      #-}++-- | This module corresponds to `Control.Concurrent.STM.TBQueue` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TBQueue+  ( -- * MonadSTM+    StrictTBQueue+  , LazyTBQueue+  , toLazyTBQueue+  , fromLazyTBQueue+  , castStrictTBQueue+  , newTBQueue+  , newTBQueueIO+  , readTBQueue+  , tryReadTBQueue+  , peekTBQueue+  , tryPeekTBQueue+  , flushTBQueue+  , writeTBQueue+  , lengthTBQueue+  , isEmptyTBQueue+  , isFullTBQueue+  , unGetTBQueue+    -- * MonadLabelledSTM+  , labelTBQueue+  , labelTBQueueIO+    -- * MonadTraceSTM+  , traceTBQueue+  , traceTBQueueIO+  ) where+++import qualified Control.Concurrent.Class.MonadSTM.TBQueue as Lazy+import           Control.Monad.Class.MonadSTM hiding (traceTBQueue, traceTBQueueIO)++import           Numeric.Natural (Natural)+++type LazyTBQueue m = Lazy.TBQueue m++newtype StrictTBQueue m a = StrictTBQueue { toLazyTBQueue :: LazyTBQueue m a }++fromLazyTBQueue :: LazyTBQueue m a -> StrictTBQueue m a+fromLazyTBQueue = StrictTBQueue++castStrictTBQueue :: LazyTBQueue m ~ LazyTBQueue n+                  => StrictTBQueue m a -> StrictTBQueue n a+castStrictTBQueue (StrictTBQueue var) = StrictTBQueue var++labelTBQueue :: MonadLabelledSTM m => StrictTBQueue m a -> String -> STM m ()+labelTBQueue (StrictTBQueue queue) = Lazy.labelTBQueue queue++labelTBQueueIO :: MonadLabelledSTM m => StrictTBQueue m a -> String -> m ()+labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue++traceTBQueue :: MonadTraceSTM m+             => proxy m+             -> StrictTBQueue m a+             -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)+             -> STM m ()+traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue++traceTBQueueIO :: MonadTraceSTM m+               => StrictTBQueue m a+               -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)+               -> m ()+traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue++newTBQueue :: MonadSTM m => Natural -> STM m (StrictTBQueue m a)+newTBQueue n = StrictTBQueue <$> Lazy.newTBQueue n++newTBQueueIO :: MonadSTM m => Natural -> m (StrictTBQueue m a)+newTBQueueIO = atomically . newTBQueue++readTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a+readTBQueue = Lazy.readTBQueue . toLazyTBQueue++tryReadTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a)+tryReadTBQueue = Lazy.tryReadTBQueue . toLazyTBQueue++peekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a+peekTBQueue = Lazy.peekTBQueue . toLazyTBQueue++tryPeekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a)+tryPeekTBQueue = Lazy.tryPeekTBQueue . toLazyTBQueue++flushTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m [a]+flushTBQueue = Lazy.flushTBQueue . toLazyTBQueue++writeTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m ()+writeTBQueue (StrictTBQueue tqueue) !a = Lazy.writeTBQueue tqueue a++lengthTBQueue  :: MonadSTM m => StrictTBQueue m a -> STM m Natural+lengthTBQueue = Lazy.lengthTBQueue . toLazyTBQueue++isEmptyTBQueue  :: MonadSTM m => StrictTBQueue m a -> STM m Bool+isEmptyTBQueue = Lazy.isEmptyTBQueue . toLazyTBQueue++isFullTBQueue  :: MonadSTM m => StrictTBQueue m a -> STM m Bool+isFullTBQueue = Lazy.isFullTBQueue . toLazyTBQueue++unGetTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m ()+unGetTBQueue (StrictTBQueue queue) !a = Lazy.unGetTBQueue queue a
+ src/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE TypeOperators      #-}++-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TChan+  ( StrictTChan+  , LazyTChan+  , toLazyTChan+  , fromLazyTChan+  , castStrictTChan+  , newTChan+  , newBroadcastTChan+  , writeTChan+  , readTChan+  , tryReadTChan+  , peekTChan+  , tryPeekTChan+  , dupTChan+  , unGetTChan+  , isEmptyTChan+  , cloneTChan+  ) where+++import qualified Control.Concurrent.Class.MonadSTM.TChan as Lazy+import           Control.Monad.Class.MonadSTM+++type LazyTChan   m = Lazy.TChan m++newtype StrictTChan m a = StrictTChan { toLazyTChan :: LazyTChan m a }++fromLazyTChan :: LazyTChan m a -> StrictTChan m a+fromLazyTChan = StrictTChan++castStrictTChan :: LazyTChan m ~ LazyTChan n+                => StrictTChan m a -> StrictTChan n a+castStrictTChan (StrictTChan var) = StrictTChan var++newTChan :: MonadSTM m => STM m (StrictTChan m a)+newTChan = StrictTChan <$> Lazy.newTChan++newBroadcastTChan :: MonadSTM m => STM m (StrictTChan m a)+newBroadcastTChan = StrictTChan <$> Lazy.newBroadcastTChan++writeTChan :: MonadSTM m => StrictTChan m a -> a -> STM m ()+writeTChan (StrictTChan chan) !a = Lazy.writeTChan chan a++readTChan :: MonadSTM m => StrictTChan m a -> STM m a+readTChan = Lazy.readTChan . toLazyTChan++tryReadTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a)+tryReadTChan = Lazy.tryReadTChan . toLazyTChan++peekTChan :: MonadSTM m => StrictTChan m a -> STM m a+peekTChan = Lazy.peekTChan . toLazyTChan++tryPeekTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a)+tryPeekTChan = Lazy.tryPeekTChan . toLazyTChan++dupTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a)+dupTChan = fmap fromLazyTChan . Lazy.dupTChan . toLazyTChan++unGetTChan :: MonadSTM m => StrictTChan m a -> a -> STM m ()+unGetTChan (StrictTChan chan) !a = Lazy.unGetTChan chan a++isEmptyTChan :: MonadSTM m => StrictTChan m a -> STM m Bool+isEmptyTChan = Lazy.isEmptyTChan . toLazyTChan++cloneTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a)+cloneTChan = fmap fromLazyTChan . Lazy.cloneTChan . toLazyTChan
+ src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE TypeOperators      #-}++-- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TMVar+  ( -- * StrictTMVar+    StrictTMVar+  , LazyTMVar+  , toLazyTMVar+  , fromLazyTMVar+  , castStrictTMVar+  , newTMVar+  , newEmptyTMVar+  , newTMVarIO+  , newEmptyTMVarIO+  , takeTMVar+  , tryTakeTMVar+  , putTMVar+  , tryPutTMVar+  , readTMVar+  , tryReadTMVar+  , swapTMVar+  , isEmptyTMVar+    -- * deprecated api+  , newTMVarM+  , newEmptyTMVarM+    -- * MonadLabelledSTM+  , labelTMVar+  , labelTMVarIO+    -- * MonadTraceSTM+  , traceTMVar+  , traceTMVarIO+  ) where+++import qualified Control.Concurrent.Class.MonadSTM.TMVar as Lazy+import           Control.Monad.Class.MonadSTM hiding (traceTMVar, traceTMVarIO)+++type LazyTMVar   m = Lazy.TMVar m++-- | 'TMVar' that keeps its value in WHNF at all times+--+-- Does not support an invariant: if the invariant would not be satisfied,+-- we would not be able to put a value into an empty TMVar, which would lead+-- to very hard to debug bugs where code is blocked indefinitely.+newtype StrictTMVar m a = StrictTMVar { toLazyTMVar :: LazyTMVar m a }++fromLazyTMVar :: LazyTMVar m a -> StrictTMVar m a+fromLazyTMVar = StrictTMVar++labelTMVar :: MonadLabelledSTM m => StrictTMVar m a -> String -> STM m ()+labelTMVar (StrictTMVar tvar) = Lazy.labelTMVar tvar++labelTMVarIO :: MonadLabelledSTM m => StrictTMVar m a -> String -> m ()+labelTMVarIO v = atomically . labelTMVar v++traceTMVar :: MonadTraceSTM m+           => proxy m+           -> StrictTMVar m a+           -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)+           -> STM m ()+traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var++traceTMVarIO :: MonadTraceSTM m+             => StrictTMVar m a+             -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue)+             -> m ()+traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var++castStrictTMVar :: LazyTMVar m ~ LazyTMVar n+                => StrictTMVar m a -> StrictTMVar n a+castStrictTMVar (StrictTMVar var) = StrictTMVar var++newTMVar :: MonadSTM m => a -> STM m (StrictTMVar m a)+newTMVar !a = StrictTMVar <$> Lazy.newTMVar a++newTMVarIO :: MonadSTM m => a -> m (StrictTMVar m a)+newTMVarIO !a = StrictTMVar <$> Lazy.newTMVarIO a++newTMVarM :: MonadSTM m => a -> m (StrictTMVar m a)+newTMVarM = newTMVarIO+{-# DEPRECATED newTMVarM "Use newTVarIO" #-}++newEmptyTMVar :: MonadSTM m => STM m (StrictTMVar m a)+newEmptyTMVar = StrictTMVar <$> Lazy.newEmptyTMVar++newEmptyTMVarIO :: MonadSTM m => m (StrictTMVar m a)+newEmptyTMVarIO = StrictTMVar <$> Lazy.newEmptyTMVarIO++newEmptyTMVarM :: MonadSTM m => m (StrictTMVar m a)+newEmptyTMVarM = newEmptyTMVarIO+{-# DEPRECATED newEmptyTMVarM "Use newEmptyTMVarIO" #-}++takeTMVar :: MonadSTM m => StrictTMVar m a -> STM m a+takeTMVar (StrictTMVar tmvar) = Lazy.takeTMVar tmvar++tryTakeTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)+tryTakeTMVar (StrictTMVar tmvar) = Lazy.tryTakeTMVar tmvar++putTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m ()+putTMVar (StrictTMVar tmvar) !a = Lazy.putTMVar tmvar a++tryPutTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m Bool+tryPutTMVar (StrictTMVar tmvar) !a = Lazy.tryPutTMVar tmvar a++readTMVar :: MonadSTM m => StrictTMVar m a -> STM m a+readTMVar (StrictTMVar tmvar) = Lazy.readTMVar tmvar++tryReadTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)+tryReadTMVar (StrictTMVar tmvar) = Lazy.tryReadTMVar tmvar++swapTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m a+swapTMVar (StrictTMVar tmvar) !a = Lazy.swapTMVar tmvar a++isEmptyTMVar :: MonadSTM m => StrictTMVar m a -> STM m Bool+isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar
+ src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE TypeOperators      #-}++-- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TQueue+  ( -- * MonadSTM+    StrictTQueue+  , LazyTQueue+  , toLazyTQueue+  , fromLazyTQueue+  , castStrictTQueue+  , newTQueue+  , newTQueueIO+  , readTQueue+  , tryReadTQueue+  , peekTQueue+  , tryPeekTQueue+  , flushTQueue+  , writeTQueue+  , unGetTQueue+  , isEmptyTQueue+    -- * MonadLabelledSTM+  , labelTQueue+  , labelTQueueIO+    -- * MonadTraceSTM+  , traceTQueue+  , traceTQueueIO+  ) where+++import qualified Control.Concurrent.Class.MonadSTM.TQueue as Lazy+import           Control.Monad.Class.MonadSTM hiding (traceTQueue, traceTQueueIO)+++type LazyTQueue  m = Lazy.TQueue m++newtype StrictTQueue m a = StrictTQueue { toLazyTQueue :: LazyTQueue m a }++fromLazyTQueue :: LazyTQueue m a -> StrictTQueue m a+fromLazyTQueue = StrictTQueue++castStrictTQueue :: LazyTQueue m ~ LazyTQueue n+                 => StrictTQueue m a -> StrictTQueue n a+castStrictTQueue (StrictTQueue var) = StrictTQueue var++labelTQueue :: MonadLabelledSTM m => StrictTQueue m a -> String -> STM m ()+labelTQueue (StrictTQueue queue) = Lazy.labelTQueue queue++labelTQueueIO :: MonadLabelledSTM m => StrictTQueue m a -> String -> m ()+labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue++traceTQueue :: MonadTraceSTM m+            => proxy m+            -> StrictTQueue m a+            -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)+            -> STM m ()+traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue++traceTQueueIO :: MonadTraceSTM m+              => StrictTQueue m a+              -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue)+              -> m ()+traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue++newTQueue :: MonadSTM m => STM m (StrictTQueue m a)+newTQueue = StrictTQueue <$> Lazy.newTQueue++newTQueueIO :: MonadSTM m => m (StrictTQueue m a)+newTQueueIO = atomically newTQueue++readTQueue :: MonadSTM m => StrictTQueue m a -> STM m a+readTQueue = Lazy.readTQueue . toLazyTQueue++tryReadTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a)+tryReadTQueue = Lazy.tryReadTQueue . toLazyTQueue++peekTQueue :: MonadSTM m => StrictTQueue m a -> STM m a+peekTQueue = Lazy.peekTQueue . toLazyTQueue++tryPeekTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a)+tryPeekTQueue = Lazy.tryPeekTQueue . toLazyTQueue++flushTQueue :: MonadSTM m => StrictTQueue m a -> STM m [a]+flushTQueue = Lazy.flushTQueue . toLazyTQueue++writeTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m ()+writeTQueue (StrictTQueue tqueue) !a = Lazy.writeTQueue tqueue a++isEmptyTQueue  :: MonadSTM m => StrictTQueue m a -> STM m Bool+isEmptyTQueue = Lazy.isEmptyTQueue . toLazyTQueue++unGetTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m ()+unGetTQueue (StrictTQueue queue) !a = Lazy.unGetTQueue queue a+
+ src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE TypeOperators      #-}++-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TVar+  ( -- * StrictTVar+    StrictTVar+  , LazyTVar+  , toLazyTVar+  , fromLazyTVar+  , castStrictTVar+  , newTVar+  , newTVarIO+  , newTVarWithInvariant+  , newTVarWithInvariantIO+  , readTVar+  , readTVarIO+  , writeTVar+  , modifyTVar+  , stateTVar+  , swapTVar+  , check+    -- ** Low-level API+  , checkInvariant+    -- ** deprecated API+  , updateTVar+  , newTVarM+  , newTVarWithInvariantM+    -- * MonadLabelSTM+  , labelTVar+  , labelTVarIO+    -- * MonadTraceSTM+  , traceTVar+  , traceTVarIO+  ) where++import qualified Control.Concurrent.Class.MonadSTM.TVar as Lazy+import           Control.Monad.Class.MonadSTM hiding (traceTVar, traceTVarIO)++import           GHC.Stack+++type LazyTVar    m = Lazy.TVar m++#if CHECK_TVAR_INVARIANT+data StrictTVar m a = StrictTVar+   { invariant :: !(a -> Maybe String)+     -- ^ Invariant checked whenever updating the 'StrictTVar'.+   , tvar      :: !(LazyTVar m a)+   }+#else+newtype StrictTVar m a = StrictTVar+   { tvar      :: LazyTVar m a+   }+#endif++labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m ()+labelTVar StrictTVar { tvar } = Lazy.labelTVar tvar++labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m ()+labelTVarIO v = atomically . labelTVar v++traceTVar :: MonadTraceSTM m+          => proxy m+          -> StrictTVar m a+          -> (Maybe a -> a -> InspectMonad m TraceValue)+          -> STM m ()+traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar++traceTVarIO :: MonadTraceSTM m+            => StrictTVar m a+            -> (Maybe a -> a -> InspectMonad m TraceValue)+            -> m ()+traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar++castStrictTVar :: LazyTVar m ~ LazyTVar n+               => StrictTVar m a -> StrictTVar n a+castStrictTVar v@StrictTVar {tvar} =+    mkStrictTVar (getInvariant v) tvar++-- | Get the underlying @TVar@+--+-- Since we obviously cannot guarantee that updates to this 'LazyTVar' will be+-- strict, this should be used with caution.+toLazyTVar :: StrictTVar m a -> LazyTVar m a+toLazyTVar StrictTVar { tvar } = tvar++fromLazyTVar :: LazyTVar m a -> StrictTVar m a+fromLazyTVar tvar =+#if CHECK_TVAR_INVARIANT+  StrictTVar { invariant = const Nothing+             , tvar+             }+#else+  StrictTVar { tvar }+#endif++newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)+newTVar !a = (\tvar -> mkStrictTVar (const Nothing) tvar)+         <$> Lazy.newTVar a++newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)+newTVarIO = newTVarWithInvariantIO (const Nothing)++newTVarM :: MonadSTM m => a -> m (StrictTVar m a)+newTVarM = newTVarIO+{-# DEPRECATED newTVarM "Use newTVarIO" #-}++newTVarWithInvariant :: (MonadSTM m, HasCallStack)+                     => (a -> Maybe String) -- ^ Invariant (expect 'Nothing')+                     -> a+                     -> STM m (StrictTVar m a)+newTVarWithInvariant  invariant !a =+        checkInvariant (invariant a) $+        (\tvar -> mkStrictTVar invariant tvar)+    <$> Lazy.newTVar a++newTVarWithInvariantIO :: (MonadSTM m, HasCallStack)+                       => (a -> Maybe String) -- ^ Invariant (expect 'Nothing')+                       -> a+                       -> m (StrictTVar m a)+newTVarWithInvariantIO  invariant !a =+        checkInvariant (invariant a) $+        (\tvar -> mkStrictTVar invariant tvar)+    <$> Lazy.newTVarIO a++newTVarWithInvariantM :: (MonadSTM m, HasCallStack)+                      => (a -> Maybe String) -- ^ Invariant (expect 'Nothing')+                      -> a+                      -> m (StrictTVar m a)+newTVarWithInvariantM = newTVarWithInvariantIO+{-# DEPRECATED newTVarWithInvariantM "Use newTVarWithInvariantIO" #-}++readTVar :: MonadSTM m => StrictTVar m a -> STM m a+readTVar StrictTVar { tvar } = Lazy.readTVar tvar++readTVarIO :: MonadSTM m => StrictTVar m a -> m a+readTVarIO StrictTVar { tvar } = Lazy.readTVarIO tvar++writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m ()+writeTVar v !a =+    checkInvariant (getInvariant v a) $+    Lazy.writeTVar (tvar v) a++modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m ()+modifyTVar v f = readTVar v >>= writeTVar v . f++stateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a+stateTVar v f = do+    a <- readTVar v+    let (b, a') = f a+    writeTVar v a'+    return b++swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a+swapTVar v a' = do+    a <- readTVar v+    writeTVar v a'+    return a+++updateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a+updateTVar = stateTVar+{-# DEPRECATED updateTVar "Use stateTVar" #-}+++{-------------------------------------------------------------------------------+  Dealing with invariants+-------------------------------------------------------------------------------}++getInvariant :: StrictTVar m a -> a -> Maybe String+mkStrictTVar :: (a -> Maybe String) -> Lazy.TVar m a -> StrictTVar m a++-- | Check invariant (if enabled) before continuing+--+-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws+-- an error @err@ if @mErr == Just err@.+--+-- This is exported so that other code that wants to conditionally check+-- invariants can reuse the same logic, rather than having to introduce new+-- per-package flags.+checkInvariant :: HasCallStack => Maybe String -> a -> a++#if CHECK_TVAR_INVARIANT+getInvariant StrictTVar {invariant} = invariant+mkStrictTVar invariant  tvar = StrictTVar {invariant, tvar}++checkInvariant Nothing    k = k+checkInvariant (Just err) _ = error $ "Invariant violation: " ++ err+#else+getInvariant _               = \_ -> Nothing+mkStrictTVar _invariant tvar = StrictTVar {tvar}++checkInvariant _err       k  = k+#endif
+ strict-stm.cabal view
@@ -0,0 +1,75 @@+cabal-version:       3.0+name:                strict-stm+version:             1.0.0.0+synopsis:            Strict STM interface polymorphic over stm implementation.+description:+  Strict STM interface provided on top of+  [io-classes](https://hackage.haskell.org/package/io-classes) and thus+  compatible with [stm](https://hackage.haskell.org/package/stm)+  & [io-sim](https://hackage.haskell.org/package/io-sim).+license:             Apache-2.0+license-files:+  LICENSE+  NOTICE+copyright:           2019-2023 Input Output Global Inc (IOG)+author:              Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant+maintainer:          Duncan Coutts dunca@well-typed.com, Marcin Szamotulski coot@coot.me+category:            Control+build-type:          Simple+extra-source-files:  CHANGELOG.md+                     README.md+tested-with:         GHC == { 8.10, 9.2, 9.4 }++source-repository head+  type:     git+  location: https://github.com/input-output-hk/io-sim+  subdir:   strict-stm++flag checktvarinvariant+  Description: Enable runtime invariant checks on StrictT(M)Var+  Manual: True+  Default: False++flag asserts+  description: Enable assertions+  manual:      False+  default:     False++library+  hs-source-dirs:      src++  exposed-modules:     Control.Concurrent.Class.MonadSTM.Strict+                       Control.Concurrent.Class.MonadSTM.Strict.TArray+                       Control.Concurrent.Class.MonadSTM.Strict.TBQueue+                       Control.Concurrent.Class.MonadSTM.Strict.TChan+                       Control.Concurrent.Class.MonadSTM.Strict.TMVar+                       Control.Concurrent.Class.MonadSTM.Strict.TQueue+                       Control.Concurrent.Class.MonadSTM.Strict.TVar+  reexported-modules:  Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem+  default-language:    Haskell2010+  default-extensions:  BangPatterns,+                       CPP,+                       ExplicitNamespaces,+                       FlexibleContexts,+                       FlexibleInstances,+                       GADTs,+                       NamedFieldPuns,+                       TypeOperators+  build-depends:       base        >= 4.9 && <4.18,+                       array,+                       stm         >= 2.5 && <2.6,++                       io-classes  ^>= 1.0+  ghc-options:         -Wall+                       -Wno-unticked-promoted-constructors+                       -Wcompat+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+                       -Wpartial-fields+                       -Widentities++  if flag(asserts)+    ghc-options: -fno-ignore-asserts++  if flag(checktvarinvariant)+    cpp-options: -DCHECK_TVAR_INVARIAN