HaskellでLispを書く日記

■ 対話環境を作る

今回はdefineの処理を作ろうと思っていたのだが，考えてみたらdefineが意味を持つためには，

(define x '(a b c))

(car x)

のように，defineを行う式の入力と，defineされた変数を使う式の入力の両方が順番に処理される仕組みを作らなければならない。

今までは常に1つのS式を評価することしかやっていなかったので，まずは順番に入力された複数のS式を順番に評価していくことを出来るようにする。

具体的には，今までのghci等を利用する形を離れて，自前で標準入力からユーザの入力を受け取って処理するようにする。

partParser

複数のS式が入力にあたえられるので，最初のS式を取り出して評価した後で，その続きの部分から次のS式を読み込む必要がある。そこで，ここでは入力文字列の頭から取り出せたS式と，その時点での残りの入力文字列をセットにして返すパーサpartParserを新たに用意する。

また入力文字列の最後まで到達している場合はさらにsexpParserを呼び出すとパースエラーになってしまうので決めうちで(Nil,"")を返すようにする。

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

evalLoop

入力された複数のS式を順番に評価していくevalLoopを作る。

受け取る引数は入力文字列であるstrと評価をするときに使う環境env。

まず，パースエラー時はLeft型の値が返ってくるので，エラーを表示して終了する。

次に，入力を最後まで呼んでしまった場合は，残りの入力が""になっているので，何もしないで終了する。

それ以外の通常の場合は，取り出せたS式と残りの文字列がセットで返ってくるので，それぞれexpとrestで受けて，expを評価して結果を表示し，次の入力のプロンプト">"を表示し，残りの文字列restを引数にしてevalLoopを再帰呼び出しする。

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

main

今回はmainも標準入力から入力を受け取るように書き換える。

まずプロンプト">"を表示し，標準入力をstdinに入れた後で上記evalLoopをstdinを引数にして呼び出す。

main = do
  putStr ">"
  stdin<-getContents
  evalLoop stdin env

テスト

というわけで，今回はghciではなくてrunghcを使ってテストをする。

実行すると">"というプロンプトが出るので，その後に式を入力してEnterを押すと，それに対応する評価結果が次の行に表示されている。

また，最後の例のように，閉じかっこが来るまでは入力を受け続け，閉じかっこが入力された時に評価結果を表示している。

こういうことが出来るのがHaskellはいいなあ。

C:\haskell>runghc lisp.hs
>'(a b c)
(a b c)
>(cdr '(a b c))
(b c)
>(cons 'a 'b)
(a . b)
>(cons
'a
'b
)
(a . b)
>^Z
C:\haskell>runghc lisp.hs

今日までの全コード

import Text.ParserCombinators.Parsec

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) env = Nil
eval (Symbol s) env = assoc s env
eval (Cons (Symbol "quote") (Cons a _)) _ = a
eval (Cons (Symbol "lambda") body) env = Closure body env
eval (Cons (Symbol "if") (Cons p (Cons t (Cons e _)))) env = if eval p env /= false then eval t env else eval e env
eval (Cons fun arg) env = apply (eval fun env) (evals arg env)

evals (Cons a b) env = Cons (eval a env) (evals b env)
evals a env = eval a env

apply (Subr fun) arg = fun arg
apply (Closure (Cons var (Cons body _)) env) arg = 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 key val env = Cons (Cons (Symbol key) 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 = case parse partParser "" str of
  Left err -> print err
  Right (_,"") -> return ()
  Right (exp,rest) -> do
    print $ eval exp env
    putStr ">"
    evalLoop rest env

main = do
  putStr ">"
  stdin<-getContents
  evalLoop stdin env

次回予定

こんどこそdefineを作る