{-# options_haddock prune #-}
-- |Description: Interrupt interpreters
module Polysemy.Conc.Interrupt where

import qualified Control.Concurrent.Async as A
import Control.Concurrent.Async (AsyncCancelled)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text.IO as Text
import Polysemy (getInspectorT, inspect, interpretH, runT)
import Polysemy.Async (Async, async, await, cancel)
import Polysemy.Internal.Tactics (liftT)
import Polysemy.Time (Seconds(Seconds))
import System.Posix.Signals (Handler(CatchOnce, CatchInfoOnce), SignalInfo, installHandler, keyboardSignal)

import qualified Polysemy.Conc.Data.Critical as Critical
import Polysemy.Conc.Data.Critical (Critical)
import Polysemy.Conc.Data.Interrupt (Interrupt(..))
import Polysemy.Conc.Data.Race (Race)
import qualified Polysemy.Conc.Data.Sync as Sync
import Polysemy.Conc.Race (race_)
import Polysemy.Conc.Sync (interpretSync)

putErr ::
  Member (Embed IO) r =>
  Text ->
  Sem r ()
putErr :: Text -> Sem r ()
putErr =
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> (Text -> IO ()) -> Text -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr

data InterruptState =
  InterruptState {
    InterruptState -> MVar ()
quit :: !(MVar ()),
    InterruptState -> MVar ()
finished :: !(MVar ()),
    InterruptState -> Set Text
listeners :: !(Set Text),
    InterruptState -> SignalInfo -> IO ()
original :: !(SignalInfo -> IO ()),
    InterruptState -> Map Text (IO ())
handlers :: !(Map Text (IO ()))
  }

modListeners :: (Set Text -> Set Text) -> InterruptState -> InterruptState
modListeners :: (Set Text -> Set Text) -> InterruptState -> InterruptState
modListeners Set Text -> Set Text
f s :: InterruptState
s@InterruptState {Set Text
listeners :: Set Text
$sel:listeners:InterruptState :: InterruptState -> Set Text
listeners} =
  InterruptState
s {$sel:listeners:InterruptState :: Set Text
listeners = Set Text -> Set Text
f Set Text
listeners}

modHandlers :: (Map Text (IO ()) -> Map Text (IO ())) -> InterruptState -> InterruptState
modHandlers :: (Map Text (IO ()) -> Map Text (IO ()))
-> InterruptState -> InterruptState
modHandlers Map Text (IO ()) -> Map Text (IO ())
f s :: InterruptState
s@InterruptState {Map Text (IO ())
handlers :: Map Text (IO ())
$sel:handlers:InterruptState :: InterruptState -> Map Text (IO ())
handlers} =
  InterruptState
s {$sel:handlers:InterruptState :: Map Text (IO ())
handlers = Map Text (IO ()) -> Map Text (IO ())
f Map Text (IO ())
handlers}

waitQuit ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Sem r ()
waitQuit :: Sem r ()
waitQuit = do
  MVar ()
mv <- (InterruptState -> MVar ()) -> Sem r (MVar ())
forall s s' (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets InterruptState -> MVar ()
quit
  MVar () -> Sem r ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
readMVar MVar ()
mv

checkListeners ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Sem r ()
checkListeners :: Sem r ()
checkListeners =
  Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((InterruptState -> Bool) -> Sem r Bool
forall s s' (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets (Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text -> Bool)
-> (InterruptState -> Set Text) -> InterruptState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterruptState -> Set Text
listeners)) do
    MVar ()
fin <- (InterruptState -> MVar ()) -> Sem r (MVar ())
forall s s' (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets InterruptState -> MVar ()
finished
    Sem r Bool -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar () -> () -> Sem r Bool
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m Bool
tryPutMVar MVar ()
fin ())

onQuit ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Text ->
  Sem r a ->
  Sem r a
onQuit :: Text -> Sem r a -> Sem r a
onQuit Text
name Sem r a
ma = do
  (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' ((Set Text -> Set Text) -> InterruptState -> InterruptState
modListeners (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
name))
  Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
