Object oriented haskell (in the message-passing sense). Each objects lives in a separate thread.

Objects.File.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
module Objects.File where

import Control.Monad
import System.IO

import Objects

data File a where
  IsEOF :: File Bool
  SetBuffering :: BufferMode -> File ()
  GetBuffering :: File BufferMode
  Flush :: File ()
  GetChar :: File Char
  GetString :: Int -> File String
  PutChar :: Char -> File ()
  PutString :: String -> File ()

clsFile :: Class (FilePath, IOMode) Handle File
clsFile = Class
  { classInit = \(path, mode) -> openFile path mode
  , classDestroy = hClose
  , classRespond = selfless \case
      IsEOF -> hIsEOF
      SetBuffering buf -> flip hSetBuffering buf
      GetBuffering -> hGetBuffering
      Flush -> hFlush
      GetChar -> hGetChar
      GetString n -> replicateM n . hGetChar
      PutChar c -> flip hPutChar c
      PutString s -> flip hPutStr s
  }

Objects.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Objects where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Fix
import Data.Function

import Control.Concurrent.STM

data Object k = Object
  { objThread :: ThreadId
  , objChan :: TBQueue (Request k)
  }

data Request k where
  Request :: k x -> MVar (Either SomeException x) -> Request k
  Delete :: Request k

data Class i e k = Class
  { classRespond :: forall x. k x -> e -> Object k -> IO x
  , classInit :: i -> IO e
  , classDestroy :: e -> IO ()
  }

statelessCls :: (forall x. k x -> IO x) -> Class () () k
statelessCls resp = Class
  { classInit = const (pure ())
  , classDestroy = const (pure ())
  , classRespond = const . const . resp
  }

selfless :: (forall x. k x -> e -> IO x) -> (forall x. k x -> e -> Object k -> IO x)
selfless f = \req env _self -> f req env

maxQueueSize = 16

new :: Class i e k -> i -> IO (Object k)
new = newWith forkIO

newWith :: (IO () -> IO ThreadId) -> Class i e k -> i -> IO (Object k)
newWith fork Class{classInit, classDestroy, classRespond} i = do
  env <- classInit i
  queue <- newTBQueueIO maxQueueSize
  mfix \self -> do
    tid <- fork $ fix
      \loop -> atomically (readTBQueue queue)
      >>= \case
        Delete -> do
          classDestroy env
          killThread =<< myThreadId
        Request req mvar -> do
          result <- try (classRespond req env self)
          case result of
            Left err -> do
              putMVar mvar (Left err)
            Right x -> do
              putMVar mvar (Right x)
              loop
    pure (Object tid queue)

delete :: Object k -> IO ()
delete obj = atomically $ writeTBQueue (objChan obj) Delete

(#) :: Object k -> k x -> IO x
obj # req = do
  mvar <- newEmptyMVar
  atomically $ writeTBQueue (objChan obj) (Request req mvar)
  either throwIO pure =<< takeMVar mvar