継続モナドについて

継続モナドについて勉強したこと、考えたことのまとめです。

#継続渡しスタイル(CPS)
例として階乗を求めるプログラムを通常の書き方とCPSで書いてみる。
※コメントで指摘いただきましたがこの例はCPSになってませんでした。

-- 通常スタイル
fact :: (Eq a, Num a) => a -> a
fact 0 = 1
fact n = n * fact (n-1)

fact 3 == 3 * fact 2
       == 3 * 2 * fact 1
       == 3 * 2 * 1 * fact 0
       == 3 * 2 * 1 * 1

-- CPS
cFact :: (Eq a, Num a) => a -> (a -> r) -> r
cFact 0 f = f 1
cFact n f = f $ cFact (n-1) (n*)

cFact 3 id == cFact 2 (3*)
           == 3 * cFact 1 (2*)
           == 3 * 2 * cFact 0 (1*)
           == 3 * 2 * 1 * 1

#継続モナド

newtype ContT r m a = ContT{runContT :: (a -> m r) -> m r}
type Cont r a = ContT r Identity a

instance Monad (ContT r m) where
  return a = ContT $ \k -> k a
  x >>= f  = ContT $ \k ->
    runContT x $ \a -> runContT (f a) k

地味にmをモナドに制限しなくても継続モナドのモナド変換子が定義できます。
最終継続a -> m rがモナド変換の役割をするのでContT自体のモナドの定義にはmがモナドである必要がないのです。たぶん。
大抵runContTの最終継続にはreturnを渡しますし。(=evalContT)

instance MonadTrans (ContT r) where
  lift ma = ContT (ma>>=)

liftの定義をよくみるとわかるけど、そもそもバインド(>>=)::m a -> (a -> m b) -> m bが継続そのものなのです。

##使いみち１
なにかの処理の結果を受けてなにかする

withBenchmark :: IO () -> (POSIXTime -> IO r) -> IO r
withBenchmark act fn = do
  t1 <- getPOSIXTime
  act
  t2 <- getPOSIXTime
  fn (t2 - t1)

main :: IO ()
main = evalContT $ do
  t1 <- ContT $ withBenchmark $
    print $ sum [1..10000]
  t2 <- ContT $ withBenchmark $
    print $ sum [1..1000000]
  liftIO $ print t1
  liftIO $ print t2

>>> main
50005000
500000500000
0.0330019s
0.3710212s

##使いみち２（リソース管理）
以下の記事がわかりやすくまとめてくれています。
継続モナドによるリソース管理

#callCC
callCCをつかうと継続の中断ができます。

callCC :: ((a -> ContT r m b) -> ContT r m a) -> ContT r m a
callCC f = ContT $ \k ->
  let
    exit a = ContT $ \_ -> k a
  in
    runContT (f exit) k

callCCは処理を中断するための函数exitを提供します。
exitは以降の継続を破棄して最終継続まで脱出します。

例1

fizzBuzzList :: ContT r [] String
fizzBuzzList = callCC $ \exit -> do
  i <- lift [1..100]
  when (i`mod`15==0) $ exit "FizzBuzz"
  when (i`mod`5==0) $ exit "Fizz"
  when (i`mod`3==0) $ exit "Buzz"
  return $ show i

>>> evalContT fizzBuzzList
["1","2","Buzz","4","Fizz","Buzz","7","8","Buzz","Fizz","11","Buzz","13","14","FizzBuzz","16","17","Buzz","19","Fizz","Buzz","22","23","Buzz","Fizz","26","Buzz","28","29","FizzBuzz","31","32","Buzz","34","Fizz","Buzz","37","38","Buzz","Fizz","41","Buzz","43","44","FizzBuzz","46","47","Buzz","49","Fizz","Buzz","52","53","Buzz","Fizz","56","Buzz","58","59","FizzBuzz","61","62","Buzz","64","Fizz","Buzz","67","68","Buzz","Fizz","71","Buzz","73","74","FizzBuzz","76","77","Buzz","79","Fizz","Buzz","82","83","Buzz","Fizz","86","Buzz","88","89","FizzBuzz","91","92","Buzz","94","Fizz","Buzz","97","98","Buzz","Fizz"]

