module Effects.System.Posix.Signals
  ( -- * Effect
    MonadPosixSignals (..),

    -- * Handler
    Handler (..),
    mapHandler,
    handlerToPosix,
    handlerFromPosix,

    -- * Re-exports
    Signal,
    SignalSet,
    ProcessID,
    ProcessGroupID,
  )
where

import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask)
import GHC.Stack.Types (HasCallStack)
import System.Posix.Signals (Signal, SignalInfo, SignalSet)
import System.Posix.Signals qualified as Signals
import System.Posix.Types (ProcessGroupID, ProcessID)

{- HLINT ignore "Redundant bracket" -}

-- | Class for unix signal effects.
--
-- @since 0.1
class (Monad m) => MonadPosixSignals m where
  -- | @since 0.1
  raiseSignal :: (HasCallStack) => Signal -> m ()

  -- | @since 0.1
  signalProcess :: Signal -> ProcessID -> m ()

  -- | @since 0.1
  signalProcessGroup :: Signal -> ProcessGroupID -> m ()

  -- | @since 0.1
  installHandler :: Signal -> Handler m -> Maybe SignalSet -> m (Handler m)

  -- | @since 0.1
  getSignalMask :: m SignalSet

  -- | @since 0.1
  setSignalMask :: SignalSet -> m ()

  -- | @since 0.1
  blockSignals :: SignalSet -> m ()

  -- | @since 0.1
  unblockSignals :: SignalSet -> m ()

  -- | @since 0.1
  scheduleAlarm :: Int -> m Int

  -- | @since 0.1
  getPendingSignals :: m SignalSet

  -- | @since 0.1
  awaitSignal :: Maybe SignalSet -> m ()

  -- | @since 0.1
  setStoppedChildFlag :: Bool -> m Bool

  -- | @since 0.1
  queryStoppedChildFlag :: m Bool

-- | @since 0.1
instance MonadPosixSignals IO where
  raiseSignal :: HasCallStack => Signal -> IO ()
