Haskellで分野向けの機械を開発する（３）

１．窮屈からの脱出

数式から木構造を生成する方法が、オペレーショナル・モナドに移行したが、コードが増えた割にはあまりご利益がない。数式の指定が固定的で、キーボードからの自由な入力にはなっていない。そこで、オペレーショナル・モナドの拡張版(モナド変換子）を用い、キーボードから数式が入力できるようにする。

拡張版で用意されているのは、ProgramT,PromptT,viewTである。これらはすべて、Program,Prompt,Viewをモナドの世界に移したもので、IOとの共存を許している。programTは次のように定義されている。以下で、mはモナドである。

data ProgramT instr m a

インスタンスとなるのは次の通りである。

MonadTrans (ProgramT instr)	 
Monad m => Monad (ProgramT instr m)	 
Monad m => Functor (ProgramT instr m)	 
Monad m => Applicative (ProgramT instr m)

PromptTは次のように定義されている。

data PromptT instr m a where
  Return :: a -> PromptT instr m a	 
  :>>= :: instr b -> (b -> ProgramT instr m a) -> PromptT instr m a

Returnは、命令ツリーが終了したときのもので、aを型PromptT instr m aにして返す。
:>>はそれぞれの命令に対応したもので、命令bを引数で受け取り、それを「bを引数とし型ProgramT instr m aを返す」関数に渡し、型PromptT instr m aにして返す。前との違いはモナド(入出力などと一緒の現実)の世界に移っていることである。

ViewTは次のように定義されている。

viewT :: Monad m => ProgramT instr m a -> m (PromptT instr m a)

２．プログラム書き換え

モナドの世界で生きられるように前回のプログラムを書き換えると次のようになる。

{-# LANGUAGE GADTs #-}

import Control.Monad
import Control.Monad.Operational
import Control.Applicative
import Control.Monad.Trans

data Tree =  Empty | Leaf Int | Node Op Tree Tree deriving (Eq, Show)
data Op = Plus | Mult deriving (Eq, Ord, Show)

data TreeI a where
  InsOp   :: Char -> TreeI ()
  InsVal  :: Int  -> TreeI ()

type TreeP m a = ProgramT TreeI m a

insOp  :: (Monad m) => Char -> TreeP m ()
insOp  = singleton.InsOp

insVal :: (Monad m) => Int -> TreeP m ()
insVal = singleton.InsVal  

interpret :: (Monad m) => TreeP m a -> Tree -> m Tree
interpret is tree = (\v -> eval v tree) =<< (viewT is)
  where
    eval :: (Monad m) => ProgramViewT TreeI m a -> Tree -> m Tree
    eval (InsOp  x :>>= is) tree 
      | x == '+' || x == '*'       = interpret (is ()) $ operation x tree
      | otherwise                  = return tree
    eval (InsVal x :>>= is) tree   = interpret (is ()) $ number x tree 
    eval (Return _)         tree   = return tree 

operation :: Char -> Tree -> Tree
operation x tree
  | x == '+'  = plus tree
  | x == '*'  = mult tree
plus :: Tree -> Tree
plus tree = Node Plus tree Empty

number :: Int -> Tree -> Tree
number x Empty = Leaf x
number x (Node op t1 t2)
  | t2 == Empty = Node op t1 $ Leaf x
  | otherwise   = Node op t1 $ number x t2

mult :: Tree -> Tree
mult (Leaf t2) = Node Mult (Leaf t2) Empty 
mult (Node op t1 t2) = Node op t1 $ mult t2

また、前回のTransformのところはIOが使えるようになるので、次のように書き換えることができる。

transform :: TreeP IO ()
transform = forever $ do
  (liftIO . putStrLn) "Input an integer value."
  insVal =<< read <$> liftIO getLine
  (liftIO . putStrLn) "Input an operator '+', '*' or quit 'q'."
  insOp =<< read <$> liftIO getLine
 
main :: IO ()
main = do
  (putStrLn . show) =<< interpret transform Empty