(Storeコモナドによる) LookAtパターンCoroutineバージョン

_Output

> main
(0,"env")
(6,"env/now:6")
(11,"env/now:6/aaa")

Yield.hs

{-# LANGUAGE GADTs, TemplateHaskell, FlexibleContexts #-}
import Control.Lens
import Control.Arrow
import Data.Functor.Product
import Control.Monad.State
import Control.Monad.Operational.Mini
import Control.Comonad.Store

data Pattern p q x where
  Hook :: Either (p -> p) (q -> q) -> Pattern p q ()
  Self :: Pattern p q p
  Env :: Pattern p q q
  Yield :: Pattern p q ()

makeSingletons ''Pattern

type ReifiedLookAt p q = ReifiedProgram (Pattern p q)

runLookAt :: ReifiedLookAt p q () -> State (Store p p, Store q q) (ReifiedLookAt p q ())
runLookAt (Hook (Left f) :>>= next) = do
  modify $ first $ extend (f . extract)
  runLookAt $ next ()
runLookAt (Hook (Right f) :>>= next) = do
  modify $ second $ extend (f . extract)
  runLookAt $ next ()
runLookAt (Self :>>= next) = do
  fst `fmap` get >>= runLookAt . next . extract
runLookAt (Env :>>= next) = do
  snd `fmap` get >>= runLookAt . next . extract
runLookAt (Yield :>>= next) = return $ next ()
runLookAt r@(Return ()) = return r

ex1 :: ReifiedLookAt Int String ()
ex1 = do
  hook $ Left $ (+3)
  hook $ Left $ (+3)
  n <- self
  hook $ Right $ (++ "/now:" ++ show n)
  yield
  
  hook $ Left $ (+5)
  hook $ Right $ (++ "/aaa")

run :: (p,q) -> ReifiedLookAt p q () -> ((p,q), ReifiedLookAt p q ())
run r m = (extract *** extract $ r', m') where
  (m', r') = runLookAt m `runState` (store id *** store id $ r)

main = do
  let s = (0, "env")
  print $ s
  go s ex1
  
  where
    isReturn (Return _) = True
    isReturn _ = False
  
    go s m = do
      let (s', m') = run s m
      print $ s'
      unless (isReturn m') $ go s' m'