raiseSignal = Signal -> IO ()
Signals.raiseSignal
  {-# INLINEABLE raiseSignal #-}

  signalProcess :: Signal -> ProcessID -> IO ()
signalProcess = Signal -> ProcessID -> IO ()
Signals.signalProcess
  {-# INLINEABLE signalProcess #-}

  signalProcessGroup :: Signal -> ProcessID -> IO ()
signalProcessGroup = Signal -> ProcessID -> IO ()
Signals.signalProcessGroup
  {-# INLINEABLE signalProcessGroup #-}

  installHandler :: Signal -> Handler IO -> Maybe SignalSet -> IO (Handler IO)
installHandler Signal
s Handler IO
h =
    (Handler -> Handler IO) -> IO Handler -> IO (Handler IO)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Handler -> Handler IO
handlerFromPosix (IO Handler -> IO (Handler IO))
-> (Maybe SignalSet -> IO Handler)
-> Maybe SignalSet
-> IO (Handler IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
s (Handler IO -> Handler
handlerToPosix Handler IO
h)
  {-# INLINEABLE installHandler #-}

  getSignalMask :: IO SignalSet
getSignalMask = IO SignalSet
Signals.getSignalMask
  {-# INLINEABLE getSignalMask #-}

  setSignalMask :: SignalSet -> IO ()
setSignalMask = SignalSet -> IO ()
Signals.setSignalMask
  {-# INLINEABLE setSignalMask #-}

  blockSignals :: SignalSet -> IO ()
blockSignals = SignalSet -> IO ()
Signals.blockSignals
  {-# INLINEABLE blockSignals #-}

  unblockSignals :: SignalSet -> IO ()
unblockSignals = SignalSet -> IO ()
Signals.unblockSignals
  {-# INLINEABLE unblockSignals #-}

  scheduleAlarm :: Int -> IO Int
scheduleAlarm = Int -> IO Int
Signals.scheduleAlarm
  {-# INLINEABLE scheduleAlarm #-}

  getPendingSignals :: IO SignalSet
getPendingSignals = IO SignalSet
Signals.getPendingSignals
  {-# INLINEABLE getPendingSignals #-}

  awaitSignal :: Maybe SignalSet -> IO ()
awaitSignal = Maybe SignalSet -> IO ()
Signals.awaitSignal
  {-# INLINEABLE awaitSignal #-}

  setStoppedChildFlag :: Bool -> IO Bool
setStoppedChildFlag = Bool -> IO Bool
Signals.setStoppedChildFlag
  {-# INLINEABLE setStoppedChildFlag #-}

  queryStoppedChildFlag :: IO Bool
queryStoppedChildFlag = IO Bool
Signals.queryStoppedChildFlag
  {-# INLINEABLE queryStoppedChildFlag #-}

-- | @since 0.1
instance (MonadPosixSignals m) => MonadPosixSignals (ReaderT e m) where
  raiseSignal :: HasCallStack => Signal -> ReaderT e m ()
raiseSignal = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (Signal -> m ()) -> Signal -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> m ()
forall (m :: * -> *).
(MonadPosixSignals m, HasCallStack) =>
Signal -> m ()
raiseSignal
  {-# INLINEABLE raiseSignal #-}

  signalProcess :: Signal -> ProcessID -> ReaderT e m ()
signalProcess Signal
s = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (ProcessID -> m ()) -> ProcessID -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> ProcessID -> m ()
forall (m :: * -> *).
MonadPosixSignals m =>
Signal -> ProcessID -> m ()
signalProcess Signal
s
  {-# INLINEABLE signalProcess #-}

  signalProcessGroup :: Signal -> ProcessID -> ReaderT e m ()
signalProcessGroup Signal
s = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (ProcessID -> m ()) -> ProcessID -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signal -> ProcessID -> m ()
forall (m :: * -> *).
MonadPosixSignals m =>
Signal -> ProcessID -> m ()
signalProcessGroup Signal
s
  {-# INLINEABLE signalProcessGroup #-}

  installHandler :: Signal
-> Handler (ReaderT e m)
-> Maybe SignalSet
-> ReaderT e m (Handler (ReaderT e m))
installHandler Signal
s Handler (ReaderT e m)
h Maybe SignalSet
m =
    ReaderT e m e
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT e m e
-> (e -> ReaderT e m (Handler (ReaderT e m)))
-> ReaderT e m (Handler (ReaderT e m))
forall a b. ReaderT e m a -> (a -> ReaderT e m b) -> ReaderT e m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \e
env ->
      m (Handler (ReaderT e m)) -> ReaderT e m (Handler (ReaderT e m))
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Handler (ReaderT e m)) -> ReaderT e m (Handler (ReaderT e m)))
-> m (Handler (ReaderT e m)) -> ReaderT e m (Handler (ReaderT e m))
forall a b. (a -> b) -> a -> b
$ Handler m -> Handler (ReaderT e m)
hFromM (Handler m -> Handler (ReaderT e m))
-> m (Handler m) -> m (Handler (ReaderT e m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Signal -> Handler m -> Maybe SignalSet -> m (Handler m)
forall (m :: * -> *).
MonadPosixSignals m =>
Signal -> Handler m -> Maybe SignalSet -> m (Handler m)
installHandler Signal
s (e -> Handler (ReaderT e m) -> Handler m
hToM e
env Handler (ReaderT e m)
h) Maybe SignalSet
m)
    where
      hFromM :: Handler m -> Handler (ReaderT e m)
      hFromM :: Handler m -> Handler (ReaderT e m)
hFromM = (forall x. m x -> ReaderT e m x)
-> Handler m -> Handler (ReaderT e m)
forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> Handler m -> Handler n
mapHandler m x -> ReaderT e m x
forall x. m x -> ReaderT e m x
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

      hToM :: e -> Handler (ReaderT e m) -> Handler m
      hToM :: e -> Handler (ReaderT e m) -> Handler m
hToM e
env = (forall x. ReaderT e m x -> m x)
-> Handler (ReaderT e m) -> Handler m
forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> Handler m -> Handler n
mapHandler (ReaderT e m x -> e -> m x
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` e
env)
  {-# INLINEABLE installHandler #-}

  getSignalMask :: ReaderT e m SignalSet
getSignalMask = m SignalSet -> ReaderT e m SignalSet
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m SignalSet
forall (m :: * -> *). MonadPosixSignals m => m SignalSet
getSignalMask
  {-# INLINEABLE getSignalMask #-}

  setSignalMask :: SignalSet -> ReaderT e m ()
setSignalMask = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (SignalSet -> m ()) -> SignalSet -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalSet -> m ()
forall (m :: * -> *). MonadPosixSignals m => SignalSet -> m ()
setSignalMask
  {-# INLINEABLE setSignalMask #-}

  blockSignals :: SignalSet -> ReaderT e m ()
blockSignals = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (SignalSet -> m ()) -> SignalSet -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalSet -> m ()
forall (m :: * -> *). MonadPosixSignals m => SignalSet -> m ()
blockSignals
  {-# INLINEABLE blockSignals #-}

  unblockSignals :: SignalSet -> ReaderT e m ()
unblockSignals = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (SignalSet -> m ()) -> SignalSet -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalSet -> m ()
forall (m :: * -> *). MonadPosixSignals m => SignalSet -> m ()
unblockSignals
  {-# INLINEABLE unblockSignals #-}

  scheduleAlarm :: Int -> ReaderT e m Int
scheduleAlarm = m Int -> ReaderT e m Int
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Int -> ReaderT e m Int)
-> (Int -> m Int) -> Int -> ReaderT e m Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m Int
forall (m :: * -> *). MonadPosixSignals m => Int -> m Int
scheduleAlarm
  {-# INLINEABLE scheduleAlarm #-}

  getPendingSignals :: ReaderT e m SignalSet
getPendingSignals = m SignalSet -> ReaderT e m SignalSet
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m SignalSet
forall (m :: * -> *). MonadPosixSignals m => m SignalSet
getPendingSignals
  {-# INLINEABLE getPendingSignals #-}

  awaitSignal :: Maybe SignalSet -> ReaderT e m ()
awaitSignal = m () -> ReaderT e m ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ReaderT e m ())
-> (Maybe SignalSet -> m ()) -> Maybe SignalSet -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe SignalSet -> m ()
forall (m :: * -> *).
MonadPosixSignals m =>
Maybe SignalSet -> m ()
awaitSignal
  {-# INLINEABLE awaitSignal #-}

  setStoppedChildFlag :: Bool -> ReaderT e m Bool
setStoppedChildFlag = m Bool -> ReaderT e m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ReaderT e m Bool)
-> (Bool -> m Bool) -> Bool -> ReaderT e m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> m Bool
forall (m :: * -> *). MonadPosixSignals m => Bool -> m Bool
setStoppedChildFlag
  {-# INLINEABLE setStoppedChildFlag #-}

  queryStoppedChildFlag :: ReaderT e m Bool
queryStoppedChildFlag = m Bool -> ReaderT e m Bool
forall (m :: * -> *) a. Monad m => m a -> ReaderT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Bool
forall (m :: * -> *). MonadPosixSignals m => m Bool
queryStoppedChildFlag
  {-# INLINEABLE queryStoppedChildFlag #-}

-- | @since 0.1
data Handler m
  = Default
  | Ignore
  | Catch (m ())
  | CatchOnce (m ())
  | CatchInfo (SignalInfo -> m ())
  | CatchInfoOnce (SignalInfo -> m ())

mapHandler :: (forall x. m x -> n x) -> Handler m -> Handler n
mapHandler :: forall (m :: * -> *) (n :: * -> *).
(forall x. m x -> n x) -> Handler m -> Handler n
mapHandler forall x. m x -> n x
f = \case
  Handler m
Default -> Handler n
forall (m :: * -> *). Handler m
Default
  Handler m
Ignore -> Handler n
forall (m :: * -> *). Handler m
Ignore
  Catch m ()
x -> n () -> Handler n
forall (m :: * -> *). m () -> Handler m
Catch (n () -> Handler n) -> n () -> Handler n
forall a b. (a -> b) -> a -> b
$ m () -> n ()
forall x. m x -> n x
f m ()
x
  CatchOnce m ()
x -> n () -> Handler n
forall (m :: * -> *). m () -> Handler m
CatchOnce (n () -> Handler n) -> n () -> Handler n
forall a b. (a -> b) -> a -> b
$ m () -> n ()
forall x. m x -> n x
f m ()
x
  CatchInfo SignalInfo -> m ()
x -> (SignalInfo -> n ()) -> Handler n
forall (m :: * -> *). (SignalInfo -> m ()) -> Handler m
CatchInfo ((SignalInfo -> n ()) -> Handler n)
-> (SignalInfo -> n ()) -> Handler n
forall a b. (a -> b) -> a -> b
$ m () -> n ()
forall x. m x -> n x
f (m () -> n ()) -> (SignalInfo -> m ()) -> SignalInfo -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalInfo -> m ()
x
  CatchInfoOnce SignalInfo -> m ()
x -> (SignalInfo -> n ()) -> Handler n
forall (m :: * -> *). (SignalInfo -> m ()) -> Handler m
CatchInfoOnce ((SignalInfo -> n ()) -> Handler n)
-> (SignalInfo -> n ()) -> Handler n
forall a b. (a -> b) -> a -> b
$ m () -> n ()
forall x. m x -> n x
f (m () -> n ()) -> (SignalInfo -> m ()) -> SignalInfo -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignalInfo -> m ()
x

handlerToPosix :: Handler IO -> Signals.Handler
handlerToPosix :: Handler IO -> Handler
handlerToPosix = \case
  Handler IO
Default -> Handler
Signals.Default
  Handler IO
Ignore -> Handler
Signals.Ignore
  Catch IO ()
x -> IO () -> Handler
Signals.Catch IO ()
x
  CatchOnce IO ()
x -> IO () -> Handler
Signals.CatchOnce IO ()
x
  CatchInfo SignalInfo -> IO ()
x -> (SignalInfo -> IO ()) -> Handler
Signals.CatchInfo SignalInfo -> IO ()
x
  CatchInfoOnce SignalInfo -> IO ()
x -> (SignalInfo -> IO ()) -> Handler
Signals.CatchInfoOnce SignalInfo -> IO ()
x

handlerFromPosix :: Signals.Handler -> Handler IO
handlerFromPosix :: Handler -> Handler IO
handlerFromPosix = \case
  Handler
Signals.Default -> Handler IO
forall (m :: * -> *). Handler m
Default
  Handler
Signals.Ignore -> Handler IO
forall (m :: * -> *). Handler m
Ignore
  Signals.Catch IO ()
x -> IO () -> Handler IO
forall (m :: * -> *). m () -> Handler m
Catch IO ()
x
  Signals.CatchOnce IO ()
x -> IO () -> Handler IO
forall (m :: * -> *). m () -> Handler m
CatchOnce IO ()
x
  Signals.CatchInfo SignalInfo -> IO ()
x -> (SignalInfo -> IO ()) -> Handler IO
forall (m :: * -> *). (SignalInfo -> m ()) -> Handler m
CatchInfo SignalInfo -> IO ()
x
  Signals.CatchInfoOnce SignalInfo -> IO ()
x -> (SignalInfo -> IO ()) -> Handler IO
forall (m :: * -> *). (SignalInfo -> m ()) -> Handler m
CatchInfoOnce SignalInfo -> IO ()
x