OCamlの末尾再帰について
この記事はMLアドベントカレンダー22日目の記事です。
プロローグ
autotakerはHaskellのList.sortが遅いので嘆いていた。
あまりに遅いので簡単なコードを書いて実験することにした。
gist082402e29104b2f21a6d
$ wc test300000.in 300000 300000 2994897 test300000.in $ head test300000.in -145530267 165962464 79995549 -41622317 -133297703 38688159 191031379 -188084614 -187672271 -148432431 ./ListSort < test300000.in > test300000.out [2015-12-22 06:48:09.644106 UTC] begin [2015-12-22 06:48:09.71299 UTC] parse done [2015-12-22 06:48:10.610641 UTC] sort done [2015-12-22 06:48:10.610854 UTC] Sorting: 0.897651s [2015-12-22 06:48:10.707304 UTC] output done [2015-12-22 06:48:10.707538 UTC] Elapsed Time: 1.063198s
30万個の整数列をソートするのに900msもかかるのだ。
比較のためにC++でもソートしてみた。
gist1b7a9a6f6b9c0f446ae5
$ g++-5 -std=c++11 -O3 sort.cpp -o sort $ time ./sort < test300000.in > test300000.out Sorting: 22ms real 0m0.151s user 0m0.133s sys 0m0.010s
C++のstd::sortは爆速でわずか22msでソートが完了した。なんとHaskellのList.sortの40倍以上の速さである。これはいくらなんでも速すぎる。
調べたところstd::sortはIntro sortと呼ばれるQuick sortを少し賢くしたようなアルゴリズムで実装されている一方でList.sortはmerge sortに毛が生えたようなアルゴリズムで実装されているらしい。アルゴリズムが違うならまあ仕方ない。
ところで、標準ライブラリのソートにマージソートが採用されていてよくHaskellと比較される関数型言語があるではないか。
そうOCamlである。OCamlコンパイラはGHCに比べてそれほどアグレッシブな最適化をするわけでもないし、さすがにOCamlよりは速いだろうと予想してコードを書いてみた。
OCamlのソートのバグ?
さて、ここまでが長い前振りで、ここから今回の本題に入ろう。
まず、次のようなOCamlのコードを書いて実験してみた。
$ ocamlopt sort.ml -o sort-ml $ time ./sort-ml < test300000.in > test300000.out Sorting: 0.14416s real 0m0.874s user 0m0.393s sys 0m0.470s
全体の実行時間が遅いのは主に入出力のせいなので気にしないこととして、
OCamlのList.sortは144msであり、Haskellの6倍以上速い。
これは意外な結果だったが、念のため出力があっているかを確認したときに興味深いことがわかった。
$ diff test300000.ans test300000.out | head 2,3d1 < -214745540 < -214744494 14d11 < -214729150 18d14 < -214725140 21d16 < -214723392 37d31
なんと正しくソートできていないではないか!
この短く単純なコードのどこに私はバグを仕込んでしまったのだろう。
まずは入力を正しく読めているか確認した。
let main _ = let ps = read_ints [] in let start_t = Sys.time() in Printf.fprintf stderr "length: %d\n" (List.length ps); let qs = List.sort compare ps in let end_t = Sys.time() in Printf.fprintf stderr "Sorting: %.5fs\n" (end_t -. start_t); output_ints qs;;
./sort-ml < test300000.in > test300000.out length: 261056 Sorting: 0.14787s
どうやらバグはread_intsにあるらしい。
let rec read_ints acc = try let v = read_int() in read_ints (v::acc) with _ -> List.rev acc
このコードを書いた時の私の気持ちはこうだ。
- 入力はデカイので末尾再帰にする必要がある。アキュムレータ引数を用意しよう。
- read_intのドキュメントにはファイルの末尾に達したら、End_of_file例外が投げられるとかいてある。tryで包んで例外を捉えよう。
- 例外の名前打ち込むの面倒だし、使い捨てのコードだから_でマッチさせてもいいよね!
3つ目が私の怠慢であることは認めるが、上の二つは正しそうに思えないだろうか。
私は自身の怠慢を認め、期待する例外の名前を正しく書くことにした。
let rec read_ints acc = try let v = read_int() in read_ints (v::acc) with End_of_file -> List.rev acc
$ ocamlopt sort.ml -o sort-ml $ ./sort-ml < test300000.in > test300000.out Fatal error: exception Stack_overflow
!!!!!Fatal error: exception Stack_overflow!!!!!
読者の中にはもう気づいた人もいるだろうが、実はこのread_intsは末尾再帰になっていないのだ。
なぜかというと、read_intsにはread_ints(v::acc)を呼び出したあとに例外処理のコードがあるので、例外をキャッチした時にどのハンドラに渡すかを保存するためにスタックが必要になるためだ。
正しく末尾再帰にするためには例外をoption型に変換してやらないといけない。
let rec read_ints acc = let r = try Some (read_int()) with End_of_file -> None in match r with Some(v) -> read_ints (v::acc) | None -> List.rev acc
このコードは多少不恰好だが、定数サイズのスタックしか消費しない。
gist764a6d75741e2f807bc5
$ ocamlopt sort1.ml -o sort1-ml $ time ./sort1-ml < test300000.in > test300000.out length: 300000 Sorting: 0.18463s real 0m0.972s user 0m0.436s sys 0m0.530s $ diff test300000.out test300000.ans
こうしてバグは修正された。めでたしめでたし。
後日談というか、今回のオチ
こうしてOCamlコードのバグは直ったわけだが、実験の結果、OCamlのList.sortは184msであり、やはりHaskellのList.sortがクソ遅いのはアルゴリズムのせいではなく、実装が悪いのだと考えられる。
競技Haskellerとしてこんな状況は許されないのでメモリ効率が悪いListの代わりにVectorを使ってマージソートを実装した。
gistdb303c4aae8e1ce9776b
$ ghc -O2 VecSort.hs [1 of 1] Compiling Main ( VecSort.hs, VecSort.o ) Linking VecSort ... $ ./VecSort < test300000.in > test300000.out [2015-12-22 07:58:53.725504 UTC] begin [2015-12-22 07:58:53.805494 UTC] parse done [2015-12-22 07:58:54.00343 UTC] sort done [2015-12-22 07:58:54.003704 UTC] Sorting: 0.197936s [2015-12-22 07:58:54.092547 UTC] output done [2015-12-22 07:58:54.092758 UTC] Elapsed Time: 0.367043s
このように198msと、OCamlと大差ない時間になった。
SECCON 2015 Qual Writeup Crypto 200 Find the prime numbers
問題
つなぐと
2622440554406490912 + 0147433867683690946 = 4258610457570922687
などと表示される。数字は3秒おきに更新される。
解法
もらったソースを読む。
while 1: x = pow(random.randint(1000000000, 9999999999), n, (n * n)) o = (pow(n + 1, 1, n * n) * x) % (n * n) y = (((pow(o, l, n * n) - 1) // n) * d) % n if y == 1: break c = (pow(n + 1, int(v["num"]), n * n) * x) % (n * n) h = (c * o) % (n * n) q = "%019d + %019d = %019d" % (c, o, h) print q z = "QUERY_STRING" if z in os.environ and os.environ[z] != "": if w[e]["time"] < t and os.environ[z] == v["num"]: print "SECCON{" + v["flag"] + "}" w[e]["time"] = t + 60 w[e]["outp"] = q else: w[e]["time"] = t + 3 w[e]["outp"] = q
何をやっているのかはよくわからないが、v["num"]を当てれば良いらしい。
まず、nを当てたい。表示しているのはよく読むと
という等式のようだ。どう考えても、左辺+記号は*の間違いだろう。
つまり
となる、があたえられるわけだ。
ここから
つまり、を素因数分解すればの約数(素数p,q)が得られる。
たかだか36桁程度なのでmsieveを使って解ける(べつにためし割りでも大丈夫だろう)
$ msieve -v 386636553706711704268844486594760065 factoring 386636553706711704268844486594760065 (36 digits) p1 factor: 5 p1 factor: 7 p2 factor: 11 p5 factor: 42727 p5 factor: 42727 p5 factor: 58757 p5 factor: 58757 prp15 factor: 159337556575289
よって、が得られた。
次に、
のを復元したい。これも簡単で、と求められる。
最後に
からと求められる。
離散対数はPARI/GPを用いた。
? znlog(3792102298388437469,Mod(2510510340, 6302662162225894921)) %1 = 1510490612
が求まったのでサーバに送れば良い。
FLAG: SECCON{SECCoooo_oooOooo_ooooooooN}
たぶん、想定解ではないが、いずれにせよ桁が小さすぎるのでどうやっても解けるとおもう。
SECCON 2015 Qualに参加しました。
チームnegainoidoで参加しました。
チームメンバーはautotaker, atetubou, cympfh, garasubo, isurugieri, tailedだった。
atetubouとtailedは台湾旅行(ICPCのアジア地区予選)中だったので遠隔参加でした。
コンテスト開始時
開始直後にatetubouがStart SECCON CTFを通した。
2015-12-05 15:02:16: negainoido: 50 (+50), Start SECCON CTF
SECCON Warsはやることははっきりしていたのでgarasuboに取り組んでもらった。
16時
2015-12-05 15:58:23: negainoido: 150 (+100), Reverse-Engineering Android APK 1
by autotaker
2015-12-05 16:03:40: negainoido: 250 (+100), Command-Line Quiz
by atetubou
2015-12-05 16:21:37: negainoido: 350 (+100), SECCON WARS 2015
by garasubo
コンテストサーバがおもくなりフラグを送信できなかったり、問題が見られなかったりでイライラしていた。
17時
2015-12-05 17:03:16: negainoido: 450 (+100), Connect the server
by tailed, autotaker
2015-12-05 17:45:33: negainoido: 750 (+300), Decrypt it
by atetubou
台湾でICPCの準備中とは思えないatetubouとtailedの仕事の早さに驚かされた。
本戦に行けることになったときに、チーム内で選抜をするという脅しをかけたのが良かったのかもしれない。
atetubouにunzipが既知平文攻撃ではないかと教えてもらい、cympfhが手元でpkcrackを走らせ始めた。
Entry formについてtailed, autotaker, cympfhでいろいろと試す。
18時
2015-12-05 18:39:55: negainoido: 850 (+100), Entry form
by tailed, cympfh, autotaker
Entry formの問題でtailedがブラインドOSインジェクションで/SECRETS/以下を読む。
atetubouとtailedが移動でafkしている間にbackdoor123.phpを発見して解いた。
garasuboが帰宅。
19時
isurugieriがCodeThanksFestivalから帰ってきて参加。
晩御飯を食べる。
20時
22時
2015-12-05 22:00:29: negainoido: 1150 (+200), Find the prime numbers
by autotaker, tailed
2015-12-05 22:06:51: negainoido: 1450 (+300), Exec dmesg
by tailed
23時
24時
深夜
みんな自宅に帰った。TreeWalkerは解法が見えてしまったので、睡魔と闘いながらautotakerが解析した。
2015-12-06 06:18:30: negainoido: 2350 (+200), FSB: TreeWalker
by autotaker
明らかに時間かけすぎだった。寝るべきだった。
翌朝8時
2015-12-06 08:45:12: negainoido: 2400 (+50), Last Challenge (Thank you for playing)
by atetubou?
午前中
2015-12-06 10:24:50: negainoido: 3000 (+200), Fragment2
by autotaker
2015-12-06 11:09:12: negainoido: 3100 (+100), 4042
by autotaker, garasubo, isurugieri, tailed
少し寝たら神託が降りてきてあっさり解けた。神に感謝したい。
コンテスト終了まで
この時点で方針の立っている問題がなくなってしまったので、autotaker, cympfh, garasuboの3人でHardware1を解きに行くことにした。LEDの配置さえわかればなんとかなるかと思っていたが、大量のトランジスタがあることに気づき、自分たちの無力を悟った。
結果
3100pts 26位だった。
去年は3人で2000点くらいだったのでまあまあよくできたと思う。
日本人チームで9位なので学生枠で決勝に行けそう?
またatetubouとtailed(とflowlight氏)が参加していたICPCの方もなかなか良い結果だったようだ。
Template HaskellでJSONデコーダの導出
概要
最近、CodeRunnerというAIコンテストの予選BでJSONデータをいじる必要が出てきたのでHaskellでJSONを読めるようにAesonを触ってみた。さらにTemplateHaskellを用いてレコード型の定義からJSONデコーダを自動導出できるようにしてみた。
背景
予選Bの問題は以下のリンクから閲覧できる。coderunner.jp
問題自体も面白いが、今回興味があるのはAPIで渡されるJSONデータである。
そのJSONは以下のような仕様になっている。
- power: 現在の攻撃力
- damage: 今までに与えた合計ダメージ
- hp: 一番前の敵の体力
- maxhp: 一番前の敵の初期体力
- hps: 後ろにいる敵の体力の配列(戦う順に並んでいて最後に戦う敵が一番最後になる)
- friend: 同じ部屋にいる自分以外のユーザーの配列(id昇順)
- id: ユーザーID
- power: そのユーザーの現在の攻撃力
- damage: そのユーザーの今までに与えた合計ダメージ
- log: イベントの配列(イベントは情報取得APIを前回リクエストしてから今回リクエストした間に起きたもののみを差分として表示する)
- id: 攻撃したユーザーのユーザーID
- enemy: 攻撃された敵のID(一番前の敵を含む残り敵数に等しい)
- time: ためた時間[ミリ秒表記]
- hp: 攻撃される前の敵の体力
このような構造はHaskellのレコード型を用いて自然に書くことができる。フィールド名にアンダースコアをつけているのは後でLensを使いたいからだ。
module Info where data GameInfo = GameInfo { _myPower :: Int , _myDamage :: Int , _curHp :: Int , _maxHp :: Int , _hps :: [Int] , _friends :: [Friend] , _logs :: [Log] } deriving Show data Friend = Friend { _friendId :: String , _friendPower :: Int , _friendDamage :: Int } deriving Show data Log = Log { _userId :: String , _enemyId :: Int , _time :: Int , _hp :: Int } deriving Show
ここで問題となるのがフィールド名の衝突である。
例えばAPIの仕様では"id"というフィールド名はfriendの配列の中とlogの配列の中の両方で使われている。Haskellでは同じフィールド名を異なるレコード型に用いるためには別のファイルに記述しなければならず面倒である。同じファイルに定義する場合にはプリフィックスをつけるなどして適当に名前を変更しなければならない。
JSONのパーズ
JSONデータのパーズにはAesonというライブラリを使う。
aeson: Fast JSON parsing and encoding | Hackage
ライブラリに
decode :: FromJSON a => ByteString -> Maybe a
という関数があるので、GameInfo, Friend, LogのそれぞれをFromJSONのインスタンスにしてやれば良い。
{-# LANGUAGE OverloadedStrings #-} import Data.Aeson import Data.Aeson.Types instance FromJSON Log where parseJSON (Object v) = Log <$> v .: "id" <*> v .: "enemy" <*> v .: "time" <*> v .: "hp" parseJSON invalid = typeMismatch "Log" invalid instance FromJSON Friend where parseJSON (Object v) = Friend <$> v .: "id" <*> v .: "power" <*> v .: "damage" parseJSON invalid = typeMismatch "Friend" invalid instance FromJSON GameInfo where parseJSON (Object v) = GameInfo <$> v .: "power" <*> v .: "damage" <*> v .: "hp" <*> v .: "maxhp" <*> v .: "hps" <*> v .: "friend" <*> v .: "log" parseJSON invalid = typeMismatch "GameInfo" invalid
簡単だし、typeMismatchとかいう関数を呼べばエラーメッセージもいい感じに出してくれる。
実際にパーズするのはこんな感じでできる。
import qualified Data.ByteString.Lazy as B import Data.Aeson(eitherDecode) import Text.Printf testAeson :: FilePath -> (GameInfo -> IO ()) -> IO () testAeson path cont = do putStrLn $ "Case: " ++ path s <- B.readFile path case eitherDecode s of Left err -> putStrLn err Right info -> cont info main = testAeson "sample.json" print
$ cat sample.json {"power":2604996,"damage":40599634,"hp":13879712,"maxhp":39050001,"hps":[10857025,17480761,27899524],"friend":[{"id":"PlayerB","power":1542564,"damage":72452052},{"id":"PlayerC","power":1522756,"damage":52232156}],"log":[{"id":"PlayerC","enemy":4,"time":5017,"hp":39050001},{"id":"PlayerB","enemy":5,"time":5017,"hp":25158831},{"id":"PlayerA","enemy":5,"time":4265,"hp":43349056}]} $ cat sample-e.json {"power":2604996,"damage":40599634,"hp":13879712,"maxhp":39050001,"hps":[10857],"friend":[],"log":[0]} $ ghci InfoTest.hs GHCi, version 7.10.2: http://www.haskell.org/ghc/ :? for help [1 of 2] Compiling Info ( Info.hs, interpreted ) [2 of 2] Compiling Main ( InfoTest.hs, interpreted ) Ok, modules loaded: Info, Main. *Main> testAeson "sample.json" print Case: sample.json GameInfo {_myPower = 2604996, _myDamage = 40599634, _curHp = 13879712, _maxHp = 39050001, _hps = [10857025,17480761,27899524], _friends = [Friend {_friendId = "PlayerB", _friendPower = 1542564, _friendDamage = 72452052},Friend {_friendId = "PlayerC", _friendPower = 1522756, _friendDamage = 52232156}], _logs = [Log {_userId = "PlayerC", _enemyId = 4, _time = 5017, _hp = 39050001},Log {_userId = "PlayerB", _enemyId = 5, _time = 5017, _hp = 25158831},Log {_userId = "PlayerA", _enemyId = 5, _time = 4265, _hp = 43349056}]} *Main> testAeson "sample-e.json" print Case: sample-e.json Error in $.log[0]: failed to parse field log: expected Log, encountered Number
Template Haskellで自動導出
上のインスタンス宣言はレコード型のフィールド名とJSONオブジェクトのレコード名の対応関係さえ与えてやれば自動導出できそうなのでやってみた。
一応aesonのライブラリ自体にもGenericを用いた自動導出とTemplateHaskellを用いた自動導出があるのだが、それらはHaskellのデータ型をイイ感じのJSONにするのには向いていても、すでにあるJSON型をデコードするのにはあまり向いていないように見えた。
自動導出器はTemplate.hsに実装した。
使い方はこんな感じである。
{-# LANGUAGE TemplateHaskell #-} module Info where import Template data Log = Log { _userId :: String , _enemyId :: Int , _time :: Int , _hp :: Int } deriving Show data Friend = Friend { _friendId :: String , _friendPower :: Int , _friendDamage :: Int } deriving Show data GameInfo = GameInfo { _myPower :: Int , _myDamage :: Int , _curHp :: Int , _maxHp :: Int , _hps :: [Int] , _friends :: [Friend] , _logs :: [Log] } deriving Show mkFromJSON ''Log [ ('_userId, "id") , ('_enemyId, "enemy") , ('_time, "time") , ('_hp, "hp") ] mkFromJSON ''Friend [ ('_friendId, "id") , ('_friendPower, "power") , ('_friendDamage, "damage") ] mkFromJSON ''GameInfo [ ('_myPower, "power") , ('_myDamage, "damage") , ('_curHp, "hp") , ('_maxHp, "maxhp") , ('_hps, "hps") , ('_friends, "friend") , ('_logs, "log") ]
mkFromJSONというマクロがFromJSONのインスタンスを自動導出してくれる。第一引数には導出したい型の名前、第二引数にはフィールド名の対応関係を記したリストを渡せば良い。一応簡単なエラーハンドリングもしているのでフィールド名の漏れ等も検出して教えてくれるようになっている。
Template.hsの実装はこんな感じ。TemplateHaskell触ったのは初めてだったのでチュートリアル等を見ながらなんとなく実装した。QuasiQuote使いつつやればそんなに難しくもなかった。
これらのサイトが参考になった。
できる!Template Haskell (完) - はてな使ったら負けだと思っている deriving Haskell - haskell
Language.Haskell.TH.Syntax
{-# LANGUAGE TemplateHaskell #-} module Template(mkFromJSON) where import Language.Haskell.TH import Data.Aeson import Data.Aeson.Types import qualified Data.Text as Text import Control.Monad validateInfo :: Name -> [(Name,String)] -> Q Name validateInfo name fieldmap = do info <- reify name dec <- case info of TyConI dec -> return dec _ -> fail $ nameBase name ++ " must be a type constructor" cons <- case dec of DataD _ _ _ cons _ -> return cons _ -> fail $ nameBase name ++ " must be a data type" cnstr <- case cons of [cnstr] -> return cnstr _ -> fail $ nameBase name ++ " must have only one constructor" (cname,fields) <- case cnstr of RecC cname fields -> return (cname,map (\(x,_,_) -> x) fields) _ -> fail $ nameBase name ++ " must be a record type" mapM_ (\(field,_) -> unless (field `elem` fields) $ fail $ "invalid field name" ++ nameBase field) fieldmap mapM_ (\field -> unless (field `elem` map fst fieldmap) $ fail $ "corresponding JSON field of the field " ++ nameBase field ++ " is not found") fields return cname mkFromJSON :: Name -> [(Name,String)] -> Q [Dec] mkFromJSON name fieldmap = do cnstr <- validateInfo name fieldmap vars <- mapM (\y -> (,) y <$> newName "x") fieldmap v <- newName "v" let invalid = [| typeMismatch $(stringE $ nameBase name) $(varE v) |] -- body = do -- x1 <- v .: JSONfield1 -- x2 <- v .: JSONfield2 -- ... -- xn <- v .: JSONfieldn -- return $ $cnstr{ field1 = x1, ... fieldn = xn } body = doE (stmts ++ ret) stmts = [ bindS (varP tvar) [| $(varE v) .: Text.pack $(stringE jsonfield)|] | ((_,jsonfield),tvar) <- vars ] ret = [ noBindS (appE (varE 'return) (recConE cnstr fieldDefs)) ] fieldDefs = [ return (field, VarE tvar) | ((field,_),tvar) <- vars ] [d| instance FromJSON $(conT name) where parseJSON (Object $(varP v)) = $body parseJSON $(varP v) = $invalid |]
終わりに
実装自体は出来たが、これでコードが短くなったかと言われれば微妙だ。
使う側にOverloadedStringsとかの拡張とかライブラリのインポートをしなくても良いのが便利かもしれない。
GADTを用いた型安全なCPS変換の実装
概要
CPS変換とはラムダ項と継続を入力として型Xを持つラムダ項を出力するプログラム変換である。
HaskellのGADTという機能を使うと型Tを持つラムダ項を表すデータ型Term Tを定義できる。
CPS変換が正しいことは
cps :: Term T -> Term ([T] -> X) -> Term Xという型がつくことで表現される。
(ここで[T]は型TをCPS変換した型)
GADTは表現力の高いDSLであるが、parse :: String -> Maybe (Term T)のような関数を書くことはできないため、標準入力からラムダ項を受け取りcps関数に渡すためには少し工夫がいる。
今回はtypeCheck :: Term' -> A -> (forall T. Term T -> A) -> A
という関数を実装することでこの問題を解決した。
実装は以下で公開されている。github.com
とてもとても簡単な解説
CPS変換の実装はSyntax.hsで、パーズした入力をGADTのラムダ項を生成する部分は
TypeCheck.hsにある。詳細は実装を読んでほしい。後日解説を書くかもしれない。
実行例はこんな感じ
$ ./cpstransformer \(x::o) -> x Parsed: \(x :: o) -> x TypeCheck : OK CPS : (\(x :: o -> (o -> o) -> o) -> end) (\(x :: o) -> \(k :: o -> o) -> k x) \(a :: o) -> (\(x :: o -> o) -> x a) (\(b :: o) -> b) Parsed: \(a :: o) -> (\(x :: o -> o) -> x a) (\(b :: o) -> b) TypeCheck : OK CPS : (\(x :: o -> (o -> o) -> o) -> end) (\(a :: o) -> \(k :: o -> o) -> (\(f :: (o -> (o -> o) -> o) -> (o -> o) -> o) -> (\(x :: o -> (o -> o) -> o) -> f x k) (\(b :: o) -> \(k :: o -> o) -> k b)) (\(x :: o -> (o -> o) -> o) -> \(k :: o -> o) -> (\(f :: o -> (o -> o) -> o) -> (\(x :: o) -> f x k) a) x)) \(x :: o -> o) -> x x Parsed: \(x :: o -> o) -> x x TypeCheck : failed
参考文献
今回実装したCPS変換は次のサイトを参考にしている。
How to compile with continuations
構文木にIdを振りたい。
構文木に情報を追加したいときにFix使うとちょっと楽だよっていう話。
例えば
data Term = Var String | Lam String Term | App Term Term
みたいなデータの各ノードにIdを振りたいとする。
ナイーブにやると
data ITerm = IVar Int String | ILam Int String ITerm | IApp Int ITerm ITerm
こんな感じになるだろうか。
コンストラクタの名前が変わって冗長だ。
これに対してFixを使うとこうなる。
newtype Fix f = In (f (Fix f)) data TermF a = Var String | Lam String a | App a a newtype ITermF a = ITermF (Int, TermF a) newtype Term = Term (Fix TermF) newtype ITerm = ITerm (Fix ITermF)
これなら他に型情報とかを追加したくなってもnewtypeで簡単に追加できる。
Idを振るサンプルは以下のとおり。
cata :: Functor f => (f a -> a) -> Fix f -> a cata f (In t) = f (fmap (cata f) t) incr :: State Int Int incr = do i <- get put $! i + 1 return i assignId :: Term -> State Int ITerm assignId (Term _t) = ITerm <$> cata f _t where f (Var s) = c $ pure $ Var s f (App t1 t2) = c $ App <$> t1 <*> t2 f (Lam x t) = c $ Lam x <$> t c t = In . ITermF <$> ((,) <$> incr <*> t)
newtype同士のキャストがだいぶ煩雑になってしまうのが玉に瑕だ。
詳細なコードは以下のgistにある。
gist0b9f189fd5cf0550903e
let式の構文解析
導入
<digit> ::= [0-9] <alphabet> ::= [a-zA-Z] <int> ::= <digit> | <digit><int> <id> ::= <alphabet> | <id> <expr> ::= <int> | <id> | '(' <expr> ')' | "let" <id> '=' <expr> "in" <expr> | <expr> '+' <expr>
さて、この文法には2つの曖昧性がある。一つは足し算の結合性、もう一つはlet式と足し算の優先順位の曖昧性だ。
1 + 2 + 3 => (+ (+ 1 2) 3) | (+ 1 (+ 2 3)) let x = 1 in 2 + 3 => (let (x 1) (+ 2 3)) | (+ (let (x 1) 2) 3)
ここでは曖昧性を解決するために足し算は左結合とし、足し算がlet式に優先するとしたい。
そのような文法はPEG*2で以下のように表現できる。
INT <- [0-9]+ ID <- [a-zA-Z]+ P <- INT / ID / '(' E ')' / "let" ID '=' E "in" E E <- E ('+' P)*
今回の記事ではこのような文法を曖昧性のない文脈自由文法で定義してみる。
最初の試み
自然に考えられる文法として以下のようなものがある。
<prim> ::= <int> | <id> | '(' <expr> ')' <term> ::= <prim> | <term> '+' <prim> <expr> ::= <term> | "let" <id> '=' <expr> "in" <expr>
この文法は上の二つの例を正しくパーズする。
1 + 2 + 3 => (+ (+ 1 2) 3) let x = 1 in 2 + 3 => (let (x 1) (+ 2 3))
しかし、この文法は期待する言語を表現していない。例えば次のような式をパーズできない。
1 + let x = 1 in x => Error!
次の試み
上の例からprimがlet式を含まなければならないということがわかった。
しかしprim '+' exprとなっている場合はprimがlet式を含んでいてはならない。
つまり、足し算の第2オペランドにlet式が出現できるかどうかを区別する必要が有る。
<atom> ::= <int> | <id> | '(' <expr> ')' <prim> ::= <atom> | "let" <id> '=' <expr> "in" <expr> <term> ::= <atom> | <term> '+' <atom> <expr> ::= <prim> | <term> '+' <prim>
この文法は期待する言語を表現する。
1 + let x = 1 in x => (+ 1 (let (x 1) x)) 1 + let x = 1 in 1 + 2 => (+ 1 (let (x 1) (+ 1 2))) 1 + (let x = 1 in x) + 3 => (+ (+ 1 (let (x 1) x)) 3)
yaccによる動作確認
この文法に曖昧性がないことを確かめるためにyaccに書き下す。
Parsing
yaccがconflictを出さなかったのでこの文法は曖昧でない。
ちなみに動作例。
$ ocamlbuild main.native $ ./main.native 1 + let x = 1 in x + x Plus(1, Let(x, 1, Plus(x, x))) 1 + 2 + 3 Plus(Plus(1, 2), 3) 1 + (2 + 3) Plus(1, Plus(2, 3)) (let x = 1 in let y = 2 in x + y) + 3 Plus(Let(x, 1, Let(y, 2, Plus(x, y))), 3)
yaccのPrecedenceについて
上のようなパーサはyaccのPrecedenceを適切に設定することによっても得ることができる。
gist114a58bce2ab6af47926
このPrecedenceがどう働くかは
http://dinosaur.compilertools.net/yacc/
に記述がある。
The precedences and associativities are used by Yacc to resolve parsing conflicts; they give rise to disambiguating rules. Formally, the rules work as follows:
1. The precedences and associativities are recorded for those tokens and literals that have them.
2. A precedence and associativity is associated with each grammar rule; it is the precedence and associativity of the last token or literal in the body of the rule. If the %prec construction is used, it overrides this default. Some grammar rules may have no precedence and associativity associated with them.
3. When there is a reduce/reduce conflict, or there is a shift/reduce conflict and either the input symbol or the grammar rule has no precedence and associativity, then the two disambiguating rules given at the beginning of the section are used, and the conflicts are reported.
4. If there is a shift/reduce conflict, and both the grammar rule and the input character have precedence and associativity associated with them, then the conflict is resolved in favor of the action (shift or reduce) associated with the higher precedence. If the precedences are the same, then the associativity is used; left associative implies reduce, right associative implies shift, and nonassociating implies error.
要約すると、各ruleの一番最後に現れるtokenのprecedenceをそのruleのprecedenceとし、パーサを構成する過程でconflictが起こったところでprecedenceの高いruleを選択するという仕組みのようだ。
どうにもad-hocに思えてならないのだが、上手くいく裏付けが何かあるのだろうか。