objectiveを用いた継承

gistfile1.hs

{-# LANGUAGE GADTs #-}
module Main where
import Control.Object
import Control.Monad.Operational
import Control.Monad.Trans.State.Strict
import Control.Monad.IO.Class
import Control.Monad

main :: IO ()
main = do
  a <- new objA
  a.-SetA "Hoge"
  a.-PrintA 
  
  putStrLn "----"
  b <- new objB
  b.-InL (SetA "Piyo")
  b.-InL PrintA 
  b.-InR PrintB
  b.-InL (SetA "Fuga")
  b.-InR PrintA2

--------

data A a where
  SetA :: String -> A ()
  GetA :: A String
  PrintA :: A ()

objA :: Object A IO
objA = stateful handle ""
  where
    handle :: A a -> StateT String IO a
    handle (SetA s) = put s
    handle GetA = get
    handle PrintA = get >>= liftIO . putStrLn . ("PrintA : "++)

--------

data B a where
  PrintB :: B ()
  PrintA2 :: B ()

mf :: Object A (Program (Sum A IO))
mf = liftO handle
  where
    handle :: A a -> Program (Sum A IO) a
    handle x = singleton $ InL x

mg :: Object B (Program (Sum A IO))
mg = liftO handle
  where
    handle :: B a -> Program (Sum A IO) a
    handle PrintB = do
      x <- singleton $ InL GetA
      singleton . InR . putStrLn $ "PrintB : " ++ x
    handle PrintA2 = do
     singleton $ InL PrintA
     singleton $ InL PrintA

objB :: Object (Sum A B) IO
objB = (mf @||@ mg) @>>@ sequential (objA @||@ echo)

--------

data Sum f g a = InL (f a) | InR (g a)

(@||@) :: Functor m => Object f m -> Object g m -> Object (Sum f g) m
a @||@ b = Object $ \r -> case r of
  InL f -> fmap (fmap (@||@b)) $ runObject a f
  InR g -> fmap (fmap (a@||@)) $ runObject b g

sequential :: Monad m => Object t m -> Object (Program t) m
sequential r = Object $ liftM (fmap sequential) . inv r
  where
    inv :: Monad m => Object t m -> Program t t1 -> m (t1, Object t m)
    inv obj (Program (Pure x)) = return (x, obj)
    inv obj (Program (Free (CoYoneda f x))) 
      = runObject obj x >>= \(a, obj') -> inv obj' (Program . f $ a)