waitQuit
  a
a <- Sem r a
ma
  (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' ((Set Text -> Set Text) -> InterruptState -> InterruptState
modListeners (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.delete Text
name))
  Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
checkListeners
  pure a
a

processHandler ::
  Member (Embed IO) r =>
  Text ->
  IO () ->
  Sem r ()
processHandler :: Text -> IO () -> Sem r ()
processHandler Text
name IO ()
thunk = do
  Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr [qt|processing interrupt handler: #{name}|]
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO ()
thunk

execInterrupt ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Sem r (SignalInfo -> Sem r ())
execInterrupt :: Sem r (SignalInfo -> Sem r ())
execInterrupt = do
  InterruptState MVar ()
quitSignal MVar ()
finishSignal Set Text
_ SignalInfo -> IO ()
orig Map Text (IO ())
_ <- Sem r InterruptState
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
Sem r s
atomicGet
  MVar () -> () -> Sem r ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar ()
quitSignal ()
  ((Text, IO ()) -> Sem r ()) -> [(Text, IO ())] -> Sem r ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((Text -> IO () -> Sem r ()) -> (Text, IO ()) -> Sem r ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> IO () -> Sem r ()
processHandler) ([(Text, IO ())] -> Sem r ())
-> (Map Text (IO ()) -> [(Text, IO ())])
-> Map Text (IO ())
-> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (IO ()) -> [(Text, IO ())]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text (IO ()) -> Sem r ())
-> Sem r (Map Text (IO ())) -> Sem r ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (InterruptState -> Map Text (IO ())) -> Sem r (Map Text (IO ()))
forall s s' (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets InterruptState -> Map Text (IO ())
handlers
  Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
checkListeners
  MVar () -> Sem r ()
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar MVar ()
finishSignal
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ())
-> (SignalInfo -> IO ()) -> SignalInfo -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalInfo -> IO ()
orig (SignalInfo -> Sem r ())
-> Sem r () -> Sem r (SignalInfo -> Sem r ())
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr Text
"interrupt handlers finished"

registerHandler ::
  Member (AtomicState InterruptState) r =>
  Text ->
  IO () ->
  Sem r ()
