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

• 第一回：ごりごり編
• 第二回：Stateモナド編
• 第三回：パーサコンビネータ編
• 最終回：Operationalモナド編←今回

Operationalモナド

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

Stakageに組み込まれてるのは1のほう実装みたいです。

1つ目の実装

{-# 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

{-# 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

米田の補題をもとにしているらしいです。

{-# 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

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を構築

{-# 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記法で処理がつくれます。

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

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化

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化できるように変更します。

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をほぼそのまま移植します。

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で繰り返すことだってできます。

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のコードが生成できます。

これまでのまとめ

以下、集大成。

{-# 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は最高のプログラミング教材だ！！！