Tickモナドとモナド則

Haskell

まだHaskellをはじめて間もないころ、「bindの度に何かするモナド」を考えた。例えば、

action = do
	putStrLn "one."
	putStrLn "two."
	putStrLn "three."

というコードを実行すると

one
Hello!
two
Hello!
three

と出力するような。応用すれば、「定期的に yield するスレッド」とかを作れそうだ。 というかOCamlのLWT(lightweight thread)とかは多分そういうことをやっているはず。
まず思いつくのは、bindの定義を素朴に書き換えることだ。試してないけどこんな感じに：

newtype MyIO a = MyIO {ext::IO a}
instance MyIO where
  return = MyIO . return
  MyIO m >>= f = MyIO (m >>= \a -> putStrLn "Hello!" >> ext (f a))

しかしこれはモナド則を満たさない。具体的には、returnが >>= の単位元にならない。 m >>= return は "Hello!" を余分に出力するので m と等価ではない。 同様に return a >>= f が f a と等価にならない。

TickT モナド変換子

id:yts さんは(ずいぶん昔の話だが)私に こちらで丁寧にも TickTモナド変換子というものを ReaderTの変種として提示してくださった。tickという関数でIOアクションをliftしたときのみ、環境に入れておいた仕事をする。
一方、当初試していたように、

  • bindの定義で何か他の仕事をさせる
  • モナド則を満たす

ようなモナドもあっていいはずだ（← やってる事はytsさんのTickTと変わらない）。
というわけで下のコードを書いた。多分モナド則は満たしているはず。
ここで定義した Tick はwrapMがliftになるモナド変換子(MonadTransのインスタンス)のように見えるが、多分違う。 例えば lift (return a) は return a と等価であってほしいはずだけど(多分)、wrapM (return a) は余分に仕事をさせるので return a と等価ではない。

ブラウザで試す(ideone)

module Tick(Tick(), runTick, wrapM, w, wrap, p) where

import Control.Monad       -- 例で使う
import Control.Monad.State -- 例で使う

-- | `Tick' monad. Tick is not a monad transformer!!
newtype Tick m a = Tick {untick :: m () -> TickCase m a}
data TickCase m a = Wrap (m a) | Return a


-- | Runs a tick monad.
runTick :: Monad m => Tick m a -> m () -> m a
runTick (Tick f) t = extTickCase (f t)
  where 
    extTickCase (Wrap m)   = m
    extTickCase (Return a) = return a

tryAddTick :: Monad m => TickCase m a -> m () -> m a
tryAddTick (Return a) _ = return a
tryAddTick (Wrap m)   t = t >> m

instance Monad m => Monad (Tick m) where
  return a = Tick (\_ -> Return a)
  Tick f >>= g = Tick (\t -> case f t of 
    Return a -> untick (g a) t
    Wrap m -> Wrap (m >>= \a -> tryAddTick (untick (g a) t) t))

wrapM, w :: Monad m => m a -> Tick m a
wrapM m = Tick (\_ -> Wrap m)
w = wrapM

wrap, p :: Monad m => a -> Tick m a
wrap = wrapM . return
p = wrap


changeTick :: Monad m => (m () -> m ()) -> Tick m a -> Tick m a
changeTick f m = Tick (\t -> untick m (f t))


----------
-- Example 
----------

tick1 = putStr "tick! "
tak1  = putStr "tak! "

ex1 = do wrapM (putStr "Hello, "); wrapM (putStrLn "World!")
-- *Tick> runTick ex1 tick1
-- Hello, tick! World!
-- 
-- *Tick> runTick ex1 tak1
-- Hello, tak! World!

ex2 = mapM (\x -> do w$ print x; return x) [1..10]
-- *Tick> runTick ex2 tick1
-- 1
-- tick! 2
-- tick! 3
-- tick! 4
-- tick! 5
-- tick! 6
-- tick! 7
-- tick! 8
-- tick! 9
-- tick! 10
-- [1,2,3,4,5,6,7,8,9,10]
-- *Tick> runTick ex2 tak1
-- 1
-- tak! 2
-- tak! 3
-- tak! 4
-- tak! 5
-- tak! 6
-- tak! 7
-- tak! 8
-- tak! 9
-- tak! 10
-- [1,2,3,4,5,6,7,8,9,10]

inc :: State Int ()
inc = State (\s -> ((), s+1))

ex3 = runTick (foldM (\x y -> p$ x+y) 0 [1..10]) inc

-- *Tick> runState ex3 0
-- (55,9)