Concurrent.hs

{-# OPTIONS_GHC -Wall -Werror #-}

{-# LANGUAGE NoGeneralizedNewtypeDeriving #-}
{-# LANGUAGE Safe                         #-}

{-# LANGUAGE LambdaCase                   #-}

--------------------------------------------------------------------------------

-- |
-- Copyright  : (c) 2026 SPISE MISU ApS
-- License    : SSPL-1.0 OR AGPL-3.0-only
-- Maintainer : SPISE MISU <mail+hackage@spisemisu.com>
-- Stability  : experimental

--------------------------------------------------------------------------------

module Agent.Control.Concurrent
  ( Async
  , Task
  , fork
  , wait
  , join
  , tmax
  , ttid
  , tkil
  , tnum
  , tvar
  , tval
  , terr
  )
where

--------------------------------------------------------------------------------

{- DEBUG

import           Control.Concurrent
  ( ThreadId
  , forkFinally
  , getNumCapabilities
  , killThread
  , threadDelay
  )

import           Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , putMVar
  , readMVar
  , tryReadMVar
  )

import           GHC.Exception
  ( SomeException
  , errorCallException
  , throw
  )

-}

{-

-}

import           Control.Concurrent
  ( ThreadId
  , forkFinally
  , getNumCapabilities
  , killThread
  )

import           Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , putMVar
  , readMVar
  , tryReadMVar
  )

import           GHC.Exception           ( SomeException, throw )

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

type Wrap a = Either SomeException a
data Task a = Task !ThreadId !(MVar (Wrap a)) !(IO (Wrap a))

--------------------------------------------------------------------------------

tmax :: IO Int
tmax =
  getNumCapabilities

ttid
  :: Task a
  -> ThreadId
ttid (Task uid _ _) =
  uid

tkil
  :: Task a
  -> IO String
tkil t@(Task uid _ _) =
  killThread uid >>
  pure n
  where
    n = tnum t

tnum
  :: Task a
  -> String
tnum (Task uid _ _) =
  -- NOTE: Sample of `show uid` is `ThreadId 42` and
  -- > cat /proc/sys/kernel/threads-max
  -- > 509_390
  (lpad 6 '0' . drop 1 . dropWhile (/= ' ') . show) uid
  where
    lpad n c x =
      replicate (n - l) c ++ x
      where
        l = length x

tvar
  :: Task a
  -> IO Bool
tvar (Task _ mvar _) =
    ( \case
        Nothing -> False
        Just __ -> True
    )
    <$> tryReadMVar mvar

tval
  :: Task a
  -> IO (Maybe a)
tval (Task _ _ mval) =
    ( \case
        Right a -> Just a
        Left  _ -> Nothing
    )
    <$> mval

terr
  :: Task a
  -> IO (Maybe String)
terr (Task _ _ mval) =
    ( \case
        Right _ -> Nothing
        Left  e -> Just $ show e
    )
    <$> mval

--------------------------------------------------------------------------------
--------------------------------------------------------------------------------

-- |
-- To prevent the users from adding instances of `Async`, we
-- provide a middle-layer (`Proxy`) between the `Monad` instance and the `Proxy`
-- (`Async`) instance.

class Monad m => Proxy m where
  new :: m (MVar a)
  put ::    MVar a -> a -> m ( )
  get ::    MVar a ->      m  a
class Proxy m => Async m where
  fork ::   m    a   -> m (Task a)
  wait ::   Task a   -> m       a
  join :: [ Task a ] -> m      ( )

--------------------------------------------------------------------------------

instance Proxy IO where
  -- | newEmptyMVar: Create an MVar which is initially empty.
  new = newEmptyMVar
  -- | putMVar: Put a value into an MVar.
  put = putMVar
  -- |
  -- readMVar: Atomically read the contents of an MVar. If the MVar is currently
  -- empty, readMVar will wait until it is full. readMVar is guaranteed to
  -- receive the next putMVar.
  get = readMVar

instance Async IO where
  fork compute =
    new                               >>= \ var ->
    forkFinally compute (finally var) >>= \ tid ->
    pure $ Task tid var $ get var
    where
      finally v r =
        -- DEBUG: sleep for 9 million microseconds, or 9 seconds
        --threadDelay 9000000 >>
        -- DEBUG: Force an exception
        --put v (Left $ errorCallException "DEBUG")
        put v r
  wait (Task _ _ mval) =
    ( \case
        Right v ->       v
        Left  e -> throw e
    )
    <$> mval
  join =
    mapM_ wait