「HaskellでLispを書く日記」を読む(2)

• 「HaskellでLispを書く日記 / evalの作成（変数編）

Lisp は定義された値をテーブルに登録し、それを検索しているようです。

import Text.ParserCombinators.Parsec

data Sexp = Nil | Symbol String | N Integer | Cons Sexp Sexp deriving Show

{-
リストの動作が見えるようにShowインスタンスは無効にする。
instance Show Sexp where
  show (Nil) = "()"
  show (N a) = show a
  show (Symbol a) = a
  show (Cons a b) = "(" ++ show a ++ showCdr b ++ ")"

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,"")]

sexpParser :: Parser Sexp
sexpParser = spaces >>
 (    do { string "("; listParser }
  <|> do { string "'"; a <- sexpParser; return (Cons (Symbol "quote")(Cons a Nil)) }
  <|> do { a<- many1 digit ; return (N (read a)) }
  <|> do { a<- many1 $ noneOf "'( )"; return (Symbol a) } )

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



env :: Sexp
env = read "((x . a) (y . b))"
-- S式の様子
-- Cons (Cons (Symbol "x") (Symbol "a"))(Cons (Cons (Symbol "y") (Symbol "b")) Nil)

-- リスプっぽくcar、cdr　を定義してみる。
car :: Sexp -> Sexp
car (Cons a _) = a

cdr :: Sexp -> Sexp
cdr (Cons _ b) = b

assoc :: String -> Sexp -> Sexp
assoc s Nil =  error ("unbound variable: " ++ show s)
-- assoc s (Cons (Cons (Symbol k) v) e) = if s==k then v else assoc s e
-- 検索する関数も car、cdr を使ってみる。
assoc s (Cons a b) = if s == fromSymbol (car a) 
                        then cdr a 
                        else assoc s b
                          where
                            fromSymbol :: Sexp -> String
                            fromSymbol (Symbol s) = s

eval :: Sexp -> Sexp -> Sexp
eval (Nil) env = Nil
eval (Symbol s) env = assoc s env
-- quote の eval は quote を外すだけ。
eval (Cons (Symbol "quote") (Cons a _)) _ = a

main = do
  print $ eval (read "x") env            -- > Symbol "a"
  print $ eval (read "y") env            -- > Symbol "b"
  -- print $ eval (read "z") env 
  -- *** Exception: unbound variable: "z"
  print $ eval (read "(quote foo)") env  -- > Symbol "foo"
  print $ eval (read "'foo") env         -- > Symbol "foo"
  print $ eval (read "()") env           -- > Nil

• car、cdr で env を操作した様子。

> env
Cons (Cons (Symbol "x") (Symbol "a")) (Cons (Cons (Symbol "y") (Symbol "b")) Nil)
> car env        -- > Cons (Symbol "x") (Symbol "a")
> cdr $ car env  -- > Symbol "a"
> car $ car env  -- > Symbol "x"

> cdr env             -- > Cons (Cons (Symbol "y") (Symbol "b")) Nil
> car $ cdr env       -- > Cons (Symbol "y") (Symbol "b")
> car $ car $ cdr env -- > Symbol "y"
> cdr $ car $ cdr env -- > Symbol "b"
>  cdr $ cdr env      -- >  Nil