Brainf*ckインタプリタをつくりながら学ぶHaskell（最終回：Operationalモナド編）

- [第一回：ごりごり編](https://qiita.com/sgmryk/items/18e0a4c72130b2a54986)
- [第二回：Stateモナド編](https://qiita.com/sgmryk/items/dfb0666f44020f4f5e6b)
- [第三回：パーサコンビネータ編](https://qiita.com/sgmryk/items/a76ebb6f66cba4d25dfa)
- 最終回：Operationalモナド編←今回

# Operationalモナド
Operationalモナドには主に２種類の実装があります。（と思います）
1. http://hackage.haskell.org/package/operational
2. http://hackage.haskell.org/package/free-operational

[Stakage](https://www.stackage.org/haddock/lts-11.10/operational-0.2.3.5/Control-Monad-Operational.html)に組み込まれてるのは1のほう実装みたいです。

# 1つ目の実装
```hs
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE RankNTypes #-}
data Program instr a where
  Return :: a -> Program instr a
  Bind :: Program instr r -> (r -> Program instr a) -> Program instr a
  Instr :: instr a -> Program instr a

instance Monad (Program instr) where
  return = Return
  (>>=) = Bind

singleton :: instr a -> Program instr a
singleton = Instr

interpret :: Monad m => (forall r. instr r -> m r) -> Program instr a -> m a
interpret _ (Return a) = return a
interpret f (Instr  a) = f a
interpret f (Return r     `Bind` g) = interpret f (g r)
interpret f (Instr fr     `Bind` g) = f fr >>= interpret f . g
interpret f (pgr `Bind` h `Bind` g) = interpret f $ pgr `Bind` \r -> h r`Bind`g
```
実際の実装内容とは違いますが要点はこんな感じ。

# 2つ目の実装(Free + CoYoneda)

## Free
```hs
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE RankNTypes #-}
data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Functor (Free f) where
  fmap f (Pure a) = Pure (f a)
  fmap f (Free x) = Free $ fmap (fmap f) x

instance Functor f => Applicative (Free f) where
  pure = Pure
  (Pure f) <*> x = fmap f x
  (Free f) <*> x = Free $ fmap (<*>x) f

instance Functor f => Monad (Free f) where
  return = Pure
  (Pure a) >>= f = f a
  (Free x) >>= f = Free $ fmap (>>=f) x

liftF :: Functor f => f a -> Free f a
liftF x = Free $ fmap return x
```
Freeモナドは、FunctorからMonadを作ることができるモナドです。
`liftF`でFunctorなデータをFreeモナドに変換します。

## CoYoneda
[米田の補題](https://ja.wikipedia.org/wiki/%E7%B1%B3%E7%94%B0%E3%81%AE%E8%A3%9C%E9%A1%8C)をもとにしているらしいです。

```hs
{-# LANGUAGE GADTs      #-}
{-# LANGUAGE RankNTypes #-}
data Coyoneda f a where
  Coyoneda :: (r -> a) -> f r -> Coyoneda f a

instance Functor (Coyoneda f) where
  fmap f (Coyoneda k x) = Coyoneda (f.k) x

liftCoyoneda :: f a -> Coyoneda f a
liftCoyoneda = Coyoneda id
```
Coyonedaを利用すると、任意のデータ型をFunctorにすることができます。
これをFreeと組み合わせると任意のデータ型をMonadにできます！！！

## Operational = Free + CoYoneda
```hs
type Program f a = Free (Coyoneda f) a

singleton :: f a -> Program f a
singleton = liftF . liftCoyoneda

interpret :: Monad m => (forall r.f r -> m r) -> Program f a -> m a
interpret _ (Pure a) = return a
interpret f (Free (Coyoneda k x)) = f x >>= interpret f . k
```
`Program`はFreeとCoyonedaの組み合わせで表現します。
`singleton`はCoyonedaに持ち上げたものを、Freeにさらに持ち上げます。

# OperationalをつかってDSLを構築
```hs
{-# LANGUAGE GADTs #-}
data Hoge a where
  Hoge :: Hoge String
  Fuga :: Hoge ()
  Piyo :: String -> Hoge Int

hogeProgram :: Program Hoge (String,Int)
hogeProgram =  do
  x <- singleton Hoge
  y <- singleton (Piyo "piyo")
  singleton Fuga
  return (x,y)
```
適当なデータ型`Hoge`をつくります。
`singleton`をつかってモナド化するとdo記法で処理がつくれます。

```hs
-- Hogeの構成子それぞれにIO処理を定義していく
runHoge :: Program Hoge a -> IO a
runHoge = interpret eval where
  eval :: Hoge a -> IO a
  eval Hoge = return "Hoge"
  eval Fuga = putStrLn "Hello, World!"
  eval (Piyo a) = return (length a)

-- IO処理が実行できた
>>> runHoge hogeProgram
Hello, World!
("Hoge",4)
```
`interpret`をつかって、`Hogeプログラム`を`IOモナド`に変換する方法を定義します。

`interpret`で違うモナドへの変換をつくってあげれば、
同じ内容のプログラムから全く違う処理結果ができます。

```hs
logHoge :: Program Hoge a -> Writer String a
logHoge = interpret eval where
  eval :: Hoge a -> Writer String a
  eval Hoge = tell "[Hoge]" >> return "hogeeee"
  eval Fuga = tell "[Fuga]"
  eval (Piyo a) = tell ("[Piyo \"" ++ a ++ "\"]") >> return 777

-- 同じプログラムから違う結果
>>> logHoge hogeProgram
(("hogeeee",777),"[Hoge][Piyo \"piyo\"][Fuga]")
```

# Brainf*ckをDSL化
```hs
type BFProgram a = Program BF a
data BF a where
  Inc :: BF ()
  Dec :: BF ()
  Next :: BF ()
  Prev :: BF ()
  PutC :: BF ()
  GetC :: BF ()
  Loop :: BFProgram a -> BF ()
```
まずはBF型をDSL化できるように変更します。

```hs
runBF :: BFProgram a -> StateT Memory IO a
runBF = interpretWithMonad eval
  where
  eval :: BF a -> StateT Memory IO a
  eval Inc  = modify $ \(l,m,r) -> modify $ \(l,m,r) -> (l,succ m,r)
  eval Dec  = modify $ \(l,m,r) -> modify $ \(l,m,r) -> (l,pred m,r)
  eval Next = modify $ \(l,m,r) -> if null l then ( [],toEnum 0,m:r) else (tail l,head l,   m:r)
  eval Prev = modify $ \(l,m,r) -> if null r then (m:l,toEnum 0, []) else (   m:l,head r,tail r)
  eval PutC = get >>= \(_,m,_) -> liftIO (putChar m)
  eval GetC  = liftIO getChar >>= \c -> modify $ \(l,m,r) -> (l,c,r)
  eval (Loop pg) = loop where
    loop :: StateT Memory IO ()
    loop = do
      (_,m,_) <- get
      if m == toEnum 0
        then return ()
        else runBF pg >> loop
```
`runBF`を定義します。
第二回の`runBF`をほぼそのまま移植します。


```hs
helloWorld :: BFProgram ()
helloWorld = do
  mapM_ (\_ -> singleton Inc) [1..9]
  singleton.Loop $ do
    singleton Next
    mapM_ (\_ -> singleton Inc) [1..8]
    singleton Next
    mapM_ (\_ -> singleton Inc) [1..11]
    singleton Next
    mapM_ (\_ -> singleton Inc) [1..5]
    singleton Prev
    singleton Prev
    singleton Prev
    singleton Dec
  singleton Next
  singleton PutC
  singleton Next
  singleton Inc
  singleton Inc
  singleton PutC
  mapM_ (\_ -> singleton Inc) [1..7]
  singleton PutC
  singleton PutC
  mapM_ (\_ -> singleton Inc) [1..3]
  singleton PutC
  singleton Next
  singleton Dec
  singleton PutC
  mapM_ (\_ -> singleton Dec) [1..12]
  singleton PutC
  singleton Prev
  mapM_ (\_ -> singleton Inc) [1..8]
  singleton PutC
  mapM_ (\_ -> singleton Dec) [1..8]
  singleton PutC
  mapM_ (\_ -> singleton Inc) [1..3]
  singleton PutC
  mapM_ (\_ -> singleton Dec) [1..6]
  singleton PutC
  mapM_ (\_ -> singleton Dec) [1..8]
  singleton PutC
  singleton Next
  singleton Inc
  singleton PutC
```
HelloWorldのBrainf*ckプログラムをdo記法で書くことができます。
モナドなので`mapM`で繰り返すことだってできます。


```hs
writeBF :: BFProgram a -> Writer String a
writeBF = interpretWithMonad eval
  where
  eval :: BF a -> Writer String a
  eval Inc       = tell "+"
  eval Dec       = tell "-"
  eval Next      = tell ">"
  eval Prev      = tell "<"
  eval PutC      = tell "."
  eval GetC      = tell ","
  eval (Loop pg) = tell "[" >> writeBF pg >> tell "]"

>>> execWriter (writeBF helloWorld)
"+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+."
```
Writerモナドへの変換をつくってあげれば、BFプログラムからBrainf*ckのコードが生成できます。

# これまでのまとめ
以下、集大成。

```hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
import           Control.Monad.Operational
import           Control.Monad.State
import           Control.Monad.Writer
import           Data.Functor.Identity
import           Data.Maybe
import           Text.Parsec

-- BF型
data BF a where
  Inc :: BF ()
  Dec :: BF ()
  Next :: BF ()
  Prev :: BF ()
  PutC :: BF ()
  GetC :: BF ()
  Loop :: BFProgram a -> BF ()

-- BFのプログラム
type BFProgram a = Program BF a

-- メモリ
type Memory = ([Char],Char,[Char])
initMemory :: Memory
initMemory = ([],toEnum 0,[])

-- BFプログラム → Stateモナド
runBF :: BFProgram a -> StateT Memory IO a
runBF = interpretWithMonad eval
  where
  eval :: BF a -> StateT Memory IO a
  eval Inc  = modify $ \(l,m,r) -> (l,succ m,r)
  eval Dec  = modify $ \(l,m,r) -> (l,pred m,r)
  eval Next = modify $ \(l,m,r) -> if null l then ( [],toEnum 0,m:r) else (tail l,head l,   m:r)
  eval Prev = modify $ \(l,m,r) -> if null r then (m:l,toEnum 0, []) else (   m:l,head r,tail r)
  eval PutC = get >>= \(_,m,_) -> liftIO (putChar m)
  eval GetC  = liftIO getChar >>= \c -> modify $ \(l,m,r) -> (l,c,r)
  eval (Loop pg) = loop where
    loop :: StateT Memory IO ()
    loop = do
      (_,m,_) <- get
      if m == toEnum 0
        then return ()
        else runBF pg >> loop

-- BFプログラム → Writerモナド
writeBF :: BFProgram a -> Writer String a
writeBF = interpretWithMonad eval
  where
  eval :: BF a -> Writer String a
  eval Inc       = tell "+"
  eval Dec       = tell "-"
  eval Next      = tell ">"
  eval Prev      = tell "<"
  eval PutC      = tell "."
  eval GetC      = tell ","
  eval (Loop pg) = tell "[" >> writeBF pg >> tell "]"

-- BFプログラム → Brainf*ckのコード
getBFCode :: BFProgram a -> String
getBFCode = execWriter . writeBF

-- BF型へのパーサー
parseBF :: Stream s Identity Char => Parsec s u [BF ()]
parseBF = catMaybes <$> manyTill bf eof where
  bf :: Stream s Identity Char => Parsec s u (Maybe (BF ()))
  bf = choice [
    Nothing   <$ noneOf "+-<>.,[]",
    Just Inc  <$ char '+',
    Just Dec  <$ char '-',
    Just Next <$ char '>',
    Just Prev <$ char '<',
    Just PutC <$ char '.',
    Just GetC <$ char ',',
    loop
    ]
    where
    loop = do
      maybeBFs <- between (char '[') (char ']') (many bf)
      let
        pg :: BFProgram ()
        pg = mapM_ singleton (catMaybes maybeBFs)
      return $ Just (Loop pg)

-- Brainf*ckのコードを実行する
-- String -> [BF ()] -> BFProgram () -> StateT IO () -> IO ()
interpretBF :: String -> IO ()
interpretBF s = case parse parseBF "Brainf*ck" s of
  Left err -> print err
  Right pg -> evalStateT (mapM_ (runBF.singleton) pg) initMemory
```
Brainf*ckのコードを実行するだけのために多くの変換を経ています。
でも、第一回のゴリゴリ実装にくらべるといいところがたくさんです。

パーサコンビネータによって、コンパイルエラーがわかりやすい形で出力されるようになりました。
Stateモナドによって、処理の流れが簡潔になりました。
OperationalモナドでDSL化したことにより、中間言語(`BFProgram`)でプログラムがつくれて逆コンパイル(`getBFCode`)までできるようになりました。
（普通は逆コンパイルすると高級言語になるはずだが、逆に難解プログラミング言語になってしまう）

BFProgramで部品を作って組み合わせることで、複雑な処理もBrainがF*ckされずにつくれるようになる可能性を秘めています。
さらにそれを逆コンパイルすれば、複雑な処理をするBrainf*ckのプログラムのコードがかけてしまうのではないでしょうか。
Operationalモナドすごい・・・

# 最後に
**Brainf*ckは最高のプログラミング教材だ！！！**