{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Observe.Event.Crash
( withScheduleCrash,
ScheduleCrash,
DoCrash,
hoistScheduleCrash,
Crashing (..),
renderCrashing,
)
where
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Unlift
import Data.Void
import Observe.Event
import Observe.Event.Render.JSON
withScheduleCrash ::
(MonadUnliftIO m) =>
EventBackend m r Crashing ->
DoCrash m ->
(ScheduleCrash m r -> m a) ->
m a
withScheduleCrash :: forall (m :: * -> *) r a.
MonadUnliftIO m =>
EventBackend m r Crashing
-> DoCrash m -> (ScheduleCrash m r -> m a) -> m a
withScheduleCrash EventBackend m r Crashing
backend DoCrash m
crash ScheduleCrash m r -> m a
go = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO -> do
MVar (Maybe r)
scheduleCrashChan <- forall a. IO (MVar a)
newEmptyMVar
let waitForCrash :: IO ()
waitForCrash = do
Maybe r
cause <- forall a. MVar a -> IO a
takeMVar MVar (Maybe r)
scheduleCrashChan
forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent (forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
(Functor m, Functor n) =>
(forall x. m x -> n x) -> EventBackend m r s -> EventBackend n r s
hoistEventBackend forall a. m a -> IO a
runInIO EventBackend m r Crashing
backend) Crashing Void
Crashing \Event IO r Crashing Void
ev ->
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
(forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> r -> m ()
addProximate Event IO r Crashing Void
ev)
Maybe r
cause
forall a. m a -> IO a
runInIO DoCrash m
crash
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO ()
waitForCrash \Async ()
_ ->
forall a. m a -> IO a
runInIO forall a b. (a -> b) -> a -> b
$ ScheduleCrash m r -> m a
go forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MVar a -> a -> IO Bool
tryPutMVar MVar (Maybe r)
scheduleCrashChan
type ScheduleCrash m r = Maybe r -> m ()
type DoCrash m = m ()
hoistScheduleCrash ::
(forall x. f x -> g x) ->
ScheduleCrash f r ->
ScheduleCrash g r
hoistScheduleCrash :: forall (f :: * -> *) (g :: * -> *) r.
(forall x. f x -> g x) -> ScheduleCrash f r -> ScheduleCrash g r
hoistScheduleCrash forall x. f x -> g x
nt ScheduleCrash f r
s = forall x. f x -> g x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScheduleCrash f r
s
data Crashing f where
Crashing :: Crashing Void
renderCrashing :: RenderSelectorJSON Crashing
renderCrashing :: RenderSelectorJSON Crashing
renderCrashing Crashing f
Crashing = (Key
"crashing", forall a. Void -> a
absurd)