ReaderとWriterの組み合わせにフィードバック機能が付いたら面白そうだな、と考えた結果。計算の間の相互作用を記述するのに使えそう

Mirror.hs

{-# LANGUAGE FlexibleContexts #-}
module Control.Monad.Mirror (MirrorT, MirrorF, look, pose, reflect, runMirrorT) where
import Control.Monad.Trans.Free
import Control.Monad.Trans
import Data.Monoid

data MirrorF i a = Look (i -> a) | Pose i a | Reflect a

instance Functor (MirrorF i) where
    fmap f (Look g) = Look (f . g)
    fmap f (Pose i x) = Pose i (f x)
    fmap f (Reflect x) = Reflect (f x)

type MirrorT i = FreeT (MirrorF i)

-- | 鏡を見る。
look :: MonadFree (MirrorF i) m => m i
look = wrap $ Look return

-- | 鏡にモノを映す。
pose :: MonadFree (MirrorF i) m => i -> m ()
pose i = wrap $ Pose i (return ())

-- | モノを反射させる。今までにposeしたものがlookで見えるようになる。
reflect :: MonadFree (MirrorF i) m => m ()
reflect = wrap $ Reflect (return ())

-- | Mirrorモナドを実行し、結果を取り出す。
runMirrorT :: (Monad m, Monoid i) => i -> MirrorT i m a -> m a
runMirrorT initial = run initial mempty where
    run image current m = runFreeT m >>= \r -> case r of
        Pure a -> return a
        Free (Look f) -> run image current (f image)
        Free (Pose img cont) -> run image (mappend current img) cont
        Free (Reflect cont) -> run current mempty cont

main = runMirrorT [0..9] $ do
    i <- look
    lift $ print i -- [0,1,2,3,4,5,6,7,8,9]が表示される
    
    pose (filter odd i)
    pose (filter even i)
    
    look >>= lift . print -- [0,1,2,3,4,5,6,7,8,9]が表示される
    reflect
    look >>= lift . print -- [1,3,5,7,9,0,2,4,6,8]が表示される
    reflect
    look >>= lift . print -- []が表示される