registerHandler :: Text -> IO () -> Sem r ()
registerHandler Text
name IO ()
handler =
  (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' ((Map Text (IO ()) -> Map Text (IO ()))
-> InterruptState -> InterruptState
modHandlers (Text -> IO () -> Map Text (IO ()) -> Map Text (IO ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name IO ()
handler))

awaitOrKill ::
  Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
  Text ->
  A.Async (Maybe a) ->
  Sem r (Maybe a)
awaitOrKill :: Text -> Async (Maybe a) -> Sem r (Maybe a)
awaitOrKill Text
desc Async (Maybe a)
handle = do
  Sem (Sync () : r) (Maybe a) -> Sem r (Maybe a)
forall d (r :: [(* -> *) -> * -> *]).
Members '[Race, Embed IO] r =>
InterpreterFor (Sync d) r
interpretSync @() do
    Sem (Sync () : r) (Maybe a)
-> Sem (Sync () : r) (Maybe a) -> Sem (Sync () : r) (Maybe a)
forall (r :: [(* -> *) -> * -> *]) a.
Member Race r =>
Sem r a -> Sem r a -> Sem r a
race_ (Sem (Sync () : r) (Maybe a) -> Sem (Sync () : r) (Maybe a)
catchCritical (Async (Maybe a) -> Sem (Sync () : r) (Maybe a)
forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError Async r =>
Async a -> Sem r a
await Async (Maybe a)
handle)) Sem (Sync () : r) (Maybe a)
kill
  where
    catchCritical :: Sem (Sync () : r) (Maybe a) -> Sem (Sync () : r) (Maybe a)
catchCritical =
      Sem (Sync () : r) (Maybe a)
-> (a -> Sem (Sync () : r) (Maybe a))
-> Maybe a
-> Sem (Sync () : r) (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Sem (Sync () : r) (Maybe a)
forall a. Sem (Sync () : r) (Maybe a)
waitKill (Maybe a -> Sem (Sync () : r) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Sem (Sync () : r) (Maybe a))
-> (a -> Maybe a) -> a -> Sem (Sync () : r) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) (Maybe a -> Sem (Sync () : r) (Maybe a))
-> (Sem (Sync () : r) (Maybe a) -> Sem (Sync () : r) (Maybe a))
-> Sem (Sync () : r) (Maybe a)
-> Sem (Sync () : r) (Maybe a)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Maybe a
-> Sem (Sync () : r) (Maybe a) -> Sem (Sync () : r) (Maybe a)
forall e a (r :: [(* -> *) -> * -> *]).
(Exception e, Member Critical r) =>
a -> Sem r a -> Sem r a
Critical.catchAs @AsyncCancelled Maybe a
forall a. Maybe a
Nothing
    waitKill :: Sem (Sync () : r) (Maybe a)
waitKill =
      Maybe a
forall a. Maybe a
Nothing Maybe a
-> Sem (Sync () : r) (Maybe ()) -> Sem (Sync () : r) (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Seconds -> Sem (Sync () : r) (Maybe ())
forall d (r :: [(* -> *) -> * -> *]) u.
(MemberWithError (Sync d) r, TimeUnit u) =>
u -> Sem r (Maybe d)
Sync.wait @() (Int64 -> Seconds
Seconds Int64
1)
    kill :: Sem (Sync () : r) (Maybe a)
kill = do
      Text -> Sem (Sync () : r) (Maybe a) -> Sem (Sync () : r) (Maybe a)
forall (r :: [(* -> *) -> * -> *]) a.
Members '[AtomicState InterruptState, Embed IO] r =>
Text -> Sem r a -> Sem r a
onQuit Text
desc do
        Text -> Sem (Sync () : r) ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr [qt|killing #{desc}|]
        Async (Maybe a) -> Sem (Sync () : r) ()
forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError Async r =>
Async a -> Sem r ()
cancel Async (Maybe a)
handle
        Text -> Sem (Sync () : r) ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr [qt|killed #{desc}|]
        () -> Sem (Sync () : r) ()
forall d (r :: [(* -> *) -> * -> *]).
MemberWithError (Sync d) r =>
d -> Sem r ()
Sync.putBlock ()
        pure Maybe a
forall a. Maybe a
Nothing

interpretInterruptState ::
  Members [AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
  InterpreterFor Interrupt r
interpretInterruptState :: InterpreterFor Interrupt r
interpretInterruptState =
  (forall x (rInitial :: [(* -> *) -> * -> *]).
 Interrupt (Sem rInitial) x
 -> Tactical Interrupt (Sem rInitial) r x)
-> Sem (Interrupt : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Register name handler ->
      Sem r () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Text -> IO () -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (AtomicState InterruptState) r =>
Text -> IO () -> Sem r ()
registerHandler Text
name IO ()
handler)
    Unregister name ->
      Sem r () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ()))
-> Sem r ()
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall a b. (a -> b) -> a -> b
$ (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' \ s :: InterruptState
s@InterruptState {Map Text (IO ())
handlers :: Map Text (IO ())
$sel:handlers:InterruptState :: InterruptState -> Map Text (IO ())
handlers} -> InterruptState
s {$sel:handlers:InterruptState :: Map Text (IO ())
handlers = Text -> Map Text (IO ()) -> Map Text (IO ())
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
name Map Text (IO ())
handlers}
    Interrupt (Sem rInitial) x
WaitQuit ->
      Sem r () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
waitQuit
    Interrupt (Sem rInitial) x
Quit ->
      Sem r () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT do
        Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr Text
"manual interrupt"
        Sem r (SignalInfo -> Sem r ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Sem r (SignalInfo -> Sem r ())
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r (SignalInfo -> Sem r ())
execInterrupt
    Interrupt (Sem rInitial) x
Interrupted ->
      Sem r Bool
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f Bool)
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r Bool
 -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f Bool))
-> (MVar () -> Sem r Bool)
-> MVar ()
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe () -> Bool) -> Sem r (Maybe ()) -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Sem r (Maybe ()) -> Sem r Bool)
-> (MVar () -> Sem r (Maybe ())) -> MVar () -> Sem r Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> Sem r (Maybe ())
forall (m :: * -> *) a. MonadIO m => MVar a -> m (Maybe a)
tryReadMVar (MVar ()
 -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f Bool))
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (MVar ())
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (InterruptState -> MVar ())
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (MVar ())
forall s s' (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets InterruptState -> MVar ()
quit
    KillOnQuit desc ma -> do
      Sem (Interrupt : r) (f a)
