parent and child communication

pipe.hs

{-# LANGUAGE GADTs #-}
import Control.Monad
import Data.Functor.Identity
import Linear.V2
import Pipes
import Pipes.Core
import SDLight.Types

(&&&) :: Monad m => Pipe a b m () -> Pipe a' b' m () -> Pipe (a,a') (b,b') m ()
p1 &&& p2 = do
  (a,a') <- await
  for (yield a >-> p1) $ \b ->
    for (yield a' >-> p2) $ \b' ->
    yield (b,b')

data Child1 = Child1 Int deriving (Eq, Show)
data Child2 = Child2 String deriving (Eq, Show)

data Add = Add Int
data Eff1 this m r where
  New1 :: Eff1 this Identity this
  Render1 :: this -> Eff1 this IO ()
  Step1 :: this -> Eff1 this IO (Add,this)

pipeChild1 :: Monad m => Pipe (Eff1 Child1 m r) r m ()
pipeChild1 = do
  await >>= \e -> case e of
    New1 -> yield $ Child1 299
    Render1 this -> do
      lift $ print this
      yield ()
    Step1 (Child1 n) -> do
      yield (Add n, Child1 (n+1))

data Eff this m r where
  New :: Eff this Identity this
  Render :: this -> Eff this IO ()
  Step :: this -> Eff this IO this

pipeChild2 :: Monad m => Pipe (Eff Child2 m r) r m ()
pipeChild2 = do
  await >>= \e -> case e of
    New -> yield $ Child2 "poyo"
    Render this -> do
      lift $ print this
      yield ()
    Step (Child2 n) -> yield $ Child2 $ n ++ "."

lengthTo1 :: Monad m => Pipe Child2 Child1 m ()
lengthTo1 = await >>= \(Child2 r) -> yield $ Child1 (length r)

--

data Parent
  = Parent
  { number :: Int
  , child1 :: Child1
  , child2 :: Child2
  }
  deriving (Eq, Show)

handleChild1ToParent :: Monad m => Pipe (Add,Child1) (Parent -> Parent) m ()
handleChild1ToParent = await >>= \r -> case r of
  (Add t, ch1) -> yield $ \p -> p { child1 = ch1, number = number p + t }

pipeParent :: Monad m => Pipe (Eff Parent m r) r m ()
pipeParent = do
  await >>= \e -> case e of
    New ->
      for (yield New1 >-> pipeChild1) $ \ch1 ->
      for (yield New >-> pipeChild2) $ \ch2 ->
      yield $ Parent 5 ch1 ch2
    Render this -> do
      lift $ print $ "parent render:"
      lift $ print $ number this
      lift $ print $ "children render:"
      for (yield (Render1 (child1 this) , Render (child2 this)) >-> pipeChild1 &&& pipeChild2) $ \_ ->
        return ()
    Step this -> forever $ do
      for (yield (Step1 (child1 this)) >-> pipeChild1 >-> handleChild1ToParent) $ \f ->
        for (yield (Step (child2 this)) >-> pipeChild2) $ \ch2 ->
        yield $ f $ this { number = number this + 1, child2 = ch2 }

main = do
  let g = yield New >-> pipeParent
  let Right (a,x) = runIdentity $ next g

  print a
  -- Parent {number = 5, child1 = Child1 299, child2 = Child2 "poyo"}

  print . fmap fst =<< next (yield (Render a) >-> pipeParent)
  -- "parent render:"
  -- 5
  -- "children render:"
  -- Child1 299
  -- Child2 "poyo"
  -- Left ()

  print a
  -- Parent {number = 5, child1 = Child1 299, child2 = Child2 "poyo"}
  
  Right (b,_) <- next (yield (Step a) >-> pipeParent)
  print b
  -- Parent {number = 305, child1 = Child1 300, child2 = Child2 "poyo."}
  
  Right (c,_) <- next (yield (Step b) >-> pipeParent)
  print c
  -- Parent {number = 606, child1 = Child1 301, child2 = Child2 "poyo.."}