From 8b0eb7c91a1ad16a67f25cbcd6f8391b39f73bfd Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 2 Sep 2022 01:41:51 +0200
Subject: [PATCH] Add draft for MonadSTM and limiting STM capabilities
Co-authored-by: Jan Beinke <git@janbeinke.com>
---
cabal.project | 1 +
flake.nix | 3 +
quasar/quasar.cabal | 1 +
stm-ltd/src/Control/Concurrent/STM/Class.hs | 131 ++++++++++++++++++++
stm-ltd/stm-ltd.cabal | 96 ++++++++++++++
5 files changed, 232 insertions(+)
create mode 100644 stm-ltd/src/Control/Concurrent/STM/Class.hs
create mode 100644 stm-ltd/stm-ltd.cabal
diff --git a/cabal.project b/cabal.project
index 5ee18b8..054da09 100644
--- a/cabal.project
+++ b/cabal.project
@@ -1,2 +1,3 @@
packages:
quasar
+ stm-ltd
diff --git a/flake.nix b/flake.nix
index bb423ac..a9ff650 100644
--- a/flake.nix
+++ b/flake.nix
@@ -24,12 +24,14 @@
quasar = pkgs.haskellPackages.quasar;
quasar_ghc92 = (getHaskellPackages "ghc92.").quasar;
quasar_ghc94 = (getHaskellPackages "ghc94.").quasar;
+ stm-ltd = pkgs.haskellPackages.stm-ltd;
}
);
overlay = final: prev: {
haskell = prev.haskell // {
packageOverrides = hfinal: hprev: prev.haskell.packageOverrides hfinal hprev // {
+ stm-ltd = hfinal.callCabal2nix "stm-ltd" ./stm-ltd {};
quasar = hfinal.callCabal2nix "quasar" ./quasar {};
};
};
@@ -41,6 +43,7 @@
in pkgs.mkShell {
inputsFrom = [
self.packages.${system}.quasar.env
+ self.packages.${system}.stm-ltd.env
];
packages = [
pkgs.cabal-install
diff --git a/quasar/quasar.cabal b/quasar/quasar.cabal
index 4d33432..a71b688 100644
--- a/quasar/quasar.cabal
+++ b/quasar/quasar.cabal
@@ -79,6 +79,7 @@ library
heaps,
mtl,
stm,
+ stm-ltd,
time,
transformers,
transformers-base,
diff --git a/stm-ltd/src/Control/Concurrent/STM/Class.hs b/stm-ltd/src/Control/Concurrent/STM/Class.hs
new file mode 100644
index 0000000..b53543b
--- /dev/null
+++ b/stm-ltd/src/Control/Concurrent/STM/Class.hs
@@ -0,0 +1,131 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.Concurrent.STM.Class (
+ MonadSTM,
+ liftSTM,
+ MonadSTM'(..),
+ CanBlock,
+ CanThrow,
+ STM',
+ runSTM',
+ unsafeLimitSTM,
+) where
+
+import Control.Applicative
+import Control.Concurrent.STM (STM, TVar)
+import Control.Concurrent.STM qualified as STM
+import Control.Monad.Catch
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Writer
+import Data.Kind (Type, Constraint)
+import Prelude
+
+data BlockMode = CanBlock
+data ThrowMode = CanThrow
+
+type CanBlock :: BlockMode
+type CanBlock = 'CanBlock
+
+type CanThrow :: ThrowMode
+type CanThrow = 'CanThrow
+
+type STM' :: BlockMode -> ThrowMode -> Type -> Type
+newtype STM' b t a = STM' (STM a)
+ deriving newtype (Functor, Applicative, Monad)
+
+instance MonadThrow (STM' b CanThrow) where
+ throwM ex = STM' (throwM ex)
+
+instance MonadCatch (STM' b CanThrow) where
+ catch = catchSTM
+
+instance Semigroup a => Semigroup (STM' b t a) where
+ (<>) = liftA2 (<>)
+
+instance Monoid a => Monoid (STM' b t a) where
+ mempty = pure mempty
+
+
+type MonadSTM' :: BlockMode -> ThrowMode -> (Type -> Type) -> Constraint
+class MonadSTM' b t m | m -> b, m -> t where
+ liftSTM' :: STM' b t a -> m a
+
+
+type MonadSTM = MonadSTM' CanBlock CanThrow
+
+liftSTM :: MonadSTM m => STM a -> m a
+liftSTM fn = liftSTM' (unsafeLimitSTM fn)
+
+
+instance MonadSTM' CanBlock CanThrow STM where
+ liftSTM' = runSTM'
+
+instance MonadSTM' b t (STM' b t) where
+ liftSTM' = id
+
+instance MonadSTM' b t m => MonadSTM' b t (ReaderT r m) where
+ liftSTM' = undefined
+
+instance MonadSTM' b t m => MonadSTM' b t (WriterT w m) where
+ liftSTM' = undefined
+
+
+--class MonadRetry m where
+-- retry :: m a
+--
+--instance MonadSTM' CanBlock t m => MonadRetry m where
+-- retry = unsafeLimitSTM STM.retry
+
+
+runSTM' :: STM' b t a -> STM a
+runSTM' (STM' fn) = fn
+
+
+
+unsafeLimitSTM :: (MonadSTM' b t m) => STM a -> m a
+unsafeLimitSTM fn = liftSTM' (STM' fn)
+
+
+readTVar :: MonadSTM' b t m => TVar a -> m a
+readTVar var = unsafeLimitSTM (STM.readTVar var)
+
+retry :: MonadSTM' CanBlock t m => m a
+retry = unsafeLimitSTM STM.retry
+
+throwSTM :: (MonadSTM' b CanThrow m, Exception e) => e -> m a
+throwSTM = unsafeLimitSTM . STM.throwSTM
+
+catchSTM :: (MonadSTM' b t m, Exception e) => STM' b CanThrow a -> (e -> STM' b t a) -> m a
+catchSTM (STM' fx) fn = unsafeLimitSTM $ catch (unsafeLimitSTM fx) (\ex -> runSTM' (fn ex))
+
+
+--foobar :: STM' CanBlock t ()
+--foobar = do
+-- var <- unsafeLimitSTM $ STM.newTVar True
+-- _x <- readTVar var
+-- retry
+--
+--foobar' :: STM' CanBlock CanThrow ()
+--foobar' = do
+-- catchSTM (throwM (userError "foobar")) (\(_ :: SomeException) -> traceM "caught")
+-- retry
+--
+--catchphrase :: STM' CanBlock t ()
+--catchphrase = catchSTM (throwM (userError "foobar")) (\(_ :: SomeException) -> traceM "caught")
+--
+--rethrow :: STM' b CanThrow ()
+--rethrow = catchSTM (throwM (userError "foobar")) (\(ex :: SomeException) -> throwM ex)
+--
+--foobar_' :: ReaderT Int (STM' CanBlock CanThrow) ()
+--foobar_' = do
+-- retry
+--
+--foobar'' :: STM ()
+--foobar'' = do
+-- runSTM' retry
+--
+--foobar''' :: ReaderT Int STM ()
+--foobar''' = do
+-- _var <- liftSTM (STM.newTVar False)
+-- retry
diff --git a/stm-ltd/stm-ltd.cabal b/stm-ltd/stm-ltd.cabal
new file mode 100644
index 0000000..d85c6b3
--- /dev/null
+++ b/stm-ltd/stm-ltd.cabal
@@ -0,0 +1,96 @@
+cabal-version: 3.0
+
+name: stm-ltd
+version: 0.1.0.0
+license: BSD-2-Clause
+build-type: Simple
+
+--source-repository head
+-- type: git
+-- location: https://github.com/?/stm-ltd.git
+
+common shared-properties
+ default-extensions:
+ AllowAmbiguousTypes
+ BangPatterns
+ BlockArguments
+ ConstraintKinds
+ DataKinds
+ DefaultSignatures
+ DeriveAnyClass
+ DeriveGeneric
+ DerivingStrategies
+ DisambiguateRecordFields
+ DuplicateRecordFields
+ ExistentialQuantification
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GADTs
+ GeneralizedNewtypeDeriving
+ ImportQualifiedPost
+ InstanceSigs
+ LambdaCase
+ -- Enable once 9.0.1 is required
+ --LexicalNegation
+ MultiParamTypeClasses
+ NamedFieldPuns
+ NoImplicitPrelude
+ NumericUnderscores
+ OverloadedStrings
+ PolyKinds
+ RankNTypes
+ ScopedTypeVariables
+ StandaloneDeriving
+ TupleSections
+ TypeApplications
+ TypeFamilies
+ TypeOperators
+ ViewPatterns
+ default-language: Haskell2010
+ ghc-options:
+ -Weverything
+ -Wno-all-missed-specialisations
+ -Wno-missing-safe-haskell-mode
+ -Wno-missing-kind-signatures
+ -Wno-missing-import-lists
+ -Wno-unsafe
+ -Werror=incomplete-patterns
+ -Werror=missing-fields
+ -Werror=missing-home-modules
+ -Werror=missing-methods
+
+common shared-executable-properties
+ import: shared-properties
+ ghc-options:
+ -threaded
+ -rtsopts
+ "-with-rtsopts=-N -I0"
+
+library
+ import: shared-properties
+ build-depends:
+ base,
+ exceptions,
+ stm,
+ transformers,
+ exposed-modules:
+ Control.Concurrent.STM.Class
+ -- Control.Concurrent.STM.Class.Unsafe
+ other-modules:
+ -- Control.Concurrent.STM.Class.Internal
+ hs-source-dirs:
+ src
+
+--test-suite stm-ltd-test
+-- import: shared-executable-properties
+-- type: exitcode-stdio-1.0
+-- build-depends:
+-- base,
+-- hspec,
+-- stm-ltd
+-- main-is: Spec.hs
+-- other-modules:
+-- Control.Concurrent.STM.ClassSpec
+-- hs-source-dirs:
+-- test
--
GitLab