IArrayの怠け度合い

今日はちょっとしたメモ…

リストのレイジーな振舞い方は割りとはっきりとイメージできるのですが、ちょっと遊びでIArrayを使っていて遅延評価がどういった形で動いているのかが気になったので、ちょっと実験してみました。

IArray、つまりImmutableなArrayを作る方法はいくつかあるのですが、基本は配列に変換したいデータをリストとして渡す形になります。僕が気になったのは、リストはいつどどういった形で評価されるのかということですね…たとえば、

getContents :: IO String

などは、unsafeを使ってそれぞれの文字が必要になったときにIOを行うようになっています。getContentsで取得した文字列を配列に変換するとして、ファイルIOはいったいどの時点で起きるのでしょう？

ということで書いてみた実験コードはこんな感じ:

module Main where

import Data.Array.IArray
import Debug.Trace

data SqueakyList a = Sq a (SqueakyList a) | Nil

toSql :: [a] -> SqueakyList a
toSql [ ] = Nil
toSql (a:as) = Sq a $ toSql as

toLst :: SqueakyList a -> [a]
toLst Nil = [ ]
toLst (Sq a as) = trace "list" $ a : (toLst as)

squeak a = trace ("element" ++ (show a) ) a

str = "test"
strSq = map (squeak) str

print3rd :: Array Int Char -> IO ()
print3rd ar = trace "!2" $ print (ar ! 2)

ar :: Array Int Char
ar = arit $ toLst $ toSql $ map (squeak) str

arit :: [a] -> Array Int a
arit as = listArray (0, 3) as

main = do
	putStrLn "Test1"
	print3rd $ arit $ toLst $ toSql strSq
	putStrLn "Test2"
	print3rd $ arit $ toLst $ toSql strSq
	putStrLn "Test3"
	print $ take 2 $ assocs ar
	putStrLn "Test4"
	print $ assocs $ ar

リストの各要素が展開されていくのを見るためにSqueakyListという型を定義しました。これはリストの要素が展開されるたびにトレースを出すようになってます。ここはもっとシンプルなやり方もありそうですね…

そして、このコードの出力はこうなりました:

Test1
!2
list
list
list
list
element's'
's'
Test2
!2
list
list
list
list
's'
Test3
list
list
list
list
element't'
element'e'
[(0,'t'),(1,'e')]
Test4
element's'
element't'
[(0,'t'),(1,'e'),(2,'s'),(3,'t')]

さて、何がわかったかというと:
１．配列の生成に渡したリストは配列の要素への最初のアクセスが起きた時点で配列の生成に使われる部分はすべて展開される。ということで、getContentsの結果をそのまま配列の生成に使うと、必要なIOはすべて配列の要素に始めてアクセスする時点で起きるようです。これはTest1のトレースが!2の後にlistが４回立て続けに起きていることでわかりますね…

さらに、ほかにもわかったことがあります。
２．どうやらリストの各要素に格納されている値もボックス型になっているようで、値が評価されるのはどうやら配列の中のその要素がアクセスされた時点のようです。Test1では３文字目の's'を取り出すのにelementトレースが一つ出てますね…でも、Test2のほうではメモ化が効いているようでelementトレースが出ていません。ということで、メモ化はstrSqの内部で起きているということがいえそうですね。

３．さらにTest3とTest4を見てもメモ化の作用が見て取れますね。

ちなみにリストは今回のSqueakyListでもわかるようにHaskellの言語の範疇でで簡単に作ることができるのですが、配列のほうはどうもそうはいかないようですね。IArrayのコードをたどっていくと最終的にはコンパイラなのか、ランタイムなのかわかんないんですが、unsafeな配列生成内部関数が呼び出されているのがわかります。リンクリストよりも配列のほうがインプリメントが難しい言語というのも面白いですね…

きょうはこのへんで。
ではでは。

Programming Windows in Haskell、次の一歩。

