{-# options_haddock prune #-}

-- |Description: Interrupt interpreters
module Polysemy.Conc.Interpreter.Interrupt where

import qualified Control.Concurrent.Async as A
import Control.Concurrent.Async (AsyncCancelled)
import Control.Concurrent.STM (TVar, newTVarIO)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text.IO as Text
import Polysemy.Internal.Tactics (liftT)
import Polysemy.Time (Seconds (Seconds))
import System.IO (stderr)
import System.Posix.Signals (
  Handler (Catch, CatchInfo, CatchInfoOnce, CatchOnce),
  SignalInfo,
  installHandler,
  keyboardSignal,
  )

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

putErr ::
  Member (Embed IO) r =>
  Text ->
  Sem r ()
putErr :: forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
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 :: forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
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
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
mv)

checkListeners ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Sem r ()
checkListeners :: forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
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 (IO Bool -> Sem r Bool
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
fin ()))

onQuit ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Text ->
  Sem r a ->
  Sem r a
onQuit :: forall (r :: [(* -> *) -> * -> *]) a.
Members '[AtomicState InterruptState, Embed IO] r =>
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 :: forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> IO () -> Sem r ()
processHandler Text
name IO ()
thunk = do
  Text -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Embed IO) r =>
Text -> Sem r ()
putErr (Text
"processing interrupt handler: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 :: forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
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
  Sem r Bool -> Sem r () -> Sem r ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (IO Bool -> Sem r Bool
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
quitSignal ())) do
    ((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
    IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (MVar () -> IO ()
forall a. MVar a -> IO 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 :: forall (r :: [(* -> *) -> * -> *]).
Member (AtomicState InterruptState) r =>
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 :: 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 a)
handle = do
  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
<=< 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
<$ 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 (Text
"killing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 (Text
"killed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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 :: forall (r :: [(* -> *) -> * -> *]).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterruptState =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Interrupt (Sem rInitial) x
 -> Tactical Interrupt (Sem rInitial) r x)
-> Sem (Interrupt : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Register Text
name IO ()
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 Text
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
. IO (Maybe ()) -> Sem r (Maybe ())
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Maybe ()) -> Sem r (Maybe ()))
-> (MVar () -> IO (Maybe ())) -> MVar () -> Sem r (Maybe ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar () -> IO (Maybe ())
forall a. MVar a -> IO (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 Text
desc Sem rInitial a1
ma -> do
      Sem (Interrupt : r) (f a1)
maT <- Sem rInitial a1
-> Sem
     (WithTactics Interrupt f (Sem rInitial) r)
     (Sem (Interrupt : r) (f a1))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT Sem rInitial a1
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 a1))
handle <- Sem r (Async (Maybe (f a1)))
-> Sem
     (WithTactics Interrupt f (Sem rInitial) r) (Async (Maybe (f a1)))
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem (Interrupt : r) (Async (Maybe (f a1)))
-> Sem r (Async (Maybe (f a1)))
forall (r :: [(* -> *) -> * -> *]).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterruptState (Sem (Interrupt : r) (f a1)
-> Sem (Interrupt : r) (Async (Maybe (f a1)))
forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError Async r =>
Sem r a -> Sem r (Async (Maybe a))
async Sem (Interrupt : r) (f a1)
maT))
      f (Maybe (f a1))
result <- Sem r (Maybe (f a1))
-> Sem
     (WithTactics Interrupt f (Sem rInitial) r) (f (Maybe (f a1)))
