HaskellでLispを書く日記

■ defineを作る

defineを作るからには、単に評価結果を返すだけではなく、変化した環境を次の評価を行う際に利用できるようにしなければならない。いろいろ考えたが、今回はStateモナドを使うことにした。

evalをStateモナド化する

これまでのevalは評価するS式と環境の2つを引数としてとる関数としていたが、今回はStateモナド化するので、環境の方はモナド側の機構を利用して扱うことになり、引数としては評価するS式1つだけになる。

evalの返値はモナドでなければならないので、単にNilを返していたところはreturn Nilに書き換える(1行目)。

環境の値を使いたいときはgetまたはgetsを使って状態を取り出す。2行目では、getsを使いassocの2番目の引数に環境を与えている。getsの返値はすでにモナドなのでreturnは使わずにそのまま返せばよい。

3行目のquoteの処理はNilの時と同じでreturnでモナド化して値を返す。

4行目のlambdaの処理は2行目と同じでgetsを使ってClosure型の2つめのフィールドに環境を埋め込んでいる。getsは関数だけじゃなくてデータコンストラクタに対しても使えるようだ。（または単にカリー化されて関数になってるだけなのかも。）

5行目のifの処理では、条件分岐をするためにまず第1引数pの真偽値を求めなければならない。いままではif式の中に埋め込んで書けていたけど、今やevalの返値はモナドなのでそのままifには与えられない。いったんdo構文の<-を使ってモナド内の値を取り出して、それをifに与えるようにしている。モナドを使うと今まで関数的に書けていたところが手続き型っぽい書き方にさせられてしまうところがなんか悲しい。一方thenまたはelseでもevalを呼び出しているが、このときは返値がモナドである恩恵をうけてreturn等はなしでいい。

6行目の通常の関数呼び出しの処理も、これまで部分式で良かった関数部と引数部の評価を個別に<-を使って値を取り出して、それをapplyに渡す。applyはevalと違ってモナド化しないので返値はreturnを使ってモナドにして返す。

書き始める前は、evalのとる引数がひとつ減ってコードがすっきるするかな、と思っていたが、returnやらdo構文とかが必要になってきてそれほどでもなかった…。

eval (Nil) = return Nil
eval (Symbol s) = gets $ assoc s
eval (Cons (Symbol "quote") (Cons a _)) = return a
eval (Cons (Symbol "lambda") body) = gets (Closure body)
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) = do {b<-eval p;if b /= false then eval t else eval e}
eval (Cons fun arg) = do { a<-eval fun; b<-evals arg; return $ apply a b }

evalsもStateモナド化する。

リスト内の各S式を評価するevalsも同じeval兄弟（？）ということでモナド化する。

Cons型のデータの内部フィールドはSexp型の値が入るのであって、モナド型の値を入れるわけにはいかないので、これまでと同じように<-を使ってモナドをはずしてからCons型に入れる。で、返す値はモナドじゃないといけないので、returnでモナド化する。必要なことだとわかってはいるがなんか不毛だ…。

evals (Cons a b) = do { aa<-eval a; bb<-evals b; return $ Cons aa bb }
evals a = eval a

Stateモナド化したevalの呼び出し

Stateモナド化した関数は、runStateを使って呼び出す。runStateの第1引数が実際の処理を行う関数（今回はeval）で、第2引数が初期値として与える状態（今回は環境）。呼び出した結果は返値と状態のタプルになっている。

なので、evalLoopでは、返ってきたタプルの各値を(a,s)とのパターンマッチで取り出して、まず返値aの方をprintして、状態sの方を次のevalLoopを呼び出すときの環境として使うようにする。

evalLoop str env = ...
  Right (exp,rest) -> case runState (eval exp) env of (a,s) -> print a >> evalLoop s rest

apply中のevalの呼び出し

applyの中でも、仮引数変数と引数との組合せを追加した新たな環境を使ってevalを呼び出す処理があったので、ここも書き換える。こちらではevalの結果だけが欲しいので、runStateではなくevalStateを使う。

apply (Closure (Cons var (Cons body _)) env) arg = evalState (eval body) (zipl var arg env)

eval中にdefineの処理を作る

今までの部分は単に同じ処理を別のやり方に書き換えてきただけ。しかし、これで準備が整ったので実際のdefineに対応する部分を作る。

defineの時はリストの2番目に変数名、3番目にバインドする式が来るので、それぞれvarとexpで取り出す。そして、expを評価して値valを求め、modifyを使って状態を変更する。これまでの環境にvarとvalを対にしたものを加えたものを新たな環境とするのだから、前に作ったdefine（Haskell上で定義した関数の方）が流用できる。

最後にdefine自体の返値として定義された変数名のシンボルを返す。（Schemeの流儀に倣って変数名を返すようにしたけど、どうして値の方じゃなくて変数名なんだろう。値の方を返すようにしていれば、さらにその値を使って別のdefineが呼び出せるのに。）

eval (Cons (Symbol "define") (Cons (Symbol var) (Cons exp _))) = do { val<-eval exp; modify $ define var val; return $ Symbol var }

再帰関数を定義できるようにする

ダイナミックスコープを採用していれば、ここまでの内容で再帰関数も作れるんだけど、今回はレキシカルスコープのlispを作ろうとしているのでこのままでは再帰関数が作れない。

なぜなら、クロージャを適用（=apply）するときにはそのクロージャが持っている環境を使って評価をさせようとしているのにもかかわらず、クロージャの持つ環境は(lambda …)を評価した時点の環境を格納しているので、その環境にはまだ再帰関数名とクロージャ自分自身の対応関係が含まれていないから。

