F-coalgebra based version.

Free.hs

{-# LANGUAGE RankNTypes, KindSignatures, MultiParamTypeClasses, FlexibleContexts #-}

newtype Free f a = Free (forall m. (Monad m) => f m -> m a)

runFree :: (Monad m) => forall f a. Free f a -> f m -> m a
runFree (Free k) = k

instance Functor (Free f) where
  fmap f (Free k) = Free (\impl -> fmap f (k impl))

instance Applicative (Free f) where
  pure a = Free (\_ -> pure a)
  (Free kf) <*> (Free ka) = Free (\impl -> (kf impl) <*> (ka impl))

instance Monad (Free f) where
  (Free k) >>= f = Free (\impl -> k impl >>= (\x -> runFree (f x) impl))

data ConsoleFCo m =
  ConsoleFCo
    (m String)       -- ^ readLine
    (String -> m ()) -- ^ writeLine

data NetworkFCo m =
  NetworkFCo
    (String -> m ()) -- ^ sendToServer

class FCoProject (f :: (* -> *) -> *) (g :: (* -> *) -> *) where
  projectFCo :: forall m. f m -> g m

newtype MyFCo m = MyFCo (ConsoleFCo m, NetworkFCo m)

instance FCoProject ConsoleFCo ConsoleFCo where
  projectFCo = id

instance FCoProject NetworkFCo NetworkFCo where
  projectFCo = id

instance FCoProject MyFCo ConsoleFCo where
  projectFCo (MyFCo (x,_)) = x

instance FCoProject MyFCo NetworkFCo where
  projectFCo (MyFCo (_,x)) = x

readLine :: forall f. (FCoProject f ConsoleFCo) => Free f String
readLine = Free (\impl -> case projectFCo impl of ConsoleFCo x _ -> x)

writeLine :: forall f. (FCoProject f ConsoleFCo) => String -> Free f ()
writeLine msg = Free (\impl -> case projectFCo impl of ConsoleFCo _ x -> x msg)

sendToServer :: forall f. (FCoProject f NetworkFCo) => String -> Free f ()
sendToServer msg = Free (\impl -> case projectFCo impl of NetworkFCo x -> x msg)

myApp :: forall f. (FCoProject f ConsoleFCo, FCoProject f NetworkFCo) => Free f ()
myApp = readLine >>= sendToServer

main = return ()