{-# options_haddock prune #-}
{-# language FieldSelectors #-}

-- | Description: Interrupt interpreters
module Polysemy.Process.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 qualified Polysemy.Conc.Effect.Critical as Critical
import Polysemy.Conc.Effect.Critical (Critical)
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_)
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 Polysemy.Process.Effect.Interrupt (Interrupt (..))

putErr ::
  Member (Embed IO) r =>
  Bool ->
  Text ->
  Sem r ()
putErr :: forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr = \case
  Bool
True -> IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) 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
  Bool
False -> Sem r () -> Text -> Sem r ()
forall a b. a -> b -> a
const Sem r ()
forall (f :: * -> *). Applicative f => f ()
unit

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
$sel:listeners:InterruptState :: InterruptState -> Set Text
listeners :: 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 ())
$sel:handlers:InterruptState :: InterruptState -> Map Text (IO ())
handlers :: 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 :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
waitQuit = do
  MVar ()
mv <- (InterruptState -> MVar ()) -> Sem r (MVar ())
forall s s' (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets InterruptState -> MVar ()
quit
  IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) 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 :: EffectRow).
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 :: EffectRow).
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 :: EffectRow).
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 :: EffectRow) 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 :: EffectRow) 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 :: EffectRow).
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 :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
waitQuit
  a
a <- Sem r a
ma
  (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: EffectRow).
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 :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
checkListeners
  pure a
a

processHandler ::
  Member (Embed IO) r =>
  Bool ->
  Text ->
  IO () ->
  Sem r ()
processHandler :: forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> IO () -> Sem r ()
processHandler Bool
verbose Text
name IO ()
thunk = do
  Bool -> Text -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr Bool