２段階で脱出したりもできる

例2

hoge :: ContT r [] (Int,Int)
hoge = callCC $ \exit1 -> do
  i <- lift [1..9]
  when (i>3) $ exit1 (0,0)
  j <- callCC $ \exit2 -> do
    j <- lift [1..9]
    when (j == 5) $ exit2 0
    when (j == 7) $ exit1 (-1,-1)
    return j
  return (i,j)

>>> evalContT hoge
[(1,1),(1,2),(1,3),(1,4),(1,0),(1,6),(-1,-1),(1,8),(1,9),(2,1),(2,2),(2,3),(2,4),(2,0),(2,6),(-1,-1),(2,8),(2,9),(3,1),(3,2),(3,3),(3,4),(3,0),(3,6),(-1,-1),(3,8),(3,9),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)]

#CPS版モナド
モナドはCPSで書き直すことができます。
CPSスタイルで書くと、もとの性質と継続モナドの性質を併せ持った形になるので結構嬉しいです。
CPS版のモナドの方がパフォーマンスもいいらしい（未検証）

CPS版State

newtype CStateT r s m a = CStateT{runCStateT :: s -> ((a,s) -> m r) -> m r}

-- Monad
instance Functor (CStateT r s m) where
  fmap f x = CStateT $ \s k -> runCStateT x s $ \(a,s') -> k (f a,s')

