Last active
June 29, 2019 16:52
-
-
Save Solonarv/a895a3e2713f192734c51b39155423f7 to your computer and use it in GitHub Desktop.
Object oriented haskell (in the message-passing sense). Each objects lives in a separate thread.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 | |
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment