モナドスタックで正規表現 VM シミュレーション


[正規表現技術入門][Book]に出てきた [Russ Cox の VM][Ross] の動作を模倣して、下記のように動く`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][Ross] には４つの命令(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の動作（スレッドの実行）モデル

[正規表現技術入門][Book]を引用すると、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`

コメントの部分は[正規表現技術入門][Book]の引用。実装はコメントのまんま。

```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`

コメントの部分は[正規表現技術入門][Book]の引（以下略

```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を新たに立ち上げる方法で実装している。なお、コメントの部分は[正規表現技術入門][Book]の引用。

```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が前方一致であることに気づいた。
* 思いつきで実装してコードが無駄に長くなるこの症状、なにか名前ついてないのかな。


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

[Ross]:https://swtch.com/~rsc/regexp/regexp2.html
[Book]:http://gihyo.jp/book/2015/978-4-7741-7270-5