instance Applicative (CStateT r s m) where
  pure a = CStateT $ \s k -> k (a,s)
  f <*> x = CStateT $ \s k ->
    runCStateT f s $ \(g,s') ->
    runCStateT x s' $ \(a,s'') -> k (g a,s'')

instance Monad (CStateT r s m) where
  x >>= f = CStateT $ \s k ->
    runCStateT x s $ \(a,s') ->
    runCStateT (f a) s' k

-- StateT
type StateT s m a = CStateT (a,s) s m a
stateT :: Monad m => (s -> m (a,s)) -> StateT s m a
stateT f = CStateT $ \s k -> f s >>= k

runStateT :: Monad m => StateT s m a -> s -> m (a,s)
runStateT x s = runCStateT x s return

get :: CStateT r s m s
get = CStateT $ \s k -> k (s,s)

put :: s -> CStateT r s m ()
put s = CStateT $ \_ k -> k ((),s)

-- callCC
callCC :: ((a -> CStateT r s m b) -> CStateT r s m a) -> CStateT r s m a
callCC f = CStateT $ \s k ->
  let
    exit a = CStateT $ \_ _ -> k (a,s)
  in
    runCStateT (f exit) s k

CPS版List

newtype CListT r m a = CListT{runCListT :: ([a]->m r)->m r}

instance Functor (CListT r m) where
  fmap f x = CListT $ \k ->
    runCListT x $ \as -> k (fmap f as)

instance Applicative (CListT r m) where
  pure a = CListT $ \k -> k [a]
  f <*> x = CListT $ \k ->
    runCListT f $ \fs ->
    runCListT x $ \as -> k (fs <*> as)

instance Monad (CListT r m) where
  x >>= f = CListT $ \k ->
    let
      fn [] = k
      fn (a:as) = \bs ->
        runCListT (f a) $ \bs' -> fn as (bs ++ bs')
    in
      runCListT x $ \as -> fn as []

callCC :: ((a -> CListT r m b) -> CListT r m a) -> CListT r m a
callCC f = CListT $ \k ->
  let
    exit a = CListT $ \_ -> k [a]
  in
    runCListT (f exit) k

#shift/rest（限定継続）

-- fに以降の継続を渡す。
shiftT :: Monad m => ((a -> m r) -> ContT r m r) -> ContT r m a
shiftT f = ContT $ \k -> evalContT (f k)

-- xの継続を一旦終了して、結果を次の継続に渡す。
resetT :: Monad m => ContT r m r -> ContT r' m r
resetT x = ContT $ \k -> evalContT x >>= k

##resetは継続の範囲を限定する
例１では、ハンドラは最後の処理が終わるまで閉じられない

例１

ex1 :: ContT r IO ()
ex1 = do
  rh <- ContT $ withFile "hoge.txt" ReadMode
  contents <- liftIO $ hGetContents rh
  wh <- ContT $ withFile "fuga.txt" WriteMode
  liftIO $ hPutStr wh contents
  liftIO $ putStrLn "Hello,World!"
  -- ※whはここで閉じる
  -- ※rhはここで閉じる

---

例２ではresetTを使って、ハンドラの継続を限定することで、必要な処理が終わったらすぐにハンドラを閉じることができる。

例２

ex2 :: ContT r IO ()
ex2 = do
  contents <- resetT $ do
    rh <- ContT $ withFile "hoge.txt" ReadMode
    liftIO $ hGetContents rh
    -- ※rhはここで閉じる
  resetT $ do
    wh <- ContT $ withFile "fuga.txt" WriteMode
    liftIO $ hPutStr wh contents
    -- ※whはここで閉じる
  liftIO $ putStrLn "Hello,World!"

※例２は実際には遅延評価のせいでうまく動作しない。
Control.DeepSeqを使うなどして正格評価されるようにしてやる必要がある。
参考：What caused this “delayed read on closed handle” error?

例２'

ex2 :: ContT r IO ()
ex2 = do
  contents <- resetT $ do
    rh <- ContT $ withFile "hoge.txt" ReadMode
    contents <- liftIO $ hGetContents rh
    return $!! contents
    -- ※rhはここで閉じる
  resetT $ do
    wh <- ContT $ withFile "fuga.txt" WriteMode
    liftIO $ hPutStr wh contents
    -- ※whはここで閉じる
  liftIO $ putStrLn "Hello,World!"

shiftは継続を取り出す

sh1 :: ContT r [] (Integer, Integer)
sh1 = do
  i <- lift [1..3]
  x <- shiftT $ \k -> lift $ k 5 ++ k 6
  return (i,x)

>>>evalContT sh1
[(1,5),(1,6),(2,5),(2,6),(3,5),(3,6)]

継続モナドが絡むとわかりにくいですが、上記のコードは以下と同じです。

sh1' :: ((Integer, Integer)->[r]) -> [r]
sh1' g = [1..3] >>= f1 where
  f1 i = k 5 ++ k 6 where
    k x = g (i,x)

>>>evalContT sh1'
[(1,5),(1,6),(2,5),(2,6),(3,5),(3,6)]

shiftを使って継続を破棄してやれば、callCCと同じことができます。

fizzBuzzList :: ContT String [] String
fizzBuzzList = do
  i <- lift [1..100]
  when (i`mod`15==0) $ shiftT $ \_ -> return "FizzBuzz"
  when (i`mod`5==0) $ shiftT $ \_ -> return "Fizz"
  when (i`mod`3==0) $ shiftT $ \_ -> return "Buzz"
  return $ show i

ただし、callCCの脱出函数はa -> ContT r m bなのでaを渡すのに対してshiftTはContT r m rをかえしてあげる必要があります。
その点で利用できなかったり、つかいにくい場面があります。

#おわりに
継続モナドについて学んでみて、リソース管理と脱出への利用が便利だと思いました。
あと、コールバック地獄がdo記法でスッキリかけるのようになるのは便利。

shift/resetについてはまだまだ理解の及ばないところが多いです。
resetについてはリソース管理と合わせると使いみちが思いつくんですけど、shiftについてはcallCCのかわりに継続破棄する以外の実用的な利用方法があまり思いつきません。
shift/reset プログラミング入門に色々なことが解説されているんですけど、Haskellで定義されてる形のshift/resetだと継続の取り出しとか継続の保存がうまく定義できない気がしてます。
詳しい人いたら教えてください。