正規表現技術入門に出てきた 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することである。¹

RegExpr/VM/Program.hs

type Programming a = Writer (Program a) ()

do 記法からVM用プログラムを得る

単純にWriterモナドを使って命令を累積して、execWriterで累積結果をゲットすれば、プログラムを得られる。²

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の型はわかる。³
とは言え、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モナドがあれば良いように思える。~~⁴
だが、一応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が前方一致であることに気づいた。
思いつきで実装してコードが無駄に長くなるこの症状、なにか名前ついてないのかな。

ルー語 ↩
do記法の無駄遣い ↩
命令Char aで値の等価判定をするため、Eq aの型クラス制約が付く。 ↩
スタックは明示的に実装せずHaskellのスタックを使うことにした。スタックオーバーフロー起こすかも？ ↩