雑記帳

Haskell で break 機能付きループを作る

Haskell でループから抜け出す
前置き
Haskell で繰り返し処理を記述したい場合、「適当な自己準同形を組み立ててから、その関数を不動点コンビネータに渡してあげる」という形を取ることもできるが、実は従来の命令型プログラミング言語が標準的にサポートしている「for ループ」や「while ループ」のようなものを使って記述することもできないことはない。(ちょっと含みのある言い方になっている理由は最後まで目を通せば明らかになるよ)
まず forever という、単なる無限ループを作る関数の存在自体は有名だと思う。
とはいえ実際にこの関数を使ってみたことがある人なら実感できると思うが、「無限ループからの脱出法」が割と大きな問題として付随している。
例えばその場面において「無駄な機能は多い一方で、なんで多くの古典的なプログラミング言語では当たり前に使用が認められているはずの break がこの言語には欠落しているのだ?」と疑問に思った人も少なくないだろう。
これについて補足しておくと、そもそも純粋関数型言語である Haskell においては、その break という識別子にもある種の “数学的な実体” が伴っていなければならず、中身のない漠然とした「表記上の記号」として「ループからの脱出機能」を無造作に導入することは許されない。
でも視点を変えれば、これは「手続きの中断」をしっかりと数学的に厳密に書けばいいだけの話でもあり、そこでここではその一つの回答となる「call/cc : call-with-current-continuation を使った記述方法」を簡単に紹介していくことにしてみる。
例: yes と入力されたら終了するプログラム
以下の Python コード
def main():

  cnt = 1
  print("\nHello, there!\n")

  while True:
    # cnt = cnt

    print("Do you like category theory" + ("?" * cnt) + " (yes / no)")
    dat = input(">> ")

    print("")
    if (dat.lower() == "yes"):
      print("Of course, I knew you love it!\n")
      break
    else:
      print("Perhaps, you misspelled \"yes\" as \"" + dat + "\".")
      print("Please enter the correct one.\n")

    cnt = cnt + 1

  print("(Terminating...)")

main()
が与えられたとし、このコーディングスタイルに似せる努力をしつつそれを Haskell コードへと書き変えると、一例として以下が得られる。
import Control.Monad
import Control.Monad.Trans.Cont
import Control.Monad.IO.Class
import Data.IORef

main :: IO ()
main = evalContT $ do

  cnt'REF <- liftIO(newIORef 1)
  liftIO(putStrLn $ "\nHello, there!\n")

  foreverExt $ \break -> do
    cnt <- liftIO(readIORef cnt'REF)

    liftIO(putStrLn $ "Do you like category theory" ++ (replicate cnt '?') ++ " (yes / no)")
    dat <- liftIO(input(">> "))

    liftIO(putStrLn $ "")
    if (lower(dat) == "yes") then do
      liftIO(putStrLn $ "Of course, I knew you love it!\n")
      break
    else do
      liftIO(putStrLn $ "Perhaps, you misspelled \"yes\" as \"" ++ dat ++ "\".")
      liftIO(putStrLn $ "Please enter the correct one.\n")

    liftIO(modifyIORef' cnt'REF (+1))

  liftIO(putStrLn $ "(Terminating...)")


input :: String -> IO String
input str = (putStr str) >> getLine

lower :: String -> String
lower str = do
  c <- str
  if c `elem` ['A'..'Z'] then
    return $ toEnum(fromEnum 'a' + (fromEnum c - fromEnum 'A'))
  else if c == '!' then
    []
  else
    return $ c

foreverExt :: (ContT () IO () -> ContT () IO ()) -> ContT () IO ()
foreverExt action =
  callCC $ \exit -> forever $ action(exit ())
これが本当に正しく動作するのかについて疑わしく思う人もいると思うが、試してみればわかるように全く問題なく動作する。
ghci> :l main.hs
[1 of 1] Compiling Main             ( main.hs, interpreted )
Ok, one module loaded.
ghci> main

Hello, there!

Do you like category theory? (yes / no)
>> yees

Perhaps, you misspelled "yes" as "yees".
Please enter the correct one.

Do you like category theory?? (yes / no)
>> yes

Of course, I knew you love it!

(Terminating...)
ghci>
コードを見れば大体のことは読み取れると思うが、Haskell コードについて少しだけ言葉をつけ足しておこう。
肝となる部分は、foreverExt 関数である。
foreverExt :: (ContT () IO () -> ContT () IO ()) -> ContT () IO ()
foreverExt action =
  callCC $ \exit -> forever $ action(exit ())
見ての通りではあるのだが、call/cc を介した処理の中断を行うためのポイントの情報が埋め込まれた継続としての IO アクションに対して先に無限の繰り返しを行い、そうして得られた継続を与える関数を call/cc に渡すことで、最終的に欲しかった「中断処理の施された IO アクションと対応する継続」を獲得している。
(この記事を書き始めた当初はわかりやすさを重視し、その関数の最終出力の型が IO () になるようにしていたのだが、そうしてしまうと脱出可能なループを入れ子で使えない不都合があったため、この「継続を返すスタイル」に変更した)
(..)
最後に、Haskell で通常やりがちな繰り返し処理の記述を使ったバージョンも、対比用のオマケとして載せておく。
import Control.Monad.Fix

main :: IO ()
main = do

  cnt <- return 1
  putStrLn $ "\nHello, there!\n"

  cnt_fin <- mkLoopFromEndoMorphism cnt $ \rec i -> do
    cnt_current <- return i

    putStrLn $ "Do you like category theory" ++ (replicate cnt_current '?') ++ " (yes / no)"
    dat <- input(">> ")

    putStrLn $ ""
    if (lower(dat) == "yes") then do
      putStrLn $ "Of course, I knew you love it!\n"
      return cnt_current
    else do
      putStrLn $ "Perhaps, you misspelled \"yes\" as \"" ++ dat ++ "\"."
      putStrLn $ "Please enter the correct one.\n"
      rec $ i + 1

  putStrLn $ "(Terminating...)"


input :: String -> IO String
input str = (putStr str) >> getLine

lower :: String -> String
lower str = do
  c <- str
  if c `elem` ['A'..'Z'] then
    return $ toEnum(fromEnum 'a' + (fromEnum c - fromEnum 'A'))
  else if c == '!' then
    []
  else
    return $ c

mkLoopFromEndoMorphism :: a -> ((a -> b) -> (a -> b)) -> b
mkLoopFromEndoMorphism initialVal f = (fix f) initialVal
やはりこう見ても、Haskell では Haskell に合ったやり方で繰り返し処理を記述するのが一番な気がする...
あとがき
Python って書きやすい。