{-# LANGUAGE CPP #-}

-- | Provides the 'MonadThread' typeclass.
--
-- @since 0.1
module Effects.Concurrent.Thread
  ( -- * Thread Effect
    MonadThread (..),
    microsleep,
    sleep,

    -- * Reexports
    Natural,
    ThreadId,

    -- * QSem Effect
    MonadQSem (..),
    MonadQSemN (..),

    -- * Reexports
    QSem,
    QSemN,
  )
where

import Control.Concurrent (ThreadId)
import Control.Concurrent qualified as CC
import Control.Concurrent.QSem (QSem)
import Control.Concurrent.QSem qualified as QSem
import Control.Concurrent.QSemN (QSemN)
import Control.Concurrent.QSemN qualified as QSemN
import Control.Exception (Exception)
import Control.Monad.Trans.Class (MonadTrans (lift))
import Control.Monad.Trans.Reader (ReaderT)
import Data.Foldable (for_)
import GHC.Conc.Sync qualified as Sync
import GHC.Natural (Natural)
import GHC.Stack (HasCallStack)

{- ORMOLU_DISABLE -}

-- | Represents thread effects.
--
-- @since 0.1
class (Monad m) => MonadThread m where
  -- | Lifted 'CC.threadDelay'.
  --
  -- @since 0.1
  threadDelay :: (HasCallStack) => Int -> m ()

  -- | Lifted 'CC.throwTo'.
  --
  -- @since 0.1
  throwTo :: (Exception e, HasCallStack) => ThreadId -> e -> m ()

  -- | Lifted 'CC.getNumCapabilities'.
  --
  -- @since 0.1
  getNumCapabilities :: (HasCallStack) => m Int

  -- | Lifted 'CC.setNumCapabilities'.
  --
  -- @since 0.1
  setNumCapabilities :: (HasCallStack) => Int -> m ()

  -- | Lifted 'CC.threadCapability'.
  --
  -- @since 0.1
  threadCapability :: (HasCallStack) => ThreadId -> m (Int, Bool)

  -- | Lifted 'CC.myThreadId'.
  --
  -- @since 0.1
  myThreadId :: (HasCallStack) => m ThreadId

  -- | Lifted 'Sync.labelThread'.
  --
  -- @since 0.1
  labelThread :: (HasCallStack) => ThreadId -> String -> m ()

#if MIN_VERSION_base(4, 18, 0)

  -- | Lifted 'Sync.threadLabel'.
  --
  -- @since 0.1
  threadLabel :: (HasCallStack) => ThreadId -> m (Maybe String)

#endif

-- | @since 0.1
instance MonadThread IO where
  threadDelay :: HasCallStack => Int -> IO ()
threadDelay = Int -> IO ()
CC.threadDelay
  {-# INLINEABLE threadDelay #-}
  throwTo :: forall e. (Exception e, HasCallStack) => ThreadId -> e -> IO ()
throwTo = ThreadId -> e -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
CC.throwTo
  {-# INLINEABLE throwTo #-}
  getNumCapabilities :: HasCallStack => IO Int
getNumCapabilities = IO Int
CC.getNumCapabilities
  {-# INLINEABLE getNumCapabilities #-}
  setNumCapabilities :: HasCallStack => Int -> IO ()
setNumCapabilities = Int -> IO ()
CC.setNumCapabilities
  {-# INLINEABLE setNumCapabilities #-}
  threadCapability :: HasCallStack => ThreadId -> IO (Int, Bool)
threadCapability = ThreadId -> IO (Int, Bool)
CC.threadCapability
  {-# INLINEABLE threadCapability #-}
  myThreadId :: HasCallStack => IO ThreadId
myThreadId = IO ThreadId
CC.myThreadId
  {-# INLINEABLE myThreadId #-}
  labelThread :: HasCallStack => ThreadId -> String -> IO ()
labelThread = ThreadId -> String -> IO ()
Sync.labelThread
  {-# INLINEABLE labelThread #-}
#if MIN_VERSION_base(4, 18, 0)
  threadLabel :: HasCallStack => ThreadId -> IO (Maybe String)
threadLabel = ThreadId -> IO (Maybe String)
Sync.threadLabel
  {-# INLINEABLE threadLabel #-}
#endif

-- | @since 0.1
instance (MonadThread m) => MonadThread (ReaderT e m) where
  threadDelay :: HasCallStack => Int -> ReaderT e m ()
threadDelay = 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 ()) -> (Int -> m ()) -> Int -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m ()
forall (m :: * -> *). (MonadThread m, HasCallStack) => Int -> m ()
threadDelay
  {-# INLINEABLE threadDelay #-}
  throwTo :: forall e.
(Exception e, HasCallStack) =>
ThreadId -> e -> ReaderT e m ()
throwTo ThreadId
tid = 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 ()) -> (e -> m ()) -> e -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> e -> m ()
forall e. (Exception e, HasCallStack) => ThreadId -> e -> m ()
forall (m :: * -> *) e.
(MonadThread m, Exception e, HasCallStack) =>
ThreadId -> e -> m ()
throwTo ThreadId
tid
  {-# INLINEABLE throwTo #-}
  getNumCapabilities :: HasCallStack => ReaderT e m Int
getNumCapabilities = 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
forall (m :: * -> *). (MonadThread m, HasCallStack) => m Int
getNumCapabilities
  {-# INLINEABLE getNumCapabilities #-}
  setNumCapabilities :: HasCallStack => Int -> ReaderT e m ()
setNumCapabilities = 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 ()) -> (Int -> m ()) -> Int -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m ()
forall (m :: * -> *). (MonadThread m, HasCallStack) => Int -> m ()
setNumCapabilities
  {-# INLINEABLE setNumCapabilities #-}
  threadCapability :: HasCallStack => ThreadId -> ReaderT e m (Int, Bool)
threadCapability = m (Int, Bool) -> ReaderT e m (Int, 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 (Int, Bool) -> ReaderT e m (Int, Bool))
-> (ThreadId -> m (Int, Bool))
-> ThreadId
-> ReaderT e m (Int, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> m (Int, Bool)
forall (m :: * -> *).
(MonadThread m, HasCallStack) =>
ThreadId -> m (Int, Bool)
threadCapability
  {-# INLINEABLE threadCapability #-}
  myThreadId :: HasCallStack => ReaderT e m ThreadId
myThreadId = m ThreadId -> ReaderT e m ThreadId
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 ThreadId
forall (m :: * -> *). (MonadThread m, HasCallStack) => m ThreadId
myThreadId
  {-# INLINEABLE myThreadId #-}
  labelThread :: HasCallStack => ThreadId -> String -> ReaderT e m ()
labelThread ThreadId
tid = 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 ())
-> (String -> m ()) -> String -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> String -> m ()
forall (m :: * -> *).
(MonadThread m, HasCallStack) =>
ThreadId -> String -> m ()
labelThread ThreadId
tid
  {-# INLINEABLE labelThread #-}
#if MIN_VERSION_base(4, 18, 0)
  threadLabel :: HasCallStack => ThreadId -> ReaderT e m (Maybe String)
threadLabel = m (Maybe String) -> ReaderT e m (Maybe String)
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 (Maybe String) -> ReaderT e m (Maybe String))
-> (ThreadId -> m (Maybe String))
-> ThreadId
-> ReaderT e m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> m (Maybe String)
forall (m :: * -> *).
(MonadThread m, HasCallStack) =>
ThreadId -> m (Maybe String)
threadLabel
  {-# INLINEABLE threadLabel #-}
#endif

{- ORMOLU_ENABLE -}

-- | 'threadDelay' in terms of unbounded 'Natural' rather than 'Int' i.e.
-- runs sleep in the current thread for the specified number of microseconds.
--
-- @since 0.1
microsleep :: (HasCallStack, MonadThread m) => Natural -> m ()
microsleep :: forall (m :: * -> *).
(HasCallStack, MonadThread m) =>
Natural -> m ()
microsleep Natural
n = [Int] -> (Int -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Natural -> [Int]
natToInts Natural
n) Int -> m ()
forall (m :: * -> *). (MonadThread m, HasCallStack) => Int -> m ()
threadDelay
{-# INLINEABLE microsleep #-}

-- | Runs sleep in the current thread for the specified number of
-- seconds.
--
-- @since 0.1
sleep :: (HasCallStack, MonadThread m) => Natural -> m ()
sleep :: forall (m :: * -> *).
(HasCallStack, MonadThread m) =>
Natural -> m ()
sleep = Natural -> m ()
forall (m :: * -> *).
(HasCallStack, MonadThread m) =>
Natural -> m ()
microsleep (Natural -> m ()) -> (Natural -> Natural) -> Natural -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
* Natural
1_000_000)
{-# INLINEABLE sleep #-}

natToInts :: Natural -> [Int]
natToInts :: Natural -> [Int]
natToInts Natural
n
  | Natural
n Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
maxIntAsNat = Int
maxInt Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: Natural -> [Int]
natToInts (Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- Natural
maxIntAsNat)
  | Bool
otherwise = [Natural -> Int
n2i Natural
n]
  where
    maxInt :: Int
    maxInt :: Int
maxInt = Int
forall a. Bounded a => a
maxBound
    maxIntAsNat :: Natural
    maxIntAsNat :: Natural
maxIntAsNat = Int -> Natural
i2n Int
maxInt

n2i :: Natural -> Int
n2i :: Natural -> Int
n2i = Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

i2n :: Int -> Natural
i2n :: Int -> Natural
i2n = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | Effect for 'QSem' semaphore.
--
-- @since 0.1
class (Monad m) => MonadQSem m where
  -- | Lifted 'QSem.newQSem'.
  --
  -- @since 0.1
  newQSem :: Int -> m QSem

  -- | Lifted 'QSem.waitQSem'.
  --
  -- @since 0.1
  waitQSem :: QSem -> m ()

  -- | Lifted 'QSem.signalQSem'.
  --
  -- @since 0.1
  signalQSem :: QSem -> m ()

-- | @since 0.1
instance MonadQSem IO where
  newQSem :: Int -> IO QSem
newQSem = Int -> IO QSem
QSem.newQSem
  {-# INLINEABLE newQSem #-}
  waitQSem :: QSem -> IO ()
waitQSem = QSem -> IO ()
QSem.waitQSem
  {-# INLINEABLE waitQSem #-}
  signalQSem :: QSem -> IO ()
signalQSem = QSem -> IO ()
QSem.signalQSem
  {-# INLINEABLE signalQSem #-}

-- | @since 0.1
instance (MonadQSem m) => MonadQSem (ReaderT e m) where
  newQSem :: Int -> ReaderT e m QSem
newQSem = m QSem -> ReaderT e m QSem
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 QSem -> ReaderT e m QSem)
-> (Int -> m QSem) -> Int -> ReaderT e m QSem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m QSem
forall (m :: * -> *). MonadQSem m => Int -> m QSem
newQSem
  {-# INLINEABLE newQSem #-}
  waitQSem :: QSem -> ReaderT e m ()
waitQSem = 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 ())
-> (QSem -> m ()) -> QSem -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QSem -> m ()
forall (m :: * -> *). MonadQSem m => QSem -> m ()
waitQSem
  {-# INLINEABLE waitQSem #-}
  signalQSem :: QSem -> ReaderT e m ()
signalQSem = 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 ())
-> (QSem -> m ()) -> QSem -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QSem -> m ()
forall (m :: * -> *). MonadQSem m => QSem -> m ()
signalQSem
  {-# INLINEABLE signalQSem #-}

-- | Effect for 'QSemN' semaphore.
--
-- @since 0.1
class (Monad m) => MonadQSemN m where
  -- | Lifted 'QSemN.newQSemN'.
  --
  -- @since 0.1
  newQSemN :: Int -> m QSemN

  -- | Lifted 'QSemN.waitQSemN'.
  --
  -- @since 0.1
  waitQSemN :: QSemN -> Int -> m ()

  -- | Lifted 'QSemN.signalQSemN'.
  --
  -- @since 0.1
  signalQSemN :: QSemN -> Int -> m ()

-- | @since 0.1
instance MonadQSemN IO where
  newQSemN :: Int -> IO QSemN
newQSemN = Int -> IO QSemN
QSemN.newQSemN
  {-# INLINEABLE newQSemN #-}
  waitQSemN :: QSemN -> Int -> IO ()
waitQSemN = QSemN -> Int -> IO ()
QSemN.waitQSemN
  {-# INLINEABLE waitQSemN #-}
  signalQSemN :: QSemN -> Int -> IO ()
signalQSemN = QSemN -> Int -> IO ()
QSemN.signalQSemN
  {-# INLINEABLE signalQSemN #-}

-- | @since 0.1
instance (MonadQSemN m) => MonadQSemN (ReaderT e m) where
  newQSemN :: Int -> ReaderT e m QSemN
newQSemN = m QSemN -> ReaderT e m QSemN
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 QSemN -> ReaderT e m QSemN)
-> (Int -> m QSemN) -> Int -> ReaderT e m QSemN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> m QSemN
forall (m :: * -> *). MonadQSemN m => Int -> m QSemN
newQSemN
  {-# INLINEABLE newQSemN #-}
  waitQSemN :: QSemN -> Int -> ReaderT e m ()
waitQSemN QSemN
q = 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 ()) -> (Int -> m ()) -> Int -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QSemN -> Int -> m ()
forall (m :: * -> *). MonadQSemN m => QSemN -> Int -> m ()
waitQSemN QSemN
q
  {-# INLINEABLE waitQSemN #-}
  signalQSemN :: QSemN -> Int -> ReaderT e m ()
signalQSemN QSemN
q = 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 ()) -> (Int -> m ()) -> Int -> ReaderT e m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QSemN -> Int -> m ()
forall (m :: * -> *). MonadQSemN m => QSemN -> Int -> m ()
signalQSemN QSemN
q
  {-# INLINEABLE signalQSemN #-}