![iohk-bors[bot]](https://avatars.githubusercontent.com/in/17473?v=4&s=80)
3585: Monad transformer instances for various type classes in `io-classes` r=coot a=coot Co-authored-by: Marcin Szamotulski <[email protected]>
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
-- MonadAsync's ReaderT instance is undecidable.
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Class.MonadAsync
( MonadAsync (..)
, AsyncCancelled (..)
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTimer
import Control.Monad.Trans (lift)
import Control.Monad.Reader (ReaderT (..))
import Control.Concurrent.Async (AsyncCancelled (..))
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as E
import Data.Bifunctor (first)
import Data.Foldable (fold)
import Data.Functor (void)
import Data.Kind (Type)
tryAll :: MonadCatch m => m a -> m (Either SomeException a)
tryAll = try
--
-- ReaderT instance
--
newtype WrappedAsync r (m :: Type -> Type) a =
WrappedAsync { unWrapAsync :: Async m a }
instance ( MonadAsync m
, MonadCatch (STM m)
) => MonadAsync (ReaderT r m) where
type Async (ReaderT r m) = WrappedAsync r m
asyncThreadId (WrappedAsync a) = asyncThreadId a
async (ReaderT ma) = ReaderT $ \r -> WrappedAsync <$> async (ma r)
withAsync (ReaderT ma) f = ReaderT $ \r -> withAsync (ma r)
$ \a -> runReaderT (f (WrappedAsync a)) r
asyncWithUnmask f = ReaderT $ \r -> fmap WrappedAsync
$ asyncWithUnmask
$ \unmask -> runReaderT (f (liftF unmask)) r
where
liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a
liftF g (ReaderT r) = ReaderT (g . r)
waitCatchSTM = WrappedSTM . waitCatchSTM . unWrapAsync
pollSTM = WrappedSTM . pollSTM . unWrapAsync
race (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race (ma r) (mb r)
race_ (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race_ (ma r) (mb r)
concurrently (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> concurrently (ma r) (mb r)
wait = lift . wait . unWrapAsync
poll = lift . poll . unWrapAsync
waitCatch = lift . waitCatch . unWrapAsync
cancel = lift . cancel . unWrapAsync
uninterruptibleCancel = lift . uninterruptibleCancel
. unWrapAsync
cancelWith = (lift .: cancelWith)
. unWrapAsync
waitAny = fmap (first WrappedAsync)
. lift . waitAny
. map unWrapAsync
waitAnyCatch = fmap (first WrappedAsync)
. lift . waitAnyCatch
. map unWrapAsync
waitAnyCancel = fmap (first WrappedAsync)
. lift . waitAnyCancel
. map unWrapAsync
waitAnyCatchCancel = fmap (first WrappedAsync)
. lift . waitAnyCatchCancel
. map unWrapAsync
waitEither = on (lift .: waitEither) unWrapAsync
waitEitherCatch = on (lift .: waitEitherCatch) unWrapAsync
waitEitherCancel = on (lift .: waitEitherCancel) unWrapAsync
waitEitherCatchCancel = on (lift .: waitEitherCatchCancel) unWrapAsync
waitEither_ = on (lift .: waitEither_) unWrapAsync
waitBoth = on (lift .: waitBoth) unWrapAsync
--
-- Utilities
--
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(f .: g) x y = f (g x y)
-- | A higher order version of 'Data.Function.on'
--
on :: (f a -> f b -> c)
-> (forall x. g x -> f x)
-> (g a -> g b -> c)
on f g = \a b -> f (g a) (g b)
import qualified Control.Concurrent as IO
import Control.Exception (AsyncException (ThreadKilled), Exception)
import Control.Monad.Reader
import Control.Monad.Reader (ReaderT (..), lift)
import Data.Kind (Type)
import qualified GHC.Conc.Sync as IO (labelThread)
throwTo = IO.throwTo
killThread = IO.killThread
instance MonadThread m => MonadThread (ReaderT e m) where
type ThreadId (ReaderT e m) = ThreadId m
instance MonadThread m => MonadThread (ReaderT r m) where
type ThreadId (ReaderT r m) = ThreadId m
myThreadId = lift myThreadId
labelThread t l = lift (labelThread t l)
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
-- undecidable instances needed for 'WrappedSTM' instances of 'MonadThrow' and
-- 'MonadCatch' type classes.
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Class.MonadSTM
( MonadSTM (..)
, MonadLabelledSTM (..)
, newTMVarMDefault
, newEmptyTMVarM
, newEmptyTMVarMDefault
--
, WrappedSTM (..)
) where
import Prelude hiding (read)
import Control.Monad (MonadPlus (..))
import qualified Control.Monad.STM as STM
import Control.Monad.Trans (lift)
import Control.Monad.Cont (ContT (..))
import Control.Monad.Except (ExceptT (..))
import Control.Monad.RWS (RWST (..))
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.State (StateT (..))
import Control.Monad.Writer (WriterT (..))
import qualified Control.Monad.Class.MonadThrow as MonadThrow
import Control.Applicative (Alternative (..))
import Control.Exception
import Data.Function (on)
import Data.Kind (Type)
import GHC.Stack
import Numeric.Natural (Natural)
catchSTM :: (MonadSTM m, MonadThrow.MonadCatch (STM m), Exception e)
=> STM m a -> (e -> STM m a) -> STM m a
catchSTM = MonadThrow.catch
--
-- Monad Transformers
--
data Trans where
Cont :: Trans
Reader :: Trans
Writer :: Trans
State :: Trans
Except :: Trans
RWS :: Trans
-- | A newtype wrapper for an 'STM' monad for monad transformers.
--
newtype WrappedSTM (t :: Trans) r (m :: Type -> Type) a = WrappedSTM { runWrappedSTM :: STM m a }
deriving instance MonadSTM m => Functor (WrappedSTM t r m)
deriving instance MonadSTM m => Applicative (WrappedSTM t r m)
deriving instance MonadSTM m => Monad (WrappedSTM t r m)
deriving instance MonadSTM m => Alternative (WrappedSTM t r m)
deriving instance MonadSTM m => MonadPlus (WrappedSTM t r m)
-- note: this (and the following) instance requires 'UndecidableInstances'
-- extension because it violates 3rd Paterson condition, however `STM m` will
-- resolve to a concrete type of kind (Type -> Type), and thus no larger than
-- `m` itself, e.g. for `m ~ ReaderT r f`, `STM m ~ WrappedSTM Reader r f`.
-- Instance resolution will termniate as soon as the monad transformer stack
-- depth is exhousted.
instance ( MonadSTM m
, MonadThrow.MonadThrow (STM m)
, MonadThrow.MonadCatch (STM m)
) => MonadThrow.MonadThrow (WrappedSTM t r m) where
throwIO = WrappedSTM . MonadThrow.throwIO
instance ( MonadSTM m
, MonadThrow.MonadThrow (STM m)
, MonadThrow.MonadCatch (STM m)
) => MonadThrow.MonadCatch (WrappedSTM t r m) where
catch action handler = WrappedSTM
$ MonadThrow.catch (runWrappedSTM action) (runWrappedSTM . handler)
generalBracket acquire release use = WrappedSTM $
MonadThrow.generalBracket (runWrappedSTM acquire)
(runWrappedSTM .: release)
(runWrappedSTM . use)
instance MonadSTM m => MonadSTM (ContT r m) where
type STM (ContT r m) = WrappedSTM Cont r m
atomically = lift . atomically . runWrappedSTM
type TVar (ContT r m) = TVar m
newTVar = WrappedSTM . newTVar
readTVar = readTVar
writeTVar = WrappedSTM .: writeTVar
retry = WrappedSTM retry
orElse = WrappedSTM .: on orElse runWrappedSTM
modifyTVar = WrappedSTM .: modifyTVar
modifyTVar' = WrappedSTM .: modifyTVar'
stateTVar = WrappedSTM .: stateTVar
swapTVar = WrappedSTM .: swapTVar
check = WrappedSTM . check
type TMVar (ContT r m) = TMVar m
newTMVar = WrappedSTM . newTMVar
newEmptyTMVar = WrappedSTM newEmptyTMVar
takeTMVar = WrappedSTM . takeTMVar
tryTakeTMVar = WrappedSTM . tryTakeTMVar
putTMVar = WrappedSTM .: putTMVar
tryPutTMVar = WrappedSTM .: tryPutTMVar
readTMVar = WrappedSTM . readTMVar
tryReadTMVar = WrappedSTM . tryReadTMVar
swapTMVar = WrappedSTM .: swapTMVar
isEmptyTMVar = WrappedSTM . isEmptyTMVar
type TQueue (ContT r m) = TQueue m
newTQueue = WrappedSTM newTQueue
readTQueue = WrappedSTM . readTQueue
tryReadTQueue = WrappedSTM . tryReadTQueue
peekTQueue = WrappedSTM . peekTQueue
tryPeekTQueue = WrappedSTM . tryPeekTQueue
writeTQueue v = WrappedSTM . writeTQueue v
isEmptyTQueue = WrappedSTM . isEmptyTQueue
type TBQueue (ContT r m) = TBQueue m
newTBQueue = WrappedSTM . newTBQueue
readTBQueue = WrappedSTM . readTBQueue
tryReadTBQueue = WrappedSTM . tryReadTBQueue
peekTBQueue = WrappedSTM . peekTBQueue
tryPeekTBQueue = WrappedSTM . tryPeekTBQueue
flushTBQueue = WrappedSTM . flushTBQueue
writeTBQueue = WrappedSTM .: writeTBQueue
lengthTBQueue = WrappedSTM . lengthTBQueue
isEmptyTBQueue = WrappedSTM . isEmptyTBQueue
isFullTBQueue = WrappedSTM . isFullTBQueue
instance MonadSTM m => MonadSTM (ReaderT r m) where
type STM (ReaderT r m) = WrappedSTM Reader r m
atomically = lift . atomically . runWrappedSTM
type TVar (ReaderT r m) = TVar m
newTVar = WrappedSTM . newTVar
readTVar = readTVar
writeTVar = WrappedSTM .: writeTVar
retry = WrappedSTM retry
orElse = WrappedSTM .: on orElse runWrappedSTM
modifyTVar = WrappedSTM .: modifyTVar
modifyTVar' = WrappedSTM .: modifyTVar'
stateTVar = WrappedSTM .: stateTVar
swapTVar = WrappedSTM .: swapTVar
check = WrappedSTM . check
type TMVar (ReaderT r m) = TMVar m
newTMVar = WrappedSTM . newTMVar
newEmptyTMVar = WrappedSTM newEmptyTMVar
takeTMVar = WrappedSTM . takeTMVar
tryTakeTMVar = WrappedSTM . tryTakeTMVar
putTMVar = WrappedSTM .: putTMVar
tryPutTMVar = WrappedSTM .: tryPutTMVar
readTMVar = WrappedSTM . readTMVar
tryReadTMVar = WrappedSTM . tryReadTMVar
swapTMVar = WrappedSTM .: swapTMVar
isEmptyTMVar = WrappedSTM . isEmptyTMVar
type TQueue (ReaderT r m) = TQueue m
newTQueue = WrappedSTM newTQueue
readTQueue = WrappedSTM . readTQueue
tryReadTQueue = WrappedSTM . tryReadTQueue
peekTQueue = WrappedSTM . peekTQueue
tryPeekTQueue = WrappedSTM . tryPeekTQueue
writeTQueue v = WrappedSTM . writeTQueue v
isEmptyTQueue = WrappedSTM . isEmptyTQueue
type TBQueue (ReaderT r m) = TBQueue m
newTBQueue = WrappedSTM . newTBQueue
readTBQueue = WrappedSTM . readTBQueue
tryReadTBQueue = WrappedSTM . tryReadTBQueue
peekTBQueue = WrappedSTM . peekTBQueue
tryPeekTBQueue = WrappedSTM . tryPeekTBQueue
flushTBQueue = WrappedSTM . flushTBQueue
writeTBQueue = WrappedSTM .: writeTBQueue
lengthTBQueue = WrappedSTM . lengthTBQueue
import qualified Control.Concurrent as IO
import qualified Control.Concurrent.STM.TVar as STM
import Control.Exception (assert)
import Control.Monad.Reader
#if defined(mingw32_HOST_OS)
import Control.Monad (when)
#endif
import qualified Control.Monad.STM as STM
import Control.Monad.Trans (lift)
import Control.Monad.Cont (ContT (..))
import Control.Monad.Except (ExceptT (..))
import Control.Monad.RWS (RWST (..))
import Control.Monad.Reader (ReaderT (..))
import Control.Monad.State (StateT (..))
import Control.Monad.Writer (WriterT (..))
import Data.Functor (void)
import Data.Kind (Type)
import Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral
--
-- Lift to ReaderT
-- Transfomer's instances
--
instance MonadDelay m => MonadDelay (ContT r m) where
threadDelay = lift . threadDelay
instance MonadDelay m => MonadDelay (ReaderT r m) where
threadDelay = lift . threadDelay
instance (Monoid w, MonadDelay m) => MonadDelay (WriterT w m) where
threadDelay = lift . threadDelay
instance MonadDelay m => MonadDelay (StateT s m) where
threadDelay = lift . threadDelay
instance MonadDelay m => MonadDelay (ExceptT e m) where
threadDelay = lift . threadDelay
instance (Monoid w, MonadDelay m) => MonadDelay (RWST r w s m) where
threadDelay = lift . threadDelay
instance MonadTimer m => MonadTimer (ReaderT r m) where
newtype Timeout (ReaderT r m) = TimeoutR { unTimeoutR :: Timeout m }
newTimeout = lift . fmap TimeoutR . newTimeout
readTimeout = WrappedSTM . readTimeout . unTimeoutR
updateTimeout (TimeoutR t) d = lift $ updateTimeout t d
cancelTimeout = lift . cancelTimeout . unTimeoutR
registerDelay = lift . registerDelay
timeout d f = ReaderT $ \r -> timeout d (runReaderT f r)
instance (Monoid w, MonadTimer m) => MonadTimer (WriterT w m) where
newtype Timeout (WriterT w m) = TimeoutW { unTimeoutW :: Timeout m }
newTimeout = lift . fmap TimeoutW . newTimeout
readTimeout = WrappedSTM . readTimeout . unTimeoutW
updateTimeout (TimeoutW t) d = lift $ updateTimeout t d
cancelTimeout = lift . cancelTimeout . unTimeoutW
registerDelay = lift . registerDelay
timeout d f = WriterT $ do
r <- timeout d (runWriterT f)
return $ case r of
Nothing -> (Nothing, mempty)
Just (a, w) -> (Just a, w)
instance MonadTimer m => MonadTimer (StateT s m) where
newtype Timeout (StateT s m) = TimeoutS { unTimeoutS :: Timeout m }
newTimeout = lift . fmap TimeoutS . newTimeout
readTimeout = WrappedSTM . readTimeout . unTimeoutS
updateTimeout (TimeoutS t) d = lift $ updateTimeout t d
cancelTimeout = lift . cancelTimeout . unTimeoutS
registerDelay = lift . registerDelay
timeout d f = StateT $ \s -> do
r <- timeout d (runStateT f s)
return $ case r of
Nothing -> (Nothing, s)
Just (a, s') -> (Just a, s')
instance (Monoid w, MonadTimer m) => MonadTimer (RWST r w s m) where
newtype Timeout (RWST r w s m) = TimeoutRWS { unTimeoutRWS :: Timeout m }
newTimeout = lift . fmap TimeoutRWS . newTimeout
readTimeout = WrappedSTM . readTimeout . unTimeoutRWS
updateTimeout (TimeoutRWS t) d = lift $ updateTimeout t d
cancelTimeout = lift . cancelTimeout . unTimeoutRWS
registerDelay = lift . registerDelay
timeout d (RWST f) = RWST $ \r s -> do
res <- timeout d (f r s)
return $ case res of
Nothing -> (Nothing, s, mempty)
Just (a, s', w) -> (Just a, s', w)
Replace types with their original definitions Define simple functions in place
3852: cardano-tracer: init RTView r=deepfire a=denisshevchenko This is pre-MVP for RTView. 3880: Old peers tracing was erroneously called in new tracing r=deepfire a=jutaro /nix/store/qaplqccmisqy8n7ai65nssafzkxyyc7p-cabal-install-exe-cabal-3.6.2.0/bin/cabal --project-file=/home/deepfire/cardano-node/.nix-shell-cabal.project run exe:cardano-node -- +RTS -sghc-rts-report.txt -RTS run --config config.json --database-path run/current/node-0/db-testnet --topology topology.json --host-addr 127.0.0.1 --port 30000 --socket-path node.socket +RTS -N2 -I0 -A16m -qg -qb --disable-delayed-os-memory-return -RTS cardano-node: ExceptionInLinkedThread (ThreadId 11) The name ""peersFromNodeKernel"" is already taken by a metric. CallStack (from HasCallStack): error, called at ./System/Metrics.hs:214:5 in ekg-core-0.1.1.7-FjoslY1tzknIAl90c73kOZ:System.Metrics 3882: Fix datum in tx and ref scripts r=Jimbo4350 a=ch1bo (Couldn't reopen https://github.com/input-output-hk/cardano-node/pull/3881, so created this one) :snowflake: Add a roundtrip property `TxBodyContent -> TxBody -> TxBodyContent` This helped in fixing the :bug: and uncover the two additional gaps in the code. I'm not 100% happy with the current implementation of the property though! I needed to accept two exceptions to the general `===`: 1. `SimpleScriptV1` reference scripts may become `SimpleScriptV2` 2. A `TxOutDatumHash` + a matching `ScriptData` may become a `TxOutDatumTx` :snowflake: Resolve datum hash + matching datum in transaction to `TxOutDatumInTx`, fixes #3866 :snowflake: Add missing script languages to `scriptLanguageSupportedInEra` for `BabbageEra` :snowflake: Allow scripts in any language as refeference scripts Co-authored-by: Denis Shevchenko <[email protected]> Co-authored-by: Kosyrev Serge <[email protected]> Co-authored-by: Yupanqui <[email protected]> Co-authored-by: Sebastian Nagel <[email protected]>
- you're no exception, patroni!