maT <- Sem rInitial a
-> Sem
     (WithTactics Interrupt f (Sem rInitial) r)
     (Sem (Interrupt : r) (f a))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a
ma
      Inspector f
ins <- Sem (WithTactics Interrupt f (Sem rInitial) r) (Inspector f)
forall (e :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
      Async (Maybe (f a))
handle <- Sem r (Async (Maybe (f a)))
-> Sem
     (WithTactics Interrupt f (Sem rInitial) r) (Async (Maybe (f a)))
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem (Interrupt : r) (Async (Maybe (f a)))
-> Sem r (Async (Maybe (f a)))
forall (r :: [(* -> *) -> * -> *]).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterruptState (Sem (Interrupt : r) (f a)
-> Sem (Interrupt : r) (Async (Maybe (f a)))
forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError Async r =>
Sem r a -> Sem r (Async (Maybe a))
async Sem (Interrupt : r) (f a)
maT))
      f (Maybe (f a))
result <- Sem r (Maybe (f a))
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f (Maybe (f a)))
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Text -> Async (Maybe (f a)) -> Sem r (Maybe (f a))
forall (r :: [(* -> *) -> * -> *]) a.
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
Text -> Async (Maybe a) -> Sem r (Maybe a)
awaitOrKill Text
desc Async (Maybe (f a))
handle)
      pure (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (Maybe (f a) -> Maybe (Maybe a)) -> Maybe (f a) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a -> Maybe a) -> Maybe (f a) -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins) (Maybe (f a) -> Maybe a) -> f (Maybe (f a)) -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe (f a))
