Fork.hs

{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE UndecidableInstances      #-}
module Fork where

import           Control.Applicative (Applicative, pure, (<$>), (<*>))

data Fork f a = Halt a
              | Atomic (f (Fork f a))
              | forall b. Fork (Fork f b) (Fork f a)

instance (Functor f) => Functor (Fork f) where
  fmap f (Halt a) = Halt $ f a
  fmap f (Atomic a) = Atomic $ fmap (fmap f) a
  fmap f (Fork a1 a2) = Fork a1 $ (fmap f) a2

instance Functor f => Applicative (Fork f) where
  pure = Halt
  (Halt a) <*> b = a <$> b
  (Atomic a) <*> g = Atomic $ (<*> g) <$> a
  (Fork b a) <*> g = Fork b (a <*> g)


instance Functor f => Monad (Fork f) where
  return = Halt
  (Halt a) >>= b = b a
  (Atomic a) >>= b = Atomic $ (>>= b) <$> a
  (Fork a1 a) >>= b = Fork a1 (a >>= b)

liftF :: Functor f => f a -> Fork f a
liftF = Atomic . fmap Halt

fork :: Functor f => Fork f a -> Fork f ()
fork f = Fork f (return ())

Teletype.hs

{-# LANGUAGE DeriveFunctor #-}
module Teletype where

import           Fork

data Toy next =
    Output String next
  | Bell next deriving (Functor, Show)

type ToyM = Fork Toy

output :: String -> Fork Toy ()
output s = liftF $ Output s ()

bell :: Fork Toy ()
bell = liftF $ Bell ()

test :: Fork Toy ()
test = do
  output "test"
  fork $ do
    bell
    output "what"
  output "hello"