もうかれこれ半年以上前のポストの続きになるんですが、なんというか、HaskellでWin32を直にたたくスタイルでGUIアプリを書いてみたわけなんですが、前回挫折したのは、ウィンドウごとのステートをどうやって保持するかというところだったわけです。IORefを作ってその中にステートを書き込んだり読み出したりする方法をHaskellCafeなどでも見かけたりしたのですが、個人的にはなんともしっくり来ていなかったわけです。

先日久しぶりにこの辺のことをごにょごにょといじくってみる気になったので、コードをさわっていたわけです。HaskellでWin32アプリを書いたとき一番最初に僕が試したのはウィンドウのステートをShowしてSetWindowText/GetWindowText経由で保存するという技でした。これをやったときはまだIORefなんていうものも知らず、とにかく何か動かしたいと思ってやったことでした…

そして、次に出てきたのがIORef,Win32の常套手段ではSetWindowLong/GetWindowLongとかあるわけなんですが、なんか、やる気をそそられるものがなかったんですね…

今回、久々に気がむいて手を出してみたのはメッセージポンプの再帰呼び出しを利用して、変化するステートを維持するというモデルでした。スケッチとしては:

pump st = do
	(st', _) <- wndProc st
	pump st'
	
wndProc :: ST->HWND->MSG->WPARAM->LPARAM->
　IO(ST,LRESULT)

なんてものを夢見ていたわけです。でも、無理やり動かしてみると、これはもうWin32のプログラミングのルールを破りまくりで、いろんな形でおかしな動きをしてしまうわけです。

しかし、これをやって気づいたのは、ウィンドウプロシジャにひとつパラメタを追加してやったことで、そのウィンドウに独自の情報をCreateWindowじかに渡すことができることです。あとは、これがうまく変化させられれば良いわけなんです…
ぼーっとGraphics.Win32.Window.createWindowのコードを眺めていると、なぜか、このインプリメンテーションはAPIにユーザー指定のウィンドウプロシジャを渡さずに、その直後にsetWindowClosureという関数でウィンドウプロシジャを指定しています…不思議ですね…

setWindowClosureって、Haskellの関数をWin32のコールバック関数として登録できるのねーとおもって眺めていたら、ちょっと思いついちゃったわけです。といっても、そんな大それたことではないんですけど。

それはつまり、ウィンドウプロシジャ内でウィンドウのステートが変わるたんびに
　　setWindowClosure wndProc st'
とやってやれば、そのウィンドウの状態をうまく管理できそうだということです。

それでやってみたのがこんなのです:

module Main
	where

import System.Win32.Types
import System.Win32.DLL
import Graphics.Win32
import Graphics.Win32.Misc
import Graphics.Win32.GDI.Types 
import Graphics.Win32.Message
import Graphics.Win32.Window
import Data.List (unfoldr)
import Data.Int (Int32)
import Data.Maybe
import Control.Monad
import Control.Arrow

foreign import stdcall "PostQuitMessage" 
　　　postQuitMessage :: Int32 -> IO ()


type Vector = [Float]
type Matrix = [ [Float] ]

transform :: Matrix -> Vector -> Vector
transform mx v = [ (mul r) v| r <- mx]
　where
　　mul rs cs = sum $ zipWith ( * ) rs cs

mxRotXZ :: Float -> Matrix
mxRotXZ rot = [ [cos rot, 0, -1 * (sin rot) ],
　 [0,       1,             0 ],
　[sin rot, 0,       cos rot ] ]

proj :: Vector -> Vector
proj v@(x: y: z: [ ]) = [x * fac, y * fac]
　where
　　fac = (z - zvp) / (zvf - zvp)
　　zvp = -4 :: Float
　　zvf = -1 :: Float

cube :: [Vector]
cube = 	[ [1,  1,  1], [1, -1,  1], [-1, -1,  1], [-1,  1,  1],
　　[1,  1, -1], [1, -1, -1], [-1, -1, -1], [-1,  1, -1],
　　[1,  1,  1], [1,  1, -1], [-1,  1, -1], [-1,  1,  1],
　　[1, -1,  1], [1, -1, -1], [-1, -1, -1], [-1, -1,  1] ]

toMaybe :: Bool -> a -> Maybe a
toMaybe p a
　| p = Just a
　| otherwise = Nothing

varMap :: ( [a] -> (b, [a] ) ) -> [a] -> [b]
varMap f a = unfoldr (uncurry toMaybe . (not.null &&& f) ) a

main = do
　let clsName 	=  mkClassName "My Window Class"
　hinst 		<- getModuleHandle Nothing
　whiteBrush	<- getStockBrush wHITE_BRUSH
　curArrow	<- loadCursor Nothing iDC_ARROW
　mAtom 		<- registerClass
　　(cS_DBLCLKS, 
　　hinst,		-- HINSTANCE
　　Nothing,	-- Maybe HICON
　　Just curArrow,	-- Maybe HCURSOR
　　Just whiteBrush,-- Maybe HBRUSH
　　Nothing,	-- Maybe LPCTSTR
　　clsName)

　when (isJust mAtom) $ do
　　hwnd <- createWindow 
　　　clsName
　　　"Rotating Box Demo" 
　　　(wS_THICKFRAME + wS_CAPTION + wS_SYSMENU) 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　Nothing 
　　　hinst
　　　(wndProc 0)

　　setWinTimer hwnd 0{-tid-} 50{-msec-}

　　showWindow hwnd sW_SHOWNORMAL
　　updateWindow hwnd
　　allocaMessage $ pump

　　unregisterClass clsName hinst

pump lpmsg = do
　fContinue <- getMessage lpmsg Nothing
　when fContinue $ do
　　translateMessage lpmsg
　　dispatchMessage lpmsg
　　pump lpmsg

drawBox4 :: HDC -> [ [Int32] ] -> IO ()
drawBox4 hdc [ [x1, y1], [x2, y2], [x3, y3], [x4, y4] ] = do
　moveToEx hdc x1 y1
　lineTo   hdc x2 y2
　lineTo   hdc x3 y3
　lineTo   hdc x4 y4
　lineTo   hdc x1 y1

drawCube :: HDC -> Matrix -> IO ()
drawCube hdc rot = mapM_ (drawBox4 hdc) $ 
　varMap (splitAt 4) $ 
　map ( 
　　(map $ ( + 400).round.( * 100) ) . proj . transform rot)
　　cube

render :: HWND -> HDC -> Int -> IO ()
render hwnd hdc i  = (drawCube hdc . rot . fromIntegral) i
　where
　　rot :: Float -> Matrix
　　rot x = mxRotXZ $ (pi * x/ 180) 

onTimer :: HWND -> Int -> IO ()
onTimer hwnd i = do
　　invalidateRect (Just hwnd) Nothing True
　　setWindowClosure hwnd (wndProc $ (i + 2) `mod` 360) 

wndProc :: Int -> HWND -> WindowMessage -> WPARAM -> 
　　LPARAM -> IO LRESULT
wndProc i hwnd wm wp lp
　　| wm == wM_KEYDOWN 	= doFinish
　　| wm == wM_LBUTTONDOWN 	= doFinish
　　| wm == wM_DESTROY 	= killTimer (Just hwnd) 0 >> 
　　　　　　　　　　　　　　　postQuitMessage 0 >> return 0
　　| wm == wM_SIZE	= doInvalRender
　　| wm == wM_PAINT   	= onPaint
　　| wm == wM_TIMER	= onTimer hwnd i >> return 0
　　| otherwise 	   = defWindowProc (Just hwnd) wm wp lp
　　where
　　　　doFinish　= sendMessage hwnd wM_CLOSE 1 0 >> return 0
　　　　doInvalRender　= do
　　　　　　　　　invalidateRect (Just hwnd) Nothing True
　　　　　　　　　return 0
　　　　onPaint 	= allocaPAINTSTRUCT $ \ lpps -> do
　　　　　hdc <- beginPaint hwnd lpps
　　　　　render hwnd hdc i
　　　　　endPaint hwnd lpps
　　　　　return 0

昔、Doukakuのお題にあわせてやった簡易３Dアプリなんですが、今回の肝の部分は
wndProcの第一パラメタが（簡単すぎるという話はありますが）ウィンドウの状態を保持しているパラメタ、（回転する箱の角度）そしてそのパラメタがonTimerの中でsetWindowClosureでアップデートされています。

カリー化を使ってステートを管理できるとはなんともHaskellらしくていいかなと思ったわけです。よけいなIORefもいらないし…

ではでは。

PEGパーサーのバックトラッキング

前回、どちゃっと乗せたPEG電卓のコードなんですが、これはPappyやFrisbyのようにメモ化をまったくやっていないPEGパーサーです。ちょっと思いついて、いったいどれくらいの勢いでバックトラッキングが起きているのかを調べてみました。
バックトラッキングがたくさん起きているということはメモ化がそれだけ動作効率に影響しやすいという事になりますよね…

あれだけでかいコードでも、実際に文字をマッチしている関数は二つだけです。そこで、その２つの関数にDebug.Trace.traceをくっつけてみることにしました

_char :: (a -> Bool) -> [a] -> Maybe ([a], [a])
_char _  = Nothing
_char f (c:cs) =
	if (f c) then Just ([c], cs)
		else trace "_char failed" Nothing

eofP :: Parse [a] [a]
eofP = Parse $ \i -> f i
	where
		f  = Just(, )
		f _ = trace "eofP failed" Nothing

そして、コンパイルしなおした電卓に簡単な計算をさせます。

calc "1 + 1"

=>
_char failed
_char failed
　　:
     中略
　　:
_char failed
_char failed
_char failed
_char failed
_char failed
_char failed
_char failed
_char failed
2

ということで、トレースメッセージの出現回数をカウントするとなんと４６回です！
何でこんなことになったのでしょう？入力したのはたったの５文字です…

今回のコードの元になったPEGを引っ張ってきましょう

OPTBLANK=(' '/'\t')*

DIGIT = (1/2/3/4/5/6/7/8/9)
DIGIT0 = (0/DIGIT)

NUMBER=(ZERO/-?NONZERO)

ZERO = 0!(DIGIT0)
NONZERO = (DIGIT, DIGIT0*)

BLOCK=(\(,OPTBLANK,FORMULA,OPTBLANK,\),OPTBLANK,)
BLOCKORNUM=(NUMBER/BLOCK)

ADDDEC=(MULDIVORNUM,OPTBLANK,(+/-),OPTBLANK,ADDDEC)
MULDIV=(BLOCKORNUM,OPTBLANK,(*/\//),OPTBLANK,MULDIV)
MULDIVORNUM=(MULDIV/BLOCKORNUM)

FORMULA=(OPTBLANK,(ADDDEC/MULDIVORNUM))

バックトラックという観点から見ると、'9'をDIGITがパースするのには実はバックトラックを８回することになります。同じ'9'をNUMBERがパースするためには、まずZEROが失敗して、その次にオプショナルな'-'、そしてやっとNONZEROにいきますが、そこで'9'を発見した後にまたDIGIT0*なんていうのがあって、残念ながら次の文字はないので、ここではすべての選択肢を試した挙句にフェイルして帰ってくることになります。

ということで、NUMBERだけでもかなり大変なことになっているのがわかりますね…

もう少し上のレベルのパーサーを見てみると、ADDDECもMULDIVもさらにそれらを統合しているFULDIVORNUMやFORMULAも選択オペレータをとても贅沢に使っていることがわかりますね…自分の頭でこのPEG文法に沿って数式をパースしようと思うと気が遠くなりそうです。1 + 1をパースするのに４６回バックトラックしてもおかしくない気がしてきますね…

ちょっと考えてみると、バックトラックしたときの振る舞いはおそらく２つに大別できて、一度フェイルしたらもうその文字に対して同じパーサーが走ることはない場合（たとえばDIGITが'9'をパースするときの１−８まで）と、同じパーサーが同じ文字列に対して走る場合があるようです。

２つ目のほうの例を今回の電卓で見てみると、足し算は乗除よりもプライオリティが低いうえ、両方ともパラメタを２項とも含んだ形で定義されているので、1 + 1の最初の１はまずはMULDIVORNUM経由のMULDIVの１項目めとしてマッチして、そのあと＊も／もないのでMULDIVが失敗して、次にMULDIVORNUMの第２選択肢であるBLOCKORNUMにもう一度マッチします…

この場合はメモ化が効果を発揮しそうですね…メモ化をしなくてもパーサーの定義のほうである程度のバックトラック量の削減はできそうな気もします。パーサーの可読性や再利用性は犠牲になるかもしれませんが…

今日はこの辺で。
ではでは。

PEG電卓をやってみた

前回のポストから日数がたってしまいましたが、たまにはちゃんと最後まで書こうということで、出来上がったPEG電卓のコードを乗せておきます。

パーサーの定義が前回までのポストとは微妙に変わっていますが、大筋は同じです。こっちのほうがコンパイルして動作確認も取れてます。

電卓のほうは以前に書いた四則演算のPEG表現を素直にPEGパーサモナドで書き換えたものです…空白の処理なんかが増えてますが…

コードが長いのでこのポストはこれでおしまい。

module Main where

import System (getArgs)
import Data.List (intercalate)

ifNothing Nothing v = Just v
ifNothing (Just _) _ = Nothing

newtype Parse i o = Parse {
		runParse :: i -> Maybe (o, i)
	}

instance Monad (Parse i) where
	(>>=) p f = Parse $ \i ->
		case (runParse p i) of
			Nothing -> Nothing
			Just (o, i') -> runParse (f o) i'
	return o = Parse $ \i -> Just (o, i)
	fail _ = Parse $ \_ -> Nothing

_char :: (a -> Bool) -> [a] -> Maybe ([a], [a])
_char _  = Nothing
_char f (c:cs) =
	if (f c) then Just ([c], cs)
		else Nothing

eofP :: Parse [a] [a]
eofP = Parse $ \i -> f i
	where
		f  = Just(, )
		f _ = Nothing

charP :: Eq a => a -> Parse [a] [a]
charP ch = Parse $ \str -> _char (ch ==) str

strP :: Eq a => [a] -> Parse [a] [a]
strP str = foldr seqP emptyP $ map (charP) str

anyOfP :: Eq a => [a] -> Parse [a] [a]
anyOfP chs = Parse $ \str -> _char ( (flip elem) chs) str

anyButP :: Eq a => [a] -> Parse [a] [a]
anyButP chs = Parse $ \str -> _char (not.(flip elem) chs) str

anyP :: Parse [a] [a]
anyP = Parse $ \str -> _char (\_ -> True) str

followedP :: Parse i [o] -> Parse i [o]
followedP pf = Parse $ \i -> (runParse pf i) >> return ([ ], i)

notFollowedP :: Parse i [o] -> Parse i [o]
notFollowedP nf = Parse $ \i -> ifNothing (runParse nf i) ([ ], i)

ifP:: Parse i o -> (o -> Parse i o) -> Parse i o -> Parse i o
ifP p ps pf = Parse $ \i ->
	case (runParse p i) of
		Nothing -> runParse pf i
		Just (o, i') -> runParse (ps o) i'

emptyP :: Parse a [b]
emptyP = return  []

optP :: Parse i [o] -> Parse i [o]
optP p = ifP p return emptyP

repeatP :: Parse i [o] ->  Parse i [o]
repeatP p = ifP p (\o -> (repeatP p) >>= return.(o++)) emptyP

repeatP1 :: Parse i [o] -> Parse i [o]
repeatP1 p = seqP p (repeatP p)

choiceP :: Parse i o -> Parse i o -> Parse i o
choiceP p q = ifP p return q

seqP :: Parse i [o] -> Parse i [o] -> Parse i [o]
seqP p q = do
	v <- p
	w <- q
	return (v ++ w)
	
type StrParser = Parse String String
digitP :: StrParser
digitP = anyOfP ['1'..'9']

digit0P :: StrParser
digit0P = anyOfP ['0'..'9']

unaryP = charP '-'

numberP :: StrParser
numberP = ( (charP '0') `seqP` (notFollowedP digitP) )
	`choiceP` 
	( (optP unaryP) `seqP` digitP `seqP` (repeatP digit0P) )

numPI :: Parse String [Int]
numPI = do
	num <- numberP
	return [read num]

blankChP :: StrParser
blankChP = anyOfP " \t"

blankP = repeatP blankChP

blockPI = do
	(charP '(') `seqP` blankP
	val <- expPI 
	blankP `seqP` (charP ')') `seqP` blankP
	return val

addDecPI = addPI `choiceP` decPI

numBlkMulDivPI = mulPI `choiceP` divPI `choiceP` numBlkPI

numBlkPI :: Parse String [Int]
numBlkPI = blockPI `choiceP` numPI

addPI :: Parse String [Int]
addPI = do
	(val1:_) <- numBlkMulDivPI
	blankP `seqP` (charP '+') `seqP` blankP 
	(val2:_) <- expPI
	return [val1 + val2] 

decPI :: Parse String [Int]
decPI = do
	(val1:_) <- numBlkMulDivPI
	blankP `seqP` (charP '+') `seqP` blankP 
	(val2:_) <- expPI
	return [val1 - val2]

mulPI :: Parse String [Int]
mulPI = do
	(val1:_) <- numBlkPI 
	blankP `seqP` (charP '*') `seqP` blankP 
	(val2:_) <- numBlkMulDivPI 
	return [val1 * val2]

divPI :: Parse String [Int]
divPI = do
	(val1:_) <- numBlkPI
	blankP `seqP` (charP '/') `seqP` blankP 
	(val2:_) <- numBlkMulDivPI
	return [val1 `div` val2]

expPI = do
	blankP
	(addDecPI `choiceP` numBlkMulDivPI)

main = getArgs >>= putStrLn.show.head.fst.unJust.
	compute.intercalate " "
	where
		unJust (Just a) = a
		compute = runParse expPI

PEGパーサーを書いてみる：後半

前回、シグネチャだけで終わっていたパーサーを実装してみました。

seqP :: Parser i o -> Parser i o -> Parser i o
seqP p q = do
　　v <- p
　　w <- q
　　return (v ++ w)

ifP:: Parser i o -> ([o] -> Parser i o) -> Parser i o -> Parser i o
ifP p ps pf = Parser $ \i ->
　　case (runParser p i) of
　　　　Nothing -> runParser pf i
　　　　Just (o, i') -> runParser (ps o) i'

orP :: Parser i o -> Parser i o -> Parser i o
orP p q = ifP p return q

emptyP :: Parser i o
emptyP = return 

manyP :: Parser i o -> Parser i o
manyP p = ifP p (recurse) emptyP
　　where
　　　　recurse o = manyP p >>= return .(o++)

optP :: Parser i o -> Parser i o
optP p = ifP p return emptyP

followedByP :: Parser i o -> Parser i o
followedByP pf = Parser $ \i -> (runParser pf i) >> return (, i)

notFollowedByP :: Parser i o -> Parser i o
notFollowedP nf = Parser $ \i -> ifNothing (runParser nf i) ([], i)
　　where
　　　　ifNothing Nothing v = Just v
　　　　ifNothing (Just _) _ = Nothing

といった感じで、それぞれの振る舞いを記述するのにseqPのようにモナドインターフェースの上のレベルで書くこともできれば、followedByPのようにモナドの下のレベルで書くことも簡単できて、うまいことできてるなーという感じですね…

ちなみにifPという補助コンビネータが結構便利でした。

ちょっと簡単ですが、今日はこの辺で。

ではでは。

PEGパーサーを書いてみる

PEGで文法を表現してみて、ルールのそれぞれの使い方動きにもなじみが出てきました。

ここで、PEGパーサーをちょっと書いてみたいと思います。PappyやFrisbyのようにO(N)というわけに行くかどうかはわかりませんが…

方針としては、Parsecのまねということで、モナドのインターフェースにあわせて、ステートモナドのパターンを踏襲していきたいと思います。

次に、モナドパーサーの入出力についてみてみたいと思います。まず、パーサーとして、成功のときはパースの結果と、残りの入力文字列を返す必要があります。さらに、PEGパーサーのルールの中では空文字：（）のように成功しても何も出力しないものがあります。つまり、出力型は｢空｣というコンセプトが表現できなくてはいけませんね。それ以外にも順序：(e1,e2,e3,e4)のように複数のパーサーを順次マッチさせた結果を返すときは各パーサーの要素をうまくつなぎ合わせることができると話が単純になりそうです。ということで、ちょっと無駄なような気もするのですが、出力は常にリストになるようにするとして

data Parser i o = Parser { runParser :: \i -> Maybe ([o], i)}

ということにして見ます。パース失敗のときはNothing、成功の場合はJust（[o], i)といった感じで…その辺を指定するべくモナドのインスタンス宣言を書いて見ます：

instance Monad (Parser i) where
　　m >>= f = Parser $ \i ->
　　　　case (runParser m i) of
　　　　　　Nothing -> Nothing
　　　　　　Just (o, i') -> runParse (f o) i'
　　return o = Parse \i -> Just (o, i)

PEGのルールを見てみると、いくつかの種類に分けることができることに気づきます。
まずはパーサーの核というべき単純なパーサーです：

emptyP :: Parser i o
emptyP = Parser $ \i -> Just ([], i)

itemP :: o -> Parser i o
itemP o = Parser $ \is@(i:iss) -> 
　　if (i == 0) then Just ([o], iss)
　　　　else Nothing

ここから先はとりあえずシグネチャだけ押さえていきたいと思います。

そして、それを組み合わせていくコンビネータのうち次の2つを2項演算子として定義します

seqP :: Parser i o -> Parser i o -> Parser i o

orP :: Parser i o -> Parser i o -> Parser i o

そして、単項演算子が

manyP :: Parser i o -> Parser i o

many1P p = p `seqP` (manyP p)

optP :: Parser i o -> Parser i o

最後に、迷ったのがfollowedByPとnotFollowedByPです。これは2項でも単項でもかけるんですが、followedByという意味からすると2項で行く方法もありだと思うのですが、単項でやって見ましたということで：

followedByP :: Parser i o -> Parser i o
notFollowedByP :: Parser i o -> Parser i o

この2つを単項演算子で定義することのメリットは単体で使えることなんですが、まぁ、そんなに重要なことではないかもしれません。さらに、2項で定義したとしても、emptyPを組み合わせれば簡単に単項バージョンと同じように使えます。

これが完成すれば、前回の四則演算のPEGを使って電卓が作れます…
ではでは。

PEGで四則演算を表現してみる

前回PEGで整数をパースするパターンをやってみました：

NUMBER = (ZERO/NONZERO)
NONZERO = (DIGIT, DIGIT0*)
ZERO = 0!(DIGIT0)
DIGIT = (1/2/3/4/5/6/7/8/9)
DIGIT0 = (0/DIGIT)

これに加減乗除を追加して四則演算をパースするPEGを書いてみます。

まずは整数の表記がマイナス値も表現できるように単項演算氏のマイナスを取り扱えるようにします。マイナス記号はあっても無くてもよいので省略可能にします：

NUMBER=(ZERO/-?NONZERO)

こうすることで、0は許されても-0はエラーになるようになってます。

次に、足し算をやって見ましょう：

ADDITION=(NUMBER,+,NUMBER)

これで

1+1
1231+2343
1231+-2

はパース可能ですが、空白が途中にある文字列はパースできません。それを直すためにOPTBLANKを導入しましょう

ADDITION=(NUMBER, OPTBLANK, +, OPTBLANK, NUMBER)
OPTBLANK=(' '/'\t')*

こうすることで、数と演算子の間の任意個のタブ、空白文字をスキップできるようになります。
次に1+1+1などのような2項以上の式を取り扱えるようにします。PEGでは左再帰が必ず無限ループになってしまうので次のようにします：

ADDITION=(NUMBER,OPTBLANK,+,OPTBLANK,VALUE)
VALUE=(ADDITION\NUMBER)

こうすることで＋はleft associative(左結合)になりますね。

これを拡張して次のようにやるとどうなるでしょう？

COMPUTE=(NUMBER,OPTBLANK,(+/-/*/\//),OPTBLANK,VALUE)
VALUE=(COMPUTE\NUMBER)

これだと加減と乗除の間の優先順位の違いがうまく取り扱えません。なので、加減と乗除を行うPEGを分離します。加減のほうが乗除よりも優先順位は低いので：

ADDDEC=(MULDIVORNUM,OPTBLANK,(+/-),OPTBLANK,ADDDEC)
MULDIV=(NUMBER,OPTBLANK,(*/\//),OPTBLANK,MULDIV)
MULDIVORNUM=(MULDIV/NUMBER)

FORMULA=(ADDDEC/MULDIVORNUM)

とやってやれば、
1*2+3+4+5/2/1*3
なんていうのも
(1*2)+3+4+((5/2)/1)*3
という解釈をしてくれます。

最後におまけでカッコを使えるようにして出来上がったのがこれです：

OPTBLANK=(' '/'\t')*

DIGIT = (1/2/3/4/5/6/7/8/9)
DIGIT0 = (0/DIGIT)

NUMBER=(ZERO/-?NONZERO)

ZERO = 0!(DIGIT0)
NONZERO = (DIGIT, DIGIT0*)

BLOCK=(\(,OPTBLANK,FORMULA,OPTBLANK,\),OPTBLANK,)
BLOCKORNUM=(NUMBER/BLOCK)

ADDDEC=(MULDIVORNUM,OPTBLANK,(+/-),OPTBLANK,ADDDEC)
MULDIV=(BLOCKORNUM,OPTBLANK,(*/\//),OPTBLANK,MULDIV)
MULDIVORNUM=(MULDIV/BLOCKORNUM)

FORMULA=(OPTBLANK,(ADDDEC/MULDIVORNUM))

PEGは高々10個程度の文法要素でわりと簡単に、しかも結構簡潔に文法の記述ができますね。

今回参考にしているPackrat Parsing: a Practical Linear-Time Algorithm with Backtrackingという論文ではPappyというパーサージェネレーターライブラリについて解説しているのですが、Haskell上ではこの次の世代に当たるFrisbyというライブラリも開発されているようです。

FrisbyはPappyとは違って、Parsecに近いパーサーコンビネータ・ライブラリなようです。それでいて、Pappyと同じO(N)ドメインでパースをすることができるようです。僕はまだPEGの勉強をしているだけで、どちらも使ってみてはいないのですが…

今日はこの辺で。
ではでは。