そこで今回はdefineの処理のうち引数がClosure型だったときだけは別扱いとして、Closure内の環境を再帰関数名とクロージャ自分自身の対応関係を追加した環境に入れ替えるようにすることにした。

そうはいっても、今から作ろうとしている自分自身を含んだ新しい環境を、自分自身のフィールド値として与えなければいけないのは、鶏と卵の関係のようでどうすればいいのか結構悩んだ。

しかし、さすが遅延評価。letで用意した変数newenvに値を入れるその式中にnewenvを使うことが出来る。これはいい。Schemeでやってるような、いったん未定義の変数を導入してからset!であとで書き換えるといったことをやらなくてもいいわけだ。

define var (Closure body env) _ = let newenv = Cons (Cons (Symbol var) (Closure body newenv)) env in newenv

テスト

ここまでくれば結構まともなテストが出来る。

まずは普通に変数に値をバインドしてみる。xを評価するとちゃんと(a b c)が入っている。

次に関数null?を定義してみる。xの中身は(a b c)なのでnullではないから偽である#fが返り、()を与えると真である#tが返っている。

最後に、再帰を使うappendを定義してみる。また、上で定義したnull?も使っている。(a b c)に(a b c)を連結して(a b c a b c)を返しておりちゃんと動いているようだ。

C:\haskell>runghc lisp.hs
>(define x '(a b c))
x
>x
(a b c)
>(define null?
   (lambda (x)
     (eq? () x)))
null?
>(null? x)
#f
>(null? ())
#t
>(define append
   (lambda (x y)
     (if (null? x)
         y
         (cons (car x) (append (cdr x) y)))))
append
>(append x x)
(a b c a b c)

今日までの全コード

import Text.ParserCombinators.Parsec
import Control.Monad.State

data Sexp = Nil | Symbol String | Cons Sexp Sexp | Subr (Sexp->Sexp) | Closure Sexp Sexp

instance Eq Sexp where
  (==) Nil Nil = True
  (==) (Symbol a) (Symbol b) = a==b
  (==) (Cons a as) (Cons b bs) = a==b && as==bs
  (==) _ _ = False

instance Show Sexp where
  show (Nil) = "()"
  show (Symbol a) = a
  show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"
  show (Subr _) = "#<subr>"
  show (Closure a _) = "#<closure " ++ show a ++ ">"

showCdr (Nil) = ""
showCdr (Cons a b) = " " ++ show a ++ showCdr b
showCdr a = " . " ++ show a

instance Read Sexp where
  readsPrec _ s = case parse sexpParser "" s of Right a -> [(a,"")]

partParser = spaces >>
  (    do { eof; return (Nil,"") }
   <|> do { exp <- sexpParser; rest <- getInput; return (exp,rest) })

sexpParser = spaces >>
  (    do { string "("; listParser }
   <|> do { string "'"; a<-sexpParser; return (Cons (Symbol "quote") (Cons a Nil)) }
   <|> do { a<-many1 $ noneOf "'() \t\r\n"; return (Symbol a) } )

listParser = spaces >>
  (    do { string ")"; return Nil }
   <|> do { string "."; a<-sexpParser; listParser; return a }
   <|> do { a<-sexpParser; b<-listParser; return (Cons a b) } )

true = Symbol "#t"
false = Symbol "#f"

eval (Nil) = return Nil
eval (Symbol s) = gets $ assoc s
eval (Cons (Symbol "define") (Cons (Symbol var) (Cons exp _))) = do { val<-eval exp; modify $ define var val; return $ Symbol var }
eval (Cons (Symbol "env") _) = get
eval (Cons (Symbol "quote") (Cons a _)) = return a
eval (Cons (Symbol "lambda") body) = gets (Closure body)
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) = do {b<-eval p;if b /= false then eval t else eval e}
eval (Cons fun arg) = do { a<-eval fun; b<-evals arg; return $ apply a b }

evals (Cons a b) = do { aa<-eval a; bb<-evals b; return $ Cons aa bb }
evals a = eval a

apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = evalState (eval body) (zipl var arg env)
apply f a = error $ "error in apply: " ++ show (Cons f a)

assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
assoc s _ = error $ "unbound variable: " ++ show s

zipl Nil _ e = e
zipl (Cons k ks) (Cons v vs) e = zipl ks vs $ zipl k v e
zipl k v e = Cons (Cons k v) e

define var (Closure body env) _ = let newenv = Cons (Cons (Symbol var) (Closure body newenv)) env in newenv
define var val env = Cons (Cons (Symbol var) val) env

env =
 define "car" (Subr (\(Cons (Cons a _) _)->a)) $
 define "cdr" (Subr (\(Cons (Cons _ a) _)->a)) $
 define "cons" (Subr (\(Cons a (Cons b _))->Cons a b)) $
 define "eq?" (Subr (\(Cons a (Cons b _))->if a==b then true else false)) $
 define "pair?" (Subr (\(Cons a _)->case a of Cons _ _ -> true; _ -> false )) $
   read "((#t . #t) (#f . #f))"

evalLoop str env = putStr ">" >> case parse partParser "" str of
  Left err -> print err
  Right (_,"") -> return ()
  Right (exp,rest) -> case runState (eval exp) env of (a,s) -> print a >> evalLoop rest s

main = do
  stdin<-getContents
  evalLoop stdin env

次回予定

evalをシンプルにする