yunomuのブログ

趣味のこと

Haskellで特定のモジュールのコンパイルが遅すぎる

Haskell

という話があって。

具体的にはaws-sdk(https://github.com/worksap-ate/aws-sdk)の開発中の話で、
aws-sdkではTravis CI(https://travis-ci.org/)を使ってビルドだけのテストをしているんですが、そのテストっていうかビルドが頻繁に失敗するようになってしまった。
原因はAWS.EC2.Typesのコンパイルで、このモジュールのコンパイルだけで5分以上かかる。その間何も画面出力などはされなくて、Travisでは何も出力がされないまま5分経過するとビルドプロセスが殺されてしまうという。

これはいけませんというか、いや別に普通にTravis以外ではビルドできてるからいいといやいいんだけど、これでTravisを切り捨てるのもかっこ悪いしねぇどうしようかと。
それとは別なのかもしれないけど32bit版LinuxだとAWS.EC2.Typesのコンパイル中にghcがsegmentation faultで落ちるという問題もあって、いい加減このモジュールどうにかした方がいいんじゃないかと思っていました。

当時のソースはこんな感じ。
aws-sdk/AWS/EC2/Types.hs at v0.9.2.1 · worksap-ate/aws-sdk · GitHub

データ定義が140個並んでいて、全部がEq, Show, Readのインスタンスになってて、あとその中でFromTextクラスのインスタンス化してる型が、TemplateHaskellを使うものが64個、TemplateHaskellを使わないものが8個という感じ。72個。

これ一見TemplateHaskellが重いのかなぁと思うんですけど、TemplateHaskellが絡むモジュールだけを分割しても大して変わらないし、モジュールを大雑把に2つに分けても結局その根本のAWS.EC2.Typesのコンパイル時間はあまりかわらないし、なんなんだこれと思って、exportするシンボルの数が多いとか最適化とかそういうのかなぁでもデータ定義しか無いし、

などとバカな話も考えはじめていたんですが、
との提案を受けたので、1日かけてもいいのでよろしくって言って彼にやってもらいました。

私が最初にやったテキトウな分割と違って、きちんとデータ間の依存関係を調べて分割してくれました。すげえ、ありがとうございます。
結果: aws-sdk/AWS/EC2/Types at f43a8b589db1271c9183339873a2115e61a7d9ce · worksap-ate/aws-sdk · GitHub
diff: Split EC2/Types. · f43a8b5 · worksap-ate/aws-sdk · GitHub

で、これをやった結果、ファイルが19個増えたものの、AWS.EC2.Typesのコンパイルが速くなるってもんじゃなくて、コンパイル時間が全体で60%ほど短くなりました。いや短くなりすぎだろうという気もしますが、短くなったものは仕方ないじゃないか。
ともあれ成果出てよかった。

よく考えてみるとHaskellのデータ構造ってC言語みたいな単純なメモリマップとは違って、コードに近いんですよね多分。いやghcが吐くコードがどんなものか知りませんけど。
まあそれが関係あるのかどうかはわかりませんけど、データ間の依存関係の計算に時間がかかってたんじゃないかなぁと。@amkkunが分割してくれた結果、ある程度の依存関係はモジュール分割の段階で解決してしまっているので、それで劇的に速くなったんじゃないかなぁ。同一モジュール間でデータの関係とか調べるのかな、そうだとしたら140個は多すぎるよな。
そういう感じでした。
そもそもexportが重いとかだったらAWS.EC2もかなり重くなってしかるべきなので、その予想はさすがに無かったかな。

ということで、シンボルが多すぎる時は気をつけましょうというか、適切にインタフェースを定義したモジュールに分割しましょうというお話でした。あとこれ関係で、できるだけexportするシンボルはきちんと列挙しておいた方がいいかもしれないとも思った。

32bit Linuxについては検証するの忘れてたからまた今度。

Haskell忘年会でAWS SDK for Haskellについて喋った

Haskell AWS

去る12月16日に行われたHaskell忘年会なるイベントでしゃべってきました。
忘年会もなにも勉強会とかにはあんましで出かけないのでほとんどの方ははじめましてという感じ？　いや知ってる人も割といましたね。同僚とか同僚とか。

その時の発表スライドです。


要は作りましたというお話です。作りました。

Hackageにも登録してあります。
http://hackage.haskell.org/package/aws-sdk
ソースはGitHubにあります。
worksap-ate/aws-sdk · GitHub

まあそんなような感じです。

聞く側としては話題のFreeモナドの話がちょっとおもしろそうな感じでした。「そのライブラリもFreeで書いたらテスト楽になるんじゃないの？」って言われて、確かに面白そうな気もするけどバリバリConduit依存なのでちょい厳しいのかもしれません。いやFreeは全然使ったことないのでなんとも言えませんけど。

あとはmasterqさんにいっしょにOSカーネル書こうぜーって絡まれてたのが面白かった。
ビデオメモリ直書きで画面表示とか、泣きながらstop or rebootデバッグ（無限ループを仕込んで、何も起きなければそこまでは到達している、再起動がかかったらそれ以前でバグっているという画面が使えない時のprintfデバッグ的な技。タイムスライスで結局死んだりする）をした日々とか、やりたいようなやりたくないような感じだけどやると結構楽しいんですよねーっていう話をしていました。

忘年会なんで、終始割とゆるく楽しむ感じで、面白かったです。

少しはテストを楽しくやる(QuickCheck)

Haskell

テストって別にやりたくないわけじゃないっていうかやりたいんですけど、なんかつい後回しになってしまうというか。
でも例えば外部システムとの連携部分だったりすると私は割と真面目にテストを書くんですが、普段はなんかなんとなく面倒臭い。面倒くさいと面倒くさくないの境界線は何なんだ。

外部システム連携みたいな入出力系のテストがそれほど苦じゃないのは、どっちにしろ動作確認で動かすからなんですよね。
一方でそれ以外の部分、いわゆる計算というか、モジュール間のデータのやり取りだったりデータ変換だったりとか、そういう部分のテストがなんで面倒くさいかといったら、それは足し算をテストする時の事を考えるとだいたい想像つくと思いますけど、

@Test
void testPlus() {
    assertEqual(plus(1, 1), 2);
    assertEqual(plus(1, -1), 0);
    assertEqual(plus(2, 3), 5);
    assertEqual(plus(-5, 4), -1);
    ...

そこで浮かんでくる感情というのは「わかりきってるじゃんそんなこと」だったり、「a+b=cのa,b,cをどのくらい用意すればいいのかわからない」だったり、「いや並べておけばいいんだけどそんな単純作業面倒くさい」だったりで、一言で言うと面白くないわけです。面白くない。

これなんとか面白くならないものか。
……という観点で出会ったわけでは全然ないんですけど、ちょっとテストを書く用事ができて、QuickCheckを使ってみたらこれが割と面白かったのです。

QuickCheckというのは話には聞いたことがあったんですけど、要は関数の性質を検査するものらしいと。

性質とはなんぞや。
例えば、リストをソートする関数があった場合、実装がバブルソートだろうがクイックソートだろうが、それ以外の何か高速なアルゴリズムで実装されていようが、同じ入力に対する出力結果は同じです。こういう時に性質が同じと言う。
例えば、リストの順序を逆にする関数があった場合、任意のリストに対してその関数を2回適用すると元に戻るという性質がある。
例えば、ある数値を文字列に変換してそれをさらに数値に変換すると元の数値に戻ってほしい。
そういうものですよね。

そういう時にQuickCheckではこう書くらしい。といいつつこれコンパイルすらもしてないから動くのかはわからないけども。

import Test.Hspec
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck

spec :: Spec
spec = do
    describe "sort test" $ do
        prop "int" (test_sort :: [Int] -> Bool)
        prop "string" (test_sort :: [String] -> Bool)
    describe "reverse test" $ do
        prop "int" (test_reverse :: [Int] -> Bool)
        prop "char" (test_reverse :: [Char] -> Bool)
    describe "transform test" $ do
        prop "int to string" test_int_str

-- バブルソートとクイックソートは同じ結果になる
test_sort :: Ord a => [a] -> Bool
test_sort xs = bubble_sort xs == quick_sort xs

-- リストの逆順の逆順は元と同じになる
test_reverse :: [a] -> Bool
test_reverse xs = xs == reverse (reverse xs)

-- 数値を文字列に変換して、それを数値に変換すると元に戻る
test_int_str :: Int -> Bool
test_int_str i = i == parseInt (toString i)

ここのtest_sort, test_reverse, test_int_strで、さっき挙げた例と同じ事をやっています。
この3つの関数は全部何らかの入力を受けて、関数の性質が正しければTrueを返すようにしています。
じゃあこの「何らかの入力」というのは何なのかというと、任意の[Int]だったり[String]だったりIntだったり、それはprop関数が値の型から自動的にランダムな値を選んで適当に突っ込んでくれるらしい。

どういう仕組なのかというと、これ。
Test.QuickCheck.Arbitrary
Test.QuickCheckをimportするとIntとか[Int]とかCharとかそのあたりがあらかたArbitraryのインスタンスになって、arbitrary関数を呼び出すと、その型のランダムな値が取り出せるようになる。このランダムな値を使ってpropが適当に入力を生成してテストしてくれるというわけらしい。
生成する型インスタンスの情報が必要なので、sortとかreverseでは型注釈を書かないといけなかったわけです。
運悪く間違えてテストが通ってしまうとかありそうな気がしないでもないけど、まあ自動テストして何度も回していればいつか気づくでしょうとか、そういう感じでしょうか。そこら辺はよくわかりませんが。

で、自分で作ったデータ型に関してもArbitraryのインスタンスにしてっていうか、あの辺のモジュールにあるGenを生成するchooseとかelementsだとかいう関数を使ってarbitraryを実装してあげれば、任意の値を使った性質のテストが書けるという。

例は私が書いたものじゃないんですけど。山本先生のIPアドレス表現関係のライブラリです。
iproute/test/RouteTableSpec.hs at readaddr · yunomu/iproute · GitHub
自作のIPv4とかIPv6のデータをArbitraryのインスタンスにして、それぞれのCIDRもvalidなものを自動生成するようなコードが上の方に固まっています。

これに対して私がPull Requestを送った時に書いた異常系のテストがこっち。
iproute/test/IPReadSpec.hs at readaddr · yunomu/iproute · GitHub
InvalidIPv4とかそういうデータを定義して、異常な入力値を作っている。ここでは例えばIPv4のCIDRのマスクビット数が0-32以外の値である場合を作っています。文字とか突っ込んでもよかったなぁ。
これらを使ったテストを下の方に書いてます。今回はread関数をテストしたかったんですけど、SafeのreadMayを使ってテストするのもアリかなと思ってこんな感じにしてみましたっていうか、readMayでも問題なく使えるようにするのが目的だったんですが。

こういうのを使って正常な値を自動生成するとか異常な値を自動生成するとかいう作業は割と楽しかったりする。というか楽しかったのです。
どうやってテストできるだろうとか正常値をどう表現しようとか考えたりするのは大変だけど楽しいですよね。コピペは楽しくない。

参考というか、実際は参照してなかったりするけども。
Haskellの単体テスト最前線 - あどけない話
あと全然関係ないけどPull Requestする時に参考になった。
お気軽 pull request - Quickhack Diary

readを使って文字列をRead aに変換しようとする

Haskell

最初はreadTextみたいな関数を作ろうとしていました。
readの、StringじゃなくてTextを取る版。

readText :: Read a => Text -> a

で、最初はこんな感じで実装しようとしていた。

module Main where

import Data.Text (Text)
import qualified Data.Text as T

readText :: Read a => Text -> a
readText = read . T.unpack

unpackしてできたStringをreadに食わせれば終わりじゃないか。
と思っていたんですが、
ghciで試してみると

Main> :set -XOverloadedStrings
Main> :m Data.Text
Main Data.Text> readText "193" :: Int
193
Main Data.Text> readText "abide" :: Text
"*** Exception: Prelude.read: no parse

TextをTextに変換しようとすると失敗する。
「TextってReadのインスタンスだよね？　なんで？」って一人で大騒ぎしていました。

というかよくよく考えて試してみると、

Prelude> read "841" :: Int
841
Prelude> read "abc" :: String
"*** Exception: Prelude.read: no parse

Stringでもunpackとかしなくても普通に失敗する。Intはうまくいくのに。

ヒントはもう出ていて、`"*** Exception:`のところの最初のダブルクォーテーション、文字列をshowした時に出るやつで、文字列はshowしたりする時はダブルクォーテーションで囲まれる。
同様に、readに渡す文字列は文字列の文字列表現の形をとっている必要があって、
つまり

Prelude> read "\"abc\"" :: String
"abc"

文字列は文字列らしくダブルクォーテーションで囲めばよろしい。
文字列だと思ってparseしようとしたのにダブルクォーテーションが無かったから困ったねって事になっていたようです。

ということで、最初のreadTextの実装を変更してみる。unpackじゃなくてshowしてやればいいじゃないか。

readText :: Read a => Text -> a
readText = read . show

showしてreadってなんかなんじゃそりゃって感じですけどね。

でもこれはこれで問題があって、

Main> readText "186" :: Int
*** Exception: Prelude.read: no parse

今度は数字が読めなくなっている。全然駄目だ。
showしたことで文字列がダブルクォーテーションで囲まれてしまって、数字としてreadできなくなったということで。
そういう時だけは(read . unpack)でいいんだけど。

で、最終的にSafeモジュールのreadMayを使ってこうなった。

import Data.Text (Text)
import qualified Data.Text as T
import Safe (readMay)
import Data.Maybe (fromMaybe)

readText :: Read a => Text -> a
readText t = fromMaybe (read $ T.unpack t) . readMay . show $ t

文字列系に変換するパターンの方が圧倒的に多かったのでこういう感じに。文字列以外に変換するパターンが多かったら、showとunpackの位置が逆になるんじゃないでしょうか。

ということで出来上がったのはreadではなくて、なんか、汎用のデータ変換関数？　結局readとは少し違うものができてしまいましたし、最初から目指していたのはこれでした。

この変換関数を作成中のプロダクトの基盤部分に突っ込んでみた結果、それはそれで「型推論できないぞ」って怒られまくったんですが、それはまた別の話。
readを使いこなすのって難しいですよねぇ。というかあんまし使いたくないけども。

Haskellでコマンドラインパーサを使う2

Haskell

前回とは違うライブラリを使ってみます。
前回: Haskellでコマンドラインパーサを使う - yunomuのブログ

前回の記事ではcmdargsを使ったんですが、あれはあれで面倒くさいというか、あらかじめ定義したrecord型の通りにしかデータを取ることができないのがたまに面倒だったりとか。
第二引数があった時は第三引数が必須とか、逆に要らないとか、そういうのが面倒くさかったりします。
具体的にはgitみたいなのを作るのが面倒くさい。

ということで他になんかないものかと思って使ってみたのがparseargsというライブラリです。

ArgとかArgsとか似たような型が色々あってちょとややこしいですけど、要するにparseArgsIOに[Arg a]の配列を渡してあげればとりあえず使えそう。で、Arg aというのがコマンドライン引数の型とかオプション文字列とかdescriptionとかを持ったいわゆる「設定」で、"a"はハッシュのキーみたいなもののようだ。
なのでさしあたりaはIntということにするとこうなる。

module Main where
import System.Console.ParseArgs

options :: [Arg Int]
options =
    [Arg 1 Nothing Nothing (argDataRequired "abc" ArgtypeInt) "abc value"]

main :: IO ()
main = do
    a <- parseArgsIO ArgsComplete options
    putStrLn $ "progName: " ++ argsProgName a
    print (getArg a 1 :: Maybe Int)

これを実行するとこうなる。

% ./args
args: missing required argument <abc>
usage: args <abc>
  <abc>  abc value

DataArg（Argの4つ目の引数）を"argDataRequired"で作って渡したので、この引数はRequiredになっている。引数の名前が<abc>になってるのも、argDataRequiredに渡した文字列から取られているみたいですっていうか、マニュアルにそう書いてます。
で、なんか適当な引数を渡してみる。

% ./args text
progName: args
args: argument text to abc is not an int
usage: args <abc>
  <abc>  abc value

これは"text"って文字列を渡しているんですが、やっぱりargDataRequiredに渡してるArgtypeがArgtypeIntになっているので、Intとしてパースできる値を渡してあげないとエラーになる。

% ./args 1234
progName: args
Just 1234

Intとしてパースできる文字列を入れてあげるとこのようにうまくいきます。

ここでちょっと面白いのは、"text"って文字列を渡した時の動きで。これよく見ると、putStrLnで出力した文字列は先に出てるんですよね。
つまりこの「"text"はintじゃないからだめだよ」っていう感じのエラーメッセージは、parseArgsIOを実行した時ではなくて、そこで取ってきた値を使おうとした時、つまりgetArgした時に出力されているということなんです。まあこれは単にparseArgsIOの中でerror関数とか使って適当に戻り値を設定しているせいなんだと思いますけど。いや調べてませんけど。
まあこうしておいた方が、「この値が不正な時にどうしよう〜」っていう微妙な需要に対応できる可能性があって良いのかもしれません。どうやってやるのかわかりませんけど。

それはそうと、ArgtypeIntについて、パースできる型はInt, Integer, Float, Double, Stringとあるので、まあ十分でしょう。

Argの一つ目の引数については、最初あたりで書いたようにハッシュのキーみたいになっていて

    print (getArg a 1 :: Maybe Int)

のところの"1"で参照しています。もうちょっとわかりやすい値にした方がいいのかもしれません。

Argの2つ目と3つ目の引数はそれぞれショートオプションとロングオプションの指定になっていて、

    Arg 2 (Just 'f') (Just "flag") Nothing "flag"

みたいにすると、"-f"とか"--flag"を読み取ることができる。

この例の場合、4つ目の引数の、さっきargDataRequiredとかになってた部分がNothingになっていますけど、ここで書いたようにNothingにすると、gccでいうところの"-c"みたいに単体で何らかの意味のあるオプションになります。Just DataArgにすると"-o name"みたいなパラメータがついてるオプションになる。
そしてオプションが存在するかどうかはgotArgで調べられるので、

main = do
    (略)
    print $ gotArg a 2

とすると、"-f"がついていればTrueだし、ついてなければFalseになります。普通にgotArgは引数の存在確認として使えます。

argDataRequiredの代わりにargDataOptionalを使えば必須じゃない引数になりますし、argDataDefaultedを使えば引数が無かった時のデフォルト値を設定することもできる。
argsUsageでヘルプの表示もできる。
あとparseArgsIOに渡してるArgsCompleteは、だいたい何も考えない時はArgsCompleteでいいです。

というのをひと通りやってみたのがGitHubに上げてるこちらになります。
exercises/parseargs/Main.hs at master · yunomu/exercises · GitHub

前回紹介したcmdargsとの違いは、細かい分岐がやりやすいところかなぁ。いやrecordを読むかgetArgを読むか程度の違いしか無い気もしますけど。Requiredな引数を作るのがparseargsの方が簡単なような、うーん。
ヘルプを充実させたいならやっぱりcmdargsの方が強力だった気もしますが、私はどっちかというと今回のparseargsの方が好きかもなぁ。
という感じでした。

Haskellでコマンドラインパーサを使う

Haskell

コマンドライン引数のパースがだいたいどう転んでも面倒くさい。特にCとかJavaとかは本当に泣きたくなりますよね。まあJavaでコマンドラインのプログラムを書く事なんてあんまし無いかもしれませんけど。いや、ありますけど。泣きながら書いてました。

Haskellでもまあ別に普通に面倒くさいんですけど、いくつかライブラリがあって、その中で一番目についたというか使いやすそうだったライブラリがcmdargsでした。

使い方。

{-# LANGUAGE DeriveDataTypeable #-}
module Main where

import System.Console.CmdArgs

data Option = Option
    { label :: String
    , size :: Int
    } deriving (Show, Data, Typeable)

option :: Option
option = Option
    { label = "no label"
    , size = 0
    }

main :: IO ()
main = do
	opt <- cmdArgs option
	print opt

とりあえずサンプルそのまんまです。

これだけでも最低限の機能は持っていて、実行するとこうなる。

% runghc Main
Option {label = "no label", size = 0}

これはコマンドライン引数を何も指定していないので、optionで定義したデフォルト値がそのまま返ってきている。

引数を指定するとこうなる。

% runghc Main --label kirari --size 186
Option {label = "kirari", size = 186}

デフォルトではラベルの名前がそのまま引数の名前になります。

それとこの時点で--helpと--versionは実装されています。

% runghc Main --version
The option program
% runghc Main --help
The option program

option [OPTIONS]

Common flags:
  -l --label=ITEM
  -s --size=INT  
  -? --help        Display help message
  -V --version     Print version information

Intの変換は勝手にやってくれるので、それはちょっと楽です。

で、カスタマイズ。
多くの場合ではOptionのラベル名をそのまま引数の名前として使われると面倒くさいんじゃないかと思います。例えばOptionの定義がこんな場合。

data Option = Option
	{ optLabel :: String
	, optSize :: Int
	} deriving (Show, Data, Typeable)

この場合はオプションがこんなになってしまいます。

% runghc Main --help
{略}
Common flags:
	--optlabel=ITEM
	--optsize=Int

面倒くさいし、ショートオプションなくなってるし。
あ、このライブラリではショートオプションはロングの最初の文字から取られるようです。

で、この時にどうするかというと、デフォルト値にアノテーションを付けて、それをcmdArgsが解釈することでなんかうまくいくみたいです。
コードにするとこんな感じ。option関数のみ。

option :: Option
option = Option
	{ optLabel = "no label" &= name "label"
	, optSize = 0 &= name "size"
	}

仕組みは全くわかりませんが、これでうまくいく。

% runghc Main --help
{略}
Common flags:
  -l --label=ITEM --optlabel
  -s --size=INT --optsize

元の引数名を完全に消したいならexplicitをつける。

option :: Option
option = Option
	{ optLabel = "no label" &= name "label" &= explicit
	, optSize = 0 &= name "size" &= explicit
	}

ヘルプを書きたいならさらにhelpを足す。

option :: Option
option = Option
	{ optLabel = "no label"
	  &= name "label"
	  &= explicit
	  &= help "Name of label"
	, optSize = 0
	  &= name "size"
	  &= explicit
	  &= help "Size of struct"
	}

全体の説明を書きたいならOptionにsummaryをつける。

option :: Option
option = Option
	{ optLabel = "no label"
	  &= name "label"
	  &= explicit
	  &= help "Name of label"
	, optSize = 0
	  &= name "size"
	  &= explicit
	  &= help "Size of struct"
	}
	&= summary "CmdArgs sample"

実行例のプログラム名を変更したいならprogramで指定する。

option :: Option
option = Option
	{ optLabel = "no label"
	  &= name "label"
	  &= explicit
	  &= help "Name of label"
	, optSize = 0
	  &= name "size"
	  &= explicit
	  &= help "Size of struct"
	}
	&= summary "CmdArgs sample"
	&= program "cmdargs"

という感じで、要素を付け足したりしていけばいいみたいです。

% runghc Main --help
CmdArgs sample

cmdargs [OPTIONS]

Common flags:
     --label=ITEM  Name of label
     --size=INT    Size of struct
  -? --help        Display help message
  -V --version     Print version information

あれ、ショートオプションなくなってる……。まあよくわかりません。

今のところByteStringやBoolには対応してないっぽいです。

あと気になるのは、requiredな引数を作りたい時になんか楽にやれないのかということ。
一応、Maybe Intとかの型にしておいてもIntと同じように読んでくれたりするので、requiredなオプションはMaybe値にしておいて、自分でチェックすれば良さそうです。
というかこのMaybe対応は地味にすごい気がします。さっきのアノテーションだって本当に何をやってるのかさっぱりわかりません。

でも使うのは簡単なので使いましょう。世界は広いな。

Control.Concurrent.forkIOをもっとうまくやる

Haskell

以前に、
Conduit + Attoparsec (+ Concurrent) - yunomuのブログこのあたりで
forkIOステキ！みたいなことを書いたんだと思う。

で、最近ようやくこのあたりを真面目に扱うようになり、「プロセス終了時にスレッド中断されてるじゃん！」ってことに気付いた。
この時は軽い処理してたから気付かなかったんだね。

その前にちょっと前回のコードを書き直し。

import Control.Concurrent
import qualified Control.Exception.Lifted as E
import qualified Data.ByteString.Char8 as BC
import Control.Monad.Trans.Control
import Control.Monad.IO.Class (liftIO)
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL（中略）

printList :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
    ResumableSource m ByteString -> m ()
printList src = E.handle ignore $ do
    (src1, str1) <- src $$++ takeField
    liftIO $ forkIO $ BC.putStrLn str1
    printList src1

ignore :: MonadBaseControl IO m => ParseError -> m ()
ignore _ = return ()

main :: IO ()
main = runResourceT $ do
    (src0, _) <- CB.sourceFile "index.html" $$+ CL.take 0
    printList src0

importを足したり、ハンドラの名前を変えただけ。
ついでにネットワーク通信部分を除去してファイルから読むようにした。

まあそれはいいんですけど、これのどこに問題があったかというと、forkIOのとこ。

    liftIO $ forkIO $ BC.putStrLn str1

どうもここが、一部のスレッドが実行されないまま終了してるっぽかった。もしかするとforkIOで生成されたスレッドは親プロセスが死ぬと終了を待たずにそのままいっしょに死ぬのかもしれない。
確かにスレッドが終了するまで親が待つとかそういう事はどこにも書いてないし。

ということでwait的なものが無いかどうか探してみたんですが、ちょっと見つからない。代わりにEventというのを見つけた。
Control.Concurrent.Event - hackage
ドキュメントには、Eventを使うとEventを待つことができるから並列処理をする時に使ってね、って書いてあるような気がする。

なんとなく、子プロセス終了待ちはこれを使って自分で実装しなきゃいけない気がしてきた。
いやなんかあるのかもしれないけど。
まあでもあればあったで後で入れ替えることにして、簡単そうなのでとりあえず実装してみました。

Eventの簡単な使い方

  • newでEventを生成する
  • set eventでイベントを発生させる
  • wait eventはsetされるまでブロックされる。setされると解除される

といった感じなので、
要するに、処理が終了した後に、終了したことをEventを使って通知してあげればいい。
具体的には、Eventを生成して、スレッドに渡してあげて、スレッドが終了する時にsetする。

-- なんぞ処理(proc)を実行してeventを発生させる
withEvent :: Event -> IO a -> IO ()
withEvent event proc = do
    proc
    set event

-- スレッドを生成してイベントを返す
fork :: IO () -> IO Event
fork proc = do
    event <- new
    forkIO $ withEvent event proc
    return event

-- 改良版printList forkIOがforkになっただけ
printList :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
    ResumableSource m ByteString -> m ()
printList src = E.handle ignore $ do
    (src1, str1) <- src $$++ takeField
    liftIO $ fork $ BC.putStrLn str1
    printList src1

というので流れはおおむねいいんですが、まあ見ての通りwaitしていません。

waitは、forkがEventを返すようにしていたので、そいつを使えばいい。そして今回の場合はストリームの終了はParseErrorの発生で検出していたので、いじるのはignoreです。その影響でprintListの形も少々変わります。

-- 改良版2 printList 蓄積変数が増えた
printList :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
    ResumableSource m ByteString -> m ()
printList src = printList' src []
  where
    printList' src0 es = do
        (src1, str1) <- src $$++ takeField
        e <- liftIO $ fork $ BC.putStrLn str1
        -- eventを蓄積する
        let es' = e:es
        E.handle (ignore es') $ printList' src1 es' 

-- クラス制約が増えた。引数も増えた。すべてのイベントが終了するまで待つ
ignore :: (MonadBaseControl IO m, MonadResource m)
    => [Event] -> ParseError -> m ()
ignore es _ = liftIO $ mapM_ wait es

これでignoreが実行された時に、それまでにforkされたスレッドが全て終了するようになりました。たぶん。

これでだいたいの場合はOKなんですが、さてforkに渡されたprocの中で例外が発生した場合はどうなるでしょう。
procの中でという事なので、直接影響を受けるのはwithEvent関数で、withEvent関数の実装はこうなので

withEvent :: Event -> IO a -> IO ()
withEvent event proc = do
    proc
    set event

このprocの中で例外が起きるとsetが実行されない。
setが実行されないということは、waitの部分で死にます。

というのを回避するために、procが死のうがどうしようがset eventだけは実行してもらわなければなりません。
とう時に使えるのがJavaでもおなじみのfinallyです。
withEventをfinallyで書き換えて、set eventが必ず実行されるようにします。

withEvent :: Event -> IO a -> IO a
withEvent event proc = E.finally proc $ set event

まあなんかシグネチャから変わっていますが、使い勝手はだいたい同じというか、使いやすくなってるというか、もう無くていいんじゃないかなこの関数。

このあたり設計ちょっと面倒ですけど、まじめにやれば並列処理の実行順序を自由に制御できるようになりそうな気がしますよね。
スレッドの終了待ちくらいはあってもよさそうな気もしますけどね。
でも実質的にこの程度あれば十分なのかな。

全ソースはこちらです。
exercises/http-attoparsec/Main.hs at master · yunomu/exercises · GitHub