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
  )
where

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

import           Control.Concurrent      ( ThreadId, forkFinally )
import           Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , putMVar
  , readMVar
  )
import           GHC.Exception           ( SomeException, throw )

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

data Task a = Task !ThreadId (IO (Either SomeException a))

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

-- |
-- 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 $ get var
    where
      finally v r = put v r
  wait (Task _ mvar) =
    ( \case
        Right v ->       v
        Left  e -> throw e
    )
    <$> mvar
  join =
    mapM_ wait