verbose (Text
"processing interrupt handler: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name)
  IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO ()
thunk

execInterrupt ::
  Members [AtomicState InterruptState, Embed IO] r =>
  Bool ->
  Sem r (SignalInfo -> Sem r ())
execInterrupt :: forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Bool -> Sem r (SignalInfo -> Sem r ())
execInterrupt Bool
verbose = do
  InterruptState MVar ()
quitSignal MVar ()
finishSignal Set Text
_ SignalInfo -> IO ()
orig Map Text (IO ())
_ <- Sem r InterruptState
forall s (r :: EffectRow). 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 :: EffectRow) 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 (Bool -> Text -> IO () -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> IO () -> Sem r ()
processHandler Bool
verbose)) ([(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 :: EffectRow).
Member (AtomicState s) r =>
(s -> s') -> Sem r s'
atomicGets InterruptState -> Map Text (IO ())
handlers
    Sem r ()
forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
checkListeners
    IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) 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 :: EffectRow) 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 a b. a -> Sem r b -> Sem r a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Text -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr Bool
verbose Text
"interrupt handlers finished"

registerHandler ::
  Member (AtomicState InterruptState) r =>
  Text ->
  IO () ->
  Sem r ()
registerHandler :: forall (r :: EffectRow).
Member (AtomicState InterruptState) r =>
Text -> IO () -> Sem r ()
registerHandler Text
name IO ()
handler =
  (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: EffectRow).
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 =>
  Bool ->
  Text ->
  A.Async (Maybe a) ->
  Sem r (Maybe a)
awaitOrKill :: forall (r :: EffectRow) a.
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
Bool -> Text -> Async (Maybe a) -> Sem r (Maybe a)
awaitOrKill Bool
verbose Text
desc Async (Maybe a)
handle = do
  forall d (r :: EffectRow).
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 :: EffectRow) 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 :: EffectRow) a. Member 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 a. a -> Sem (Sync () : r) 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 :: EffectRow).
(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 a b. a -> Sem (Sync () : r) b -> Sem (Sync () : r) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall d (r :: EffectRow) u.
(Member (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 :: EffectRow) a.
Members '[AtomicState InterruptState, Embed IO] r =>
Text -> Sem r a -> Sem r a
onQuit Text
desc do
        Bool -> Text -> Sem (Sync () : r) ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr Bool
verbose (Text
"killing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc)
        Async (Maybe a) -> Sem (Sync () : r) ()
forall (r :: EffectRow) a. Member Async r => Async a -> Sem r ()
cancel Async (Maybe a)
handle
        Bool -> Text -> Sem (Sync () : r) ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr Bool
verbose (Text
"killed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc)
        () -> Sem (Sync () : r) ()
forall d (r :: EffectRow). Member (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 =>
  Bool ->
  InterpreterFor Interrupt r
interpretInterruptState :: forall (r :: EffectRow).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
Bool -> InterpreterFor Interrupt r
interpretInterruptState Bool
verbose =
  (forall (rInitial :: EffectRow) x.
 Interrupt (Sem rInitial) x
 -> Tactical Interrupt (Sem rInitial) r x)
-> Sem (Interrupt : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall (rInitial :: EffectRow) 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 x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Text -> IO () -> Sem r ()
forall (r :: EffectRow).
Member (AtomicState InterruptState) r =>
Text -> IO () -> Sem r ()
registerHandler Text
name IO ()
handler)
    Unregister Text
name ->
      Sem r x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x))
-> Sem r x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall a b. (a -> b) -> a -> b
$ (InterruptState -> InterruptState) -> Sem r ()
forall s (r :: EffectRow).
Member (AtomicState s) r =>
(s -> s) -> Sem r ()
atomicModify' \ s :: InterruptState
s@InterruptState {Map Text (IO ())
$sel:handlers:InterruptState :: InterruptState -> Map Text (IO ())
handlers :: 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 x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT Sem r x
Sem r ()
forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Sem r ()
waitQuit
    Interrupt (Sem rInitial) x
Quit ->
      Sem r x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT do
        Bool -> Text -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr Bool
verbose Text
"manual interrupt"
        Sem r (SignalInfo -> Sem r ()) -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Bool -> Sem r (SignalInfo -> Sem r ())
forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Bool -> Sem r (SignalInfo -> Sem r ())
execInterrupt Bool
verbose)
    Interrupt (Sem rInitial) x
Interrupted ->
      Sem r x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall (m :: * -> *) (f :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Sem r x -> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x))
-> (MVar () -> Sem r x)
-> MVar ()
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe () -> x) -> Sem r (Maybe ()) -> Sem r x
forall a b. (a -> b) -> Sem r a -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe () -> x
Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Sem r (Maybe ()) -> Sem r x)
-> (MVar () -> Sem r (Maybe ())) -> MVar () -> Sem r x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe ()) -> Sem r (Maybe ())
forall (m :: * -> *) (r :: EffectRow) 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 x))
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (MVar ())
-> Sem (WithTactics Interrupt f (Sem rInitial) r) (f x)
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 :: EffectRow).
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 :: EffectRow).
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 :: EffectRow).
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 :: EffectRow) a.
Sem r a -> Sem (e : r) a
raise (Bool -> InterpreterFor Interrupt r
forall (r :: EffectRow).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
Bool -> InterpreterFor Interrupt r
interpretInterruptState Bool
verbose (Sem (Interrupt : r) (f a1)
-> Sem (Interrupt : r) (Async (Maybe (f a1)))
forall (r :: EffectRow) a.
Member 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 :: EffectRow)
       (e :: (* -> *) -> * -> *) a.
Functor f =>
Sem r a -> Sem (WithTactics e f m r) (f a)
liftT (Bool -> Text -> Async (Maybe (f a1)) -> Sem r (Maybe (f a1))
forall (r :: EffectRow) a.
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
Bool -> Text -> Async (Maybe a) -> Sem r (Maybe a)
awaitOrKill Bool
verbose Text
desc Async (Maybe (f a1))
handle)
      pure (Maybe (Maybe a1) -> x
Maybe (Maybe a1) -> Maybe a1
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a1) -> x)
-> (Maybe (f a1) -> Maybe (Maybe a1)) -> Maybe (f a1) -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f a1 -> Maybe a1) -> Maybe (f a1) -> Maybe (Maybe a1)
forall a b. (a -> b) -> Maybe a -> Maybe b
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) -> x) -> f (Maybe (f a1)) -> f x
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 =>
  Bool ->
  SignalInfo ->
  Sem r ()
