Control.Comonad.Env

progLA.hs

{-# LANGUAGE GADTs, FlexibleContexts, TemplateHaskell #-}
import Control.Comonad.Env
import Control.Comonad
import Control.Monad.Operational.Mini
import qualified Data.IntMap as M

data Field = Field String (M.IntMap Chara) deriving (Show)
data Chara = Chara String deriving (Show)
updateField f (Field s m) = Field (f s) m
updateChara f (Chara s) = Chara (f s)

sync :: (Env Field Chara -> Env Field Chara) -> Field -> Field
sync f e@(Field _ c) = let (Field s k,c') = runEnv $ f $ env e (c M.! 0) in Field s $ M.insert 0 c' $ k

data Pattern p q x where
  Hook :: Either (p -> p) (q -> q) -> Pattern p q ()
  Parent :: Pattern p q p
  Self :: Pattern p q q
makeSingletons ''Pattern

type LA p q = ReifiedProgram (Pattern p q)

runLA :: LA p q () -> Env p q -> Env p q
runLA (Hook (Left f) :>>= next) env = runLA (next ()) $ local f env
runLA (Hook (Right f) :>>= next) env = runLA (next ()) $ fmap f env
runLA (Parent :>>= next) env = runLA (next $ ask env) env
runLA (Self :>>= next) env = runLA (next $ extract env) env
runLA (Return ()) env = env

prog :: LA Field Chara ()
prog = do
  hook $ Right $ updateChara ("1/"++)
  c <- self
  hook $ Left $ (\(Field s m) -> Field s (M.insert 1 c m))
  hook $ Right $ updateChara ("2/"++)
  Chara s <- self
  hook $ Left $ updateField (take 2 s++)
  Field s _ <- parent
  c <- self
  hook $ Left $ (\(Field s m) -> Field s (M.insert 2 c m))
  hook $ Right $ updateChara (++("//field:" ++ s))

main = do
  let e = Field "field" $ M.singleton 0 $ Chara "charaA"
  print $ e
  print $ sync (runLA prog) e

simpleYield.hs

{-# LANGUAGE DeriveFunctor #-}
import Control.Monad.Coroutine
import Control.Monad.State

data Yield x = Yield x deriving (Functor)

yield :: (Monad m) => Coroutine Yield m ()
yield = suspend (Yield $ return ())

-- No instance for (MonadTrans (Coroutine Yield))
instance Functor s => MonadTrans (Coroutine s) where
   lift = Coroutine . liftM Right

producer :: Coroutine (Yield) (State String) ()
producer = do
  lift $ modify (++ "!!")
  lift $ modify (++ "abc")
  yield
  lift $ modify (++ "??")
  lift $ modify (++ "def")

main = do
  let (Left (Yield r),s) = runState (resume producer) ""
  print s
  -- "!!abc"

  let (Right _,s') = runState (resume r) s
  print $ s'
  -- "!!abc??def"