result)
{-# INLINE interpretInterruptState #-}

broadcastInterrupt ::
  Members [AtomicState InterruptState, Embed IO] r =>
  SignalInfo ->
  Sem r ()
broadcastInterrupt :: SignalInfo -> Sem r ()
broadcastInterrupt SignalInfo
sig = do
  Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr Text
"caught interrupt signal"
  SignalInfo -> Sem r ()
orig <- Sem r (SignalInfo -> Sem r ())
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r (SignalInfo -> Sem r ())
execInterrupt
  SignalInfo -> Sem r ()
orig SignalInfo
sig

-- The original handler is either the default handler that kills all threads or a handler installed by an environment
-- like ghcid.
-- In the latter case, not calling it results in ghcid misbehaving.
-- To distinguish the two cases, the constructor used by the default is 'Catch', while a custom handler should usually
-- use 'CatchOnce', since you don't want to catch repeated occurences of SIGINT, as it will surely cause problems.
originalHandler :: Handler -> (SignalInfo -> IO ())
originalHandler :: Handler -> SignalInfo -> IO ()
originalHandler (CatchOnce IO ()
thunk) =
  (IO () -> SignalInfo -> IO ()
forall a b. a -> b -> a
const IO ()
thunk)
originalHandler (CatchInfoOnce SignalInfo -> IO ()
thunk) =
  SignalInfo -> IO ()
thunk
originalHandler Handler
_ =
  IO () -> SignalInfo -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass
{-# INLINE originalHandler #-}

installSignalHandler ::
  TVar InterruptState ->
  IO Handler
installSignalHandler :: TVar InterruptState -> IO Handler
installSignalHandler TVar InterruptState
state =
  Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
keyboardSignal ((SignalInfo -> IO ()) -> Handler
CatchInfoOnce SignalInfo -> IO ()
handler) Maybe SignalSet
forall a. Maybe a
Nothing
  where
    handler :: SignalInfo -> IO ()
handler SignalInfo
sig =
      Sem '[Final IO] () -> IO ()
forall (m :: * -> *) a. Monad m => Sem '[Final m] a -> m a
runFinal (Sem '[Final IO] () -> IO ()) -> Sem '[Final IO] () -> IO ()
forall a b. (a -> b) -> a -> b
$ forall (r :: [(* -> *) -> * -> *]) a.
(Member (Final IO) r, Functor IO) =>
Sem (Embed IO : r) a -> Sem r a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
Sem (Embed m : r) a -> Sem r a
embedToFinal @IO (Sem '[Embed IO, Final IO] () -> Sem '[Final IO] ())
-> Sem '[Embed IO, Final IO] () -> Sem '[Final IO] ()
forall a b. (a -> b) -> a -> b
$ TVar InterruptState
-> Sem '[AtomicState InterruptState, Embed IO, Final IO] ()
-> Sem '[Embed IO, Final IO] ()
forall (r :: [(* -> *) -> * -> *]) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar InterruptState
state (SignalInfo
-> Sem '[AtomicState InterruptState, Embed IO, Final IO] ()
forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
SignalInfo -> Sem r ()
broadcastInterrupt SignalInfo
sig)

-- |Interpret 'Interrupt' by installing a signal handler.
interpretInterrupt ::
  Members [Critical, Race, Async, Embed IO] r =>
  InterpreterFor Interrupt r
interpretInterrupt :: InterpreterFor Interrupt r
interpretInterrupt Sem (Interrupt : r) a
sem = do
  MVar ()
quitMVar <- Sem r (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  MVar ()
finishMVar <- Sem r (MVar ())
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  TVar InterruptState
state <- InterruptState -> Sem r (TVar InterruptState)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (MVar ()
-> MVar ()
-> Set Text
-> (SignalInfo -> IO ())
-> Map Text (IO ())
-> InterruptState
InterruptState MVar ()
quitMVar MVar ()
finishMVar Set Text
forall a. Set a
Set.empty (IO () -> SignalInfo -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
pass) Map Text (IO ())
forall k a. Map k a
Map.empty)
  Handler
orig <- IO Handler -> Sem r Handler
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Handler -> Sem r Handler) -> IO Handler -> Sem r Handler
forall a b. (a -> b) -> a -> b
$ TVar InterruptState -> IO Handler
installSignalHandler TVar InterruptState
state
  TVar InterruptState
-> Sem (AtomicState InterruptState : r) a -> Sem r a
forall (r :: [(* -> *) -> * -> *]) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar InterruptState
state do
    (InterruptState -> InterruptState)
-> Sem (AtomicState InterruptState : r) ()
forall s (r :: [(* -> *) -> * -> *]).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' \ InterruptState
s -> InterruptState
s {$sel:original:InterruptState :: SignalInfo -> IO ()
original = Handler -> SignalInfo -> IO ()
originalHandler Handler
orig}
    Sem (Interrupt : AtomicState InterruptState : r) a
-> Sem (AtomicState InterruptState : r) a
forall (r :: [(* -> *) -> * -> *]).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterruptState (Sem (Interrupt : AtomicState InterruptState : r) a
 -> Sem (AtomicState InterruptState : r) a)
-> Sem (Interrupt : AtomicState InterruptState : r) a
-> Sem (AtomicState InterruptState : r) a
forall a b. (a -> b) -> a -> b
$ Sem (Interrupt : r) a
-> Sem (Interrupt : AtomicState InterruptState : r) a
forall (e2 :: (* -> *) -> * -> *) (e1 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder Sem (Interrupt : r) a
sem
{-# INLINE interpretInterrupt #-}