Моя реализация акторной модели

{-# Language
    GADTs,
    LambdaCase,
    FlexibleInstances,
    MultiParamTypeClasses#-}
 
module Actor where
 
import Control.Monad
import Control.Monad.Fix
import Control.Monad.Free
import Control.Concurrent
import Control.Concurrent.Chan
import qualified System.Random as R
 
type Process = Free Interaction
 
data Interaction next where
    ReadMsg     ::               Chan a -> (a -> next) -> Interaction next
    WriteMsg    ::               Chan a ->  a -> next  -> Interaction next
    MakeChan    ::                    (Chan a -> next) -> Interaction next
    Random      :: R.Random a => a -> a -> (a -> next) -> Interaction next
    ForkProcess ::               Process ()   -> next  -> Interaction next
 
instance Functor Interaction where
    fmap f = \case 
        ReadMsg  chan   g -> ReadMsg  chan   $ f.g
        WriteMsg chan a g -> WriteMsg chan a $ f g
        MakeChan        g -> MakeChan        $ f.g
        Random    a b   g -> Random    a b   $ f.g 
        ForkProcess p   g -> ForkProcess p   $ f g
 
class Monad m => Eval m where
    eval     :: Process ()  -> m()
    forkEval :: Process ()  -> m()
    writeMsg :: Chan a -> a -> m()
    readMsg  :: Chan a      -> m a
    makeChan :: m (Chan a)
 
instance Eval IO where
    eval = \case
        Free r                -> case r of
            ReadMsg  chan   f -> eval =<< f <$> readChan chan
            MakeChan        f -> eval =<< f <$> newChan
            WriteMsg chan a f -> writeChan chan a *> eval f
            Random      a b f -> eval =<< f <$> R.randomRIO (a, b)
            ForkProcess   p f -> forkIO (eval p)  *> eval f 
        Pure r                -> return r
 
    forkEval = void.forkIO.eval
    writeMsg = writeChan
    readMsg  = readChan
    makeChan = newChan
 
instance Eval Process where
    eval f          = lift $ ForkProcess f ()
    writeMsg chan a = lift $ WriteMsg chan a ()
    readMsg  chan   = lift $ ReadMsg  chan id
    makeChan        = lift $ MakeChan      id
    forkEval        = eval
 
random a b = lift $ Random a b id
 
lift x = Free (fmap Pure x)
 
class Actor a b where
    aktor  :: a -> b
 
type Handler msg b = Chan msg -> Free Interaction b
type Result m1 m2 msg  = m1 (msg -> m2 ())
 
instance (Eval m1, Eval m2) => Actor (Handler msg b) (Result m1 m2 msg) where
    aktor f = do
        ch <- makeChan
        forkEval.void   $ f ch
        return.writeMsg $   ch
 
instance (Eval m1, Eval m2) =>
    Actor (Handler msg b -> Handler msg b) (Result m1 m2 msg) where
    aktor f = aktor.fix $ f
 
aktorST s f = aktor  $ fix f s
forkST  s f = forkIO $ fix f s

{-# Language MultiWayIf, LambdaCase#-}
-- ghc Main.hs -O2 -threaded
module Main where
 
import Control.Monad
import Control.Concurrent
import Control.Concurrent.Thread.Delay
import System.IO
import System.Console.ANSI
import Actor
 
widths = 22
height = 78
 
metronome t f = forkIO.forever $ delay t >> f
 
data Point = Point Int Int deriving Eq
 
data PointRequest = Up | Down | Forward | Backward | Jamp | Draw
 
point :: Point -> Chan Point -> Chan PointRequest -> Process ()
point p@(Point x y) out ch = readMsg ch >>= \case
    Up       | y > 1      -> point' $ Point x    (y-1)
    Down     | y < widths -> point' $ Point x    (y+1)
    Forward  | x < height -> point' $ Point (x+1) y
    Backward | x > 1      -> point' $ Point (x-1) y
    Draw                  -> writeMsg out p >> point' p
    Jamp                  -> do
        y <- random 1 widths
        x <- random 1 height
        point' $ Point x y
    _                     -> point' p
  where point' p = point p out ch
 
background = concat $ do
    n <- [0..widths + 1]
    return $ if
        | n == 0          -> '+':replicate height '-' ++ "+\n"
        | n == widths + 1 -> '+':replicate height '-' ++ "+"
        | otherwise       -> '|':replicate height ' ' ++ "|\n"
 
getKey :: (PointRequest -> IO ()) -> IO ()
getKey command = getChar >>= \case
    'w' -> command Up       *> next
    's' -> command Down     *> next
    'd' -> command Forward  *> next
    'a' -> command Backward *> next
    'j' -> command Jamp     *> next
    '!' ->                     exit
    _   ->                     next
  where next = getKey command
 
exit = do
    clearScreen
    setCursorPosition 0 0
    showCursor
 
printer p@(Point x y) chan = do
    p'@(Point x' y') <- readChan chan
    when (p /= p') $ do
        setCursorPosition y  x  *> putStr " "
        setCursorPosition y' x' *> putStr "X" 
    printer p' chan
 
main = do
    hSetBuffering stdin  NoBuffering
    hSetBuffering stdout NoBuffering
    hSetEcho stdin False
    hideCursor
 
    chan  <- makeChan
    forkIO $ do
        putStr background 
        printer (Point 3 4) chan
    point <- aktor $ point (Point 3 5) chan
    metronome 10000 $ point Draw
    getKey point