正規表現技術入門に出てきた Russ Cox の VM の動作を模倣して、下記のように動くrunVMと命令(char, match, jmp, split)を実装する。
RegExpr/main.hs
import RegExpr.VM(runVM, char, match, jmp, split)
-- | "a+b+"の正規表現
test1 = runVM do
char 'a' -- 0
split 0 2 -- 1
char 'b' -- 2
split 2 4 -- 3
match -- 4
-- | "aa*bb*"の正規表現
test2 = runVM do
char 'a' -- 0
split 2 4 -- 1
char 'a' -- 2
jmp 1 -- 3
char 'b' -- 4
split 6 8 -- 5
char 'b' -- 6
jmp 5 -- 7
match -- 8
main = do
-- | "a+b+"
print $ test1 "abb" -- True
print $ test1 "aab" -- True
print $ test1 "aaa" -- False
print $ test1 "baa" -- False
-- | "aa*bb*"
print $ test2 "abb" -- True
print $ test2 "aab" -- True
print $ test2 "aaa" -- False
print $ test2 "baa" -- False
VM用のプログラムが書けるようにする
命令の型、プログラムの型
Russ Cox の VM には４つの命令(char, match, jmp, split)があるので、（VMに対する）命令の型は次のように定義しておく。
RegExpr/VM/Program.hs
data Instruction a = Char a
| Match
| Jmp Int
| Split Int Int
プログラムは（VMに対する）命令のリストなので、ついでに次の型シノニムを定義しておく。
RegExpr/VM/Program.hs
type Program a = [Instruction a]
プログラミングという型
ProgrammingとはProgramをWriteすることである。1
RegExpr/VM/Program.hs
type Programming a = Writer (Program a) ()
do 記法からVM用プログラムを得る
単純にWriterモナドを使って命令を累積して、execWriterで累積結果をゲットすれば、プログラムを得られる。2
RegExpr/VM/Program.hs
getProgram :: Programming a -> Program a
getProgram = execWriter
char :: a -> Programming a
char x = tell [Char x]
match :: Programming a
match = tell [Match]
jmp :: Int -> Programming a
jmp x = tell [Jmp x]
split :: Int -> Int -> Programming a
split x y = tell [Split x y]
これによって、次のようなコードで、[Char 'a',Split 0 2,Char 'b',Split 2 4,Match]を得る。
.hs
getProgram $ do
char 'a'
split 0 2
char 'b'
split 2 4
match
runVM の型
この時点でrunVMの型はわかる。3
とは言え、VMの動作がわからないと此処から先は実装できないので、VM（スレッド）の動作モデルを見ていくことにする。
.hs
runVM :: Eq a => Programming a -> [a] -> Bool
VMの動作（スレッドの実行）モデル
正規表現技術入門を引用すると、VMは次の３つから成るらしい。
- ２つのレジスタ（Register）
- PC(Program Counter、プログラムカウンタ)：次に実行するバイトコードの位置
- SP(String Pointer、文字列ポインタ)：次にマッチを実行する文字の位置
- スタック
- マッチの実行単位であるスレッドの状態を保持しておく領域
- マッチ実行部
- PCが指す位置のバイトコードを取得し、それを解釈して入力文字列とのマッチを実行する。
スレッドの実態は、PCとSPの組です。
ここから次のことがわかる。
- スレッドという実行単位がある
- スレッドはPCとSPの組で、実行中にこれらの値は変化する
- PCによって参照されるバイトコードがある
- SPによって参照される文字列がある
- 実行中に分岐したスレッドを積むスタックがある
必要なモナド
- PCとSP(=スレッド)の状態を扱うStateモナド
- 参照されるバイトコード（=本実装では
Program a）と文字列を保持するReaderモナド -
そして、実行中に分岐したスレッドを記録するWriterモナドがあれば良いように思える。4 - だが、一応
IndexOutOfBounds的なエラーも考慮してErrorモナドを積んでおく。
しからば、欲しいモナドスタックは次のようなもになる。
RegExpr/VM/MonadStack.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
newtype MonadStack e s r a = MonadStack {runMS' :: ErrorT e (StateT s (Reader r)) a}
deriving(Functor, Monad, MonadError e, MonadState s, MonadReader r)
runMS :: MonadStack e s r a -> s -> r -> (Either e a)
runMS m s r = (`runReader` r) . (`evalStateT` s) . runErrorT $ runMS' m
スレッドの実行を表す型
は、先ほど作ったモナドスタックを使って下記のように書ける。
RegExpr/VM.hs
type RunThread a b = MonadStack ErrThread Thread (EnvVM a) b
ここで、ErrThread等は次のように定義しておく。
RegExpr/VM.hs
data ErrThread = PCOutOfBounds
| SPOutOfBounds
| Err String
instance Error ErrThread where
noMsg = Err "Thread Error"
strMsg = Err
data Thread = Thread { pc :: Int
, sp :: Int
}
data EnvVM a = EnvVM { program :: Program a
, string :: [a]
}
命令を実行した結果の戻り値の型
４つの命令(char, match, jmp, split)をそれぞれ実行した場合、スレッドは文字列を受理する（Accept）か、しないか（Reject）、プログラムの実行を継続する（Continue）かの３通りなので、それを表す型を用意しておく。
RegExpr/VM.hs
data Result = Accept | Reject | Continue deriving Eq
これで型の準備は十分にできた。
実装
命令サイクル
ここまでの型の定義から、runVMの実装は概ね次のようにすれば良さそうである。
.hs
runVM :: Eq a => Programming a -> [a] -> Bool
runVM m xs = runMS ic s env == Right Accept
where
ic = undefined
s = Thread 0 0
env = EnvVM (getProgram m) xs
上記では、ic :: RunThread a Resultが定義されていない。ここには何を実装すれば良いだろうか？
と言ってもVMなので命令サイクルを表す再帰関数instructionCycle を実装する他ない。
- 命令をフェッチし
- 命令を評価、実行し
- 次の命令を実行するべきか判断する
RegExpr/VM.hs
runVM :: Eq a => Programming a -> [a] -> Bool
runVM m xs = runMS ic s env == Right Accept
where
ic = instructionCycle Continue
s = Thread 0 0
env = EnvVM (getProgram m) xs
instructionCycle :: Eq a => Result -> RunThread a Result
instructionCycle x
| x /= Continue = return x
| otherwise = fetchIns >>= eval >>= instructionCycle
eval
実装の肝は命令を解釈するevalなので、fetchInsよりも先にこちらを片付ける。
RegExpr/VM.hs
eval :: Eq a => Instruction a -> RunThread a Result
Char a
コメントの部分は正規表現技術入門の引用。実装はコメントのまんま。
RegExpr/VM.hs
-- | 現在の sp が指す文字と x を比較し、
-- | 一致していれば次の命令（pc） と次の文字（sp）に進む
-- | 一致していなければ現在のThreadを終了する（マッチ失敗）
eval (Char x) = do
y <- fetchChar
if x /= y then
return Reject
else do
s <- get
put $ s {pc = pc s + 1, sp = sp s + 1}
return Continue
Match
コメントの部分は正規表現技術入門の引（以下略
RegExpr/VM.hs
-- | 現在のThreadを終了する（マッチ成功）
eval Match = return Accept
Jmp x
コメ（以下略
RegExpr/VM.hs
-- | x の位置の命令にジャンプする
eval (Jmp x) = do
s <- get
put $ s {pc = x}
return Continue
Split x y
やや、やっかいなのがこのSplit。下記では、それぞれの状態を引き継いだVMを新たに立ち上げる方法で実装している。なお、コメントの部分は正規表現技術入門の引用。
RegExpr/VM.hs
-- | ２つのThreadに分岐する、
-- | 一方のThreadは x から実行を開始し、
-- | もう一方は y から実行を開始する。
-- | どちらのThreadも sp は現在の値を引き継ぐ
eval (Split x y) = do
env <- ask
s <- get
let accx = runVM' (s {pc = x}) env
let accy = runVM' (s {pc = y}) env
return $ if accx || accy then Accept else Reject
where
runVM' s env = runMS ic s env == Right Accept
ic = instructionCycle Continue
fetchInsとfetchChar
下記の通り、ほぼ同じ実装。変な位置を参照するとOutOfBoundsなエラーを投げる。
RegExpr/VM.hs
-- | pcが指す命令の読み込み
fetchIns :: RunThread a (Instruction a)
fetchIns = do
r <- ask
s <- get
program r `indexPC` pc s
indexPC :: Program a -> Int -> RunThread a (Instruction a)
indexPC = index PCOutOfBounds
-- | 現在の sp が指す文字を取ってくる
fetchChar :: RunThread a a
fetchChar = do
r <- ask
s <- get
string r `indexSP` sp s
indexSP :: [a] -> Int -> RunThread a a
indexSP = index SPOutOfBounds
-- | リスト xs から指定された位置 i の要素を返す
-- | ただし、指定された位置に要素がなければ、err をエラーとして返す
index :: ErrThread -> [b] -> Int -> RunThread a b
index err xs i | i < 0 = throwError err
index err [] i = throwError err
index err (x: _) 0 = return x
index err (_:xs) i = index err xs $ i - 1
感想
- 実装している途中で、このVMが前方一致であることに気づいた。
- 思いつきで実装してコードが無駄に長くなるこの症状、なにか名前ついてないのかな。