import Cardano.Network.Protocol.NodeToClient
+
import qualified Control.Concurrent.Async as Async
import Control.Monad.Class.MonadST
import Ogmios.App.Configuration
import Ogmios.Control.MonadMetrics
import Ogmios.Control.MonadSTM
-
( MonadSTM (..), TVar, newTVar )
import Ogmios.Control.MonadWebSocket
+
import qualified Control.Concurrent.STM.TBQueue as STM
+
import qualified Control.Concurrent.STM.TMVar as STM
+
import qualified Control.Concurrent.STM.TQueue as STM
+
import qualified Control.Concurrent.STM.TVar as STM
+
import qualified Control.Monad.STM as STM
-
, MonadAsync, MonadThread, MonadFork
+
, MonadThread, MonadFork
, MonadThrow, MonadCatch, MonadMask
sampler <- newSampler tracerMetrics
pure $ Env{health,sensors,sampler,network,configuration}
+
-- Since `6b83e2b385b3533ccfc336c1099d27f1c6a79a2c` in ouroboros-network,
+
-- functional dependencies have been introduced between the class type family
+
-- and the monad argument making that monad injective with the type-family.
+
-- This means it's no longer possible to define instances of MonadSTM which use
+
-- `STM` as a target monad directly, without conflicting with the existing
+
-- instance definition for `IO`... this disqualifies `ReaderT` and all kind of
+
-- transformers, and also, our `App` application monad!
+
newtype WrappedSTM a = WrappedSTM { unwrapSTM :: STM.STM a }
+
deriving newtype (Functor, Applicative, Alternative, Monad, MonadPlus, MonadThrow)
+
instance MonadSTM App where
+
type STM App = WrappedSTM
+
type TVar App = STM.TVar
+
type TMVar App = STM.TMVar
+
type TQueue App = STM.TQueue
+
type TBQueue App = STM.TBQueue
+
atomically = App . lift . STM.atomically . unwrapSTM
+
retry = WrappedSTM STM.retry
+
orElse = \a0 a1 -> WrappedSTM (STM.orElse (unwrapSTM a0) (unwrapSTM a1))
+
check = WrappedSTM . STM.check
+
newTVar = WrappedSTM . STM.newTVar
+
newTVarIO = App . lift . STM.newTVarIO
+
readTVar = WrappedSTM . STM.readTVar
+
readTVarIO = App . lift . STM.readTVarIO
+
writeTVar = \a0 -> WrappedSTM . STM.writeTVar a0
+
modifyTVar = \a0 -> WrappedSTM . STM.modifyTVar a0
+
modifyTVar' = \a0 -> WrappedSTM . STM.modifyTVar' a0
+
stateTVar = \a0 -> WrappedSTM . STM.stateTVar a0
+
swapTVar = \a0 -> WrappedSTM . STM.swapTVar a0
+
newTMVar = WrappedSTM . STM.newTMVar
+
newTMVarIO = App . lift . STM.newTMVarIO
+
newEmptyTMVar = WrappedSTM STM.newEmptyTMVar
+
newEmptyTMVarIO = App (lift STM.newEmptyTMVarIO)
+
takeTMVar = WrappedSTM . STM.takeTMVar
+
tryTakeTMVar = WrappedSTM . STM.tryTakeTMVar
+
putTMVar = \a0 -> WrappedSTM . STM.putTMVar a0
+
tryPutTMVar = \a0 -> WrappedSTM . STM.tryPutTMVar a0
+
readTMVar = WrappedSTM . STM.readTMVar
+
tryReadTMVar = WrappedSTM . STM.tryReadTMVar
+
swapTMVar = \a0 -> WrappedSTM . STM.swapTMVar a0
+
isEmptyTMVar = WrappedSTM . STM.isEmptyTMVar
+
newTQueue = WrappedSTM STM.newTQueue
+
newTQueueIO = App (lift STM.newTQueueIO)
+
readTQueue = WrappedSTM . STM.readTQueue
+
tryReadTQueue = WrappedSTM . STM.tryReadTQueue
+
peekTQueue = WrappedSTM . STM.peekTQueue
+
tryPeekTQueue = WrappedSTM . STM.tryPeekTQueue
+
flushTBQueue = WrappedSTM . STM.flushTBQueue
+
writeTQueue = \a0 -> WrappedSTM . STM.writeTQueue a0
+
isEmptyTQueue = WrappedSTM . STM.isEmptyTQueue
+
newTBQueue = WrappedSTM . STM.newTBQueue
+
newTBQueueIO = App . lift . STM.newTBQueueIO
+
readTBQueue = WrappedSTM . STM.readTBQueue
+
tryReadTBQueue = WrappedSTM . STM.tryReadTBQueue
+
peekTBQueue = WrappedSTM . STM.peekTBQueue
+
tryPeekTBQueue = WrappedSTM . STM.tryPeekTBQueue
+
writeTBQueue = \a0 -> WrappedSTM . STM.writeTBQueue a0
+
lengthTBQueue = WrappedSTM . STM.lengthTBQueue
+
isEmptyTBQueue = WrappedSTM . STM.isEmptyTBQueue
+
isFullTBQueue = WrappedSTM . STM.isFullTBQueue
+
newtype WrappedAsync a = WrappedAsync { unwrapAsync :: Async.Async a }
+
deriving newtype (Functor)
+
instance MonadAsync App where
+
type Async App = WrappedAsync
+
async = \(App (ReaderT m)) -> App (ReaderT $ \r -> WrappedAsync <$> async (m r))
+
asyncThreadId = Async.asyncThreadId . unwrapAsync
+
pollSTM = WrappedSTM . Async.pollSTM . unwrapAsync
+
waitCatchSTM = WrappedSTM . Async.waitCatchSTM . unwrapAsync
+
cancel = App . lift . Async.cancel . unwrapAsync
+
cancelWith = \a0 -> App . lift . Async.cancelWith (unwrapAsync a0)
+
asyncWithUnmask = \restore -> App $ ReaderT $ \r ->
+
fmap WrappedAsync $ Async.asyncWithUnmask $ \unmask ->
+
runReaderT (unApp (restore (liftF unmask))) r
+
liftF :: (IO a -> IO a) -> App a -> App a
+
liftF g (App (ReaderT f)) = App (ReaderT (g . f))