forall (m :: * -> *) (f :: * -> *) (r :: [(* -> *) -> * -> *])
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Text -> Async (Maybe (f a1)) -> Sem r (Maybe (f a1))
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 a1))
handle)
      pure (Maybe (Maybe a1) -> Maybe a1
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a1) -> Maybe a1)
-> (Maybe (f a1) -> Maybe (Maybe a1)) -> Maybe (f a1) -> Maybe a1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a1 -> Maybe a1) -> Maybe (f a1) -> Maybe (Maybe a1)
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 a1) -> Maybe a1) -> f (Maybe (f a1)) -> f (Maybe a1)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe (f a1))
result)
{-# inline interpretInterruptState #-}

broadcastInterrupt ::
  Members [AtomicState InterruptState, Embed IO] r =>
  SignalInfo ->
  Sem r ()
broadcastInterrupt :: forall (r :: [(* -> *) -> * -> *]).
Members '[AtomicState InterruptState, Embed IO] r =>
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 (Catch IO ()
thunk) =
  (IO () -> SignalInfo -> IO ()
forall a b. a -> b -> a
const IO ()
thunk)
originalHandler (CatchInfo SignalInfo -> IO ()
thunk) =
  SignalInfo -> IO ()
thunk
originalHandler Handler
_ =
  IO () -> SignalInfo -> IO ()
forall a b. a -> b -> a
const IO ()
forall (f :: * -> *). Applicative f => f ()
unit
{-# inline originalHandler #-}

installSignalHandler ::
  TVar InterruptState ->
  ((SignalInfo -> IO ()) -> Handler) ->
  IO Handler
installSignalHandler :: TVar InterruptState
-> ((SignalInfo -> IO ()) -> Handler) -> IO Handler
installSignalHandler TVar InterruptState
state (SignalInfo -> IO ()) -> Handler
consHandler =
  Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
keyboardSignal ((SignalInfo -> IO ()) -> Handler
consHandler 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 (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.
--
-- Takes a constructor for 'Handler'.
interpretInterruptWith ::
  Members [Critical, Race, Async, Embed IO] r =>
  ((SignalInfo -> IO ()) -> Handler) ->
  InterpreterFor Interrupt r
interpretInterruptWith :: forall (r :: [(* -> *) -> * -> *]).
Members '[Critical, Race, Async, Embed IO] r =>
((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
interpretInterruptWith (SignalInfo -> IO ()) -> Handler
consHandler Sem (Interrupt : r) a
sem = do
  MVar ()
quitMVar <- IO (MVar ()) -> Sem r (MVar ())
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  MVar ()
finishMVar <- IO (MVar ()) -> Sem r (MVar ())
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  TVar InterruptState
state <- IO (TVar InterruptState) -> Sem r (TVar InterruptState)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (InterruptState -> IO (TVar InterruptState)
forall a. a -> IO (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 ()
unit) 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
-> ((SignalInfo -> IO ()) -> Handler) -> IO Handler
installSignalHandler TVar InterruptState
state (SignalInfo -> IO ()) -> Handler
consHandler
  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

-- |Interpret 'Interrupt' by installing a signal handler.
--
-- Catches repeat invocations of SIGINT.
interpretInterrupt ::
  Members [Critical, Race, Async, Embed IO] r =>
  InterpreterFor Interrupt r
interpretInterrupt :: forall (r :: [(* -> *) -> * -> *]).
Members '[Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterrupt =
  ((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
forall (r :: [(* -> *) -> * -> *]).
Members '[Critical, Race, Async, Embed IO] r =>
((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
interpretInterruptWith (SignalInfo -> IO ()) -> Handler
CatchInfo

-- |Interpret 'Interrupt' by installing a signal handler.
--
-- Catches only the first invocation of SIGINT.
interpretInterruptOnce ::
  Members [Critical, Race, Async, Embed IO] r =>
  InterpreterFor Interrupt r
interpretInterruptOnce :: forall (r :: [(* -> *) -> * -> *]).
Members '[Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterruptOnce =
  ((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
forall (r :: [(* -> *) -> * -> *]).
Members '[Critical, Race, Async, Embed IO] r =>
((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
interpretInterruptWith (SignalInfo -> IO ()) -> Handler
CatchInfoOnce

-- |Eliminate 'Interrupt' without interpreting.
interpretInterruptNull ::
  InterpreterFor Interrupt r
interpretInterruptNull :: forall (r :: [(* -> *) -> * -> *]). InterpreterFor Interrupt r
interpretInterruptNull =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Interrupt (Sem rInitial) x
 -> Tactical Interrupt (Sem rInitial) r x)
-> Sem (Interrupt : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH \case
    Register Text
_ IO ()
_ ->
      () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT ()
    Unregister Text
_ ->
      () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT ()
    Interrupt (Sem rInitial) x
WaitQuit ->
      () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT ()
    Interrupt (Sem rInitial) x
Quit ->
      () -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f ())
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT ()
    Interrupt (Sem rInitial) x
Interrupted ->
      Bool -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f Bool)
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT Bool
False
    KillOnQuit Text
_ Sem rInitial a1
_ ->
      Maybe a1
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f (Maybe a1))
forall (f :: * -> *) a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
Functor f =>
a -> Sem (WithTactics e f m r) (f a)
pureT Maybe a1
forall a. Maybe a
Nothing