broadcastInterrupt :: forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Bool -> SignalInfo -> Sem r ()
broadcastInterrupt Bool
verbose SignalInfo
sig = do
  Bool -> Text -> Sem r ()
forall (r :: EffectRow).
Member (Embed IO) r =>
Bool -> Text -> Sem r ()
putErr Bool
verbose Text
"caught interrupt signal"
  SignalInfo -> Sem r ()
orig <- Bool -> Sem r (SignalInfo -> Sem r ())
forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Bool -> Sem r (SignalInfo -> Sem r ())
execInterrupt Bool
verbose
  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 ::
  Bool ->
  TVar InterruptState ->
  ((SignalInfo -> IO ()) -> Handler) ->
  IO Handler
installSignalHandler :: Bool
-> TVar InterruptState
-> ((SignalInfo -> IO ()) -> Handler)
-> IO Handler
installSignalHandler Bool
verbose 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 :: EffectRow) 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 :: EffectRow) s a.
Member (Embed IO) r =>
TVar s -> Sem (AtomicState s : r) a -> Sem r a
runAtomicStateTVar TVar InterruptState
state (Bool
-> SignalInfo
-> Sem '[AtomicState InterruptState, Embed IO, Final IO] ()
forall (r :: EffectRow).
Members '[AtomicState InterruptState, Embed IO] r =>
Bool -> SignalInfo -> Sem r ()
broadcastInterrupt Bool
verbose SignalInfo
sig)

-- | Interpret 'Interrupt' by installing a signal handler.
--
-- Takes a constructor for 'Handler'.
interpretInterruptWith' ::
  Members [Critical, Race, Async, Embed IO] r =>
  Bool ->
  ((SignalInfo -> IO ()) -> Handler) ->
  InterpreterFor Interrupt r
interpretInterruptWith' :: forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
Bool
-> ((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
interpretInterruptWith' Bool
verbose (SignalInfo -> IO ()) -> Handler
consHandler Sem (Interrupt : r) a
sem = do
  MVar ()
quitMVar <- IO (MVar ()) -> Sem r (MVar ())
forall (m :: * -> *) (r :: EffectRow) 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 :: EffectRow) 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 :: EffectRow) 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 :: EffectRow) 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
$ Bool
-> TVar InterruptState
-> ((SignalInfo -> IO ()) -> Handler)
-> IO Handler
installSignalHandler Bool
verbose TVar InterruptState
state (SignalInfo -> IO ()) -> Handler
consHandler
  TVar InterruptState
-> Sem (AtomicState InterruptState : r) a -> Sem r a
forall (r :: EffectRow) 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 :: EffectRow).
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}
    Bool -> InterpreterFor Interrupt (AtomicState InterruptState : r)
forall (r :: EffectRow).
Members
  '[AtomicState InterruptState, Critical, Race, Async, Embed IO] r =>
Bool -> InterpreterFor Interrupt r
interpretInterruptState Bool
verbose (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 :: EffectRow) a.
Sem (e1 : r) a -> Sem (e1 : e2 : r) a
raiseUnder Sem (Interrupt : r) a
sem

interpretInterruptWith ::
  Members [Critical, Race, Async, Embed IO] r =>
  ((SignalInfo -> IO ()) -> Handler) ->
  InterpreterFor Interrupt r
interpretInterruptWith :: forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
interpretInterruptWith = Bool
-> ((SignalInfo -> IO ()) -> Handler)
-> forall {a}. Sem (Interrupt : r) a -> Sem r a
forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
Bool
-> ((SignalInfo -> IO ()) -> Handler) -> InterpreterFor Interrupt r
interpretInterruptWith' Bool
True

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

-- | 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 :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterrupt =
  Bool -> InterpreterFor Interrupt r
forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
Bool -> InterpreterFor Interrupt r
interpretInterrupt' Bool
True

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

-- | 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 :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
InterpreterFor Interrupt r
interpretInterruptOnce =
  Bool -> InterpreterFor Interrupt r
forall (r :: EffectRow).
Members '[Critical, Race, Async, Embed IO] r =>
Bool -> InterpreterFor Interrupt r
interpretInterruptOnce' Bool
True

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