簡易LISP処理系の実装例（Haskell版）

【他言語版へのリンク記事】[簡易LISP処理系の実装例【各言語版まとめ】](https://qiita.com/ytaki0801/items/dcb0fe48cbeab30ac40d)

この記事は，下記拙作記事のHaskell版を抜粋・修正したものを利用した，簡易LISP処理系（["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)）の実装例をまとめたものです．

* [『括弧文字列』簡易パーサ実装例まとめ](https://qiita.com/ytaki0801/items/b8d7d4c778fe98966ce5)
* [リスト処理関数（cons,car,cdr,eq,atom）実装例まとめ](https://qiita.com/ytaki0801/items/a11c8143c5c63a406c7f)（Haskell版は字句解析部のみ）

最低限の機能をもったLISP処理系の実装の場合，本体である評価器（eval）実装はとても簡単であり，むしろ，字句・構文解析を行うS式入出力やリスト処理実装の方が開発言語ごとの手間が多く，それが敷居になっている人向けにまとめています．

#処理系の概要
実行例は次の通り．GHC 8.4.4にて確認．

```haskell
$ ghci
GHCi, version 8.4.4: http://www.haskell.org/ghc/  :? for help
Prelude> :l jmclisp.hs
[1 of 1] Compiling Main             ( jmclisp.hs, interpreted )
Ok, one module loaded.
*Main> main
(car (cdr '(10 20 30)))

20
*Main> main
((lambda (x) (car (cdr x))) '(abc def ghi))

def
*Main> main
((lambda (f x y) (f x (f y '()))) 'cons '10 '20)

(10 20)
*Main> main
((lambda (f x y) (f x (f y '())))
'(lambda (x y) (cons x (cons y '())))
'10 '20)

(10 (20 ()))
*Main> main
((lambda (assoc k v) (assoc k v))
'(lambda (k v)
   (cond ((eq v '()) nil)
         ((eq (car (car v)) k)
          (car v))
         (t (assoc k (cdr v)))))
'Orange
'((Apple . 120) (Orange . 210) (Lemon . 180)))

(Orange . 210)
```

実装内容は次の通り．

* ["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)をベースにした評価器
* 数字を含むアトムは全てシンボルとし，変数の値とする場合は`quote`（`'`）を使用
* 構文として`quote`の他，`cond`と`lambda`が使用可能
* 組込関数：`atom` `eq` `cons` `car` `cdr`（内部でコンスセルを作成）
* 真偽値は`t`（真）および`nil`（偽）＝空リスト＝`()`
* エラーチェックなし，モジュール化なし，ガーベジコレクションなし

"McCarthy's Original Lisp"の詳細については[まとめ記事](https://qiita.com/ytaki0801/items/dcb0fe48cbeab30ac40d)を参照．ダイナミックスコープということもあり，実行例ではlambda式を`letrec`（Scheme）や`labels`（Common Lisp）などの代わりに使用しています．

#実装例

##ソースコード一式

```jmclisp.hs
--
-- JMC Lisp: defined in McCarthy's 1960 paper,
-- with S-expression input/output and basic list processing
--


-- basic list processing: cons, car, cdr, eq, atom
-- and S-expression output

data CELL = NIL | T | Sybl String | Pair CELL CELL

sStrcons :: CELL -> String
sStrcons (Pair x y) =
  case y of
    NIL      -> show x
    T        -> show x
    (Sybl a) -> show x ++ " . " ++ a
    _        -> show x ++  " "  ++ sStrcons y

instance Show CELL where
  show NIL      = "()"
  show T        = "t"
  show (Sybl x) = x
  show ss       = "(" ++ sStrcons ss ++ ")"

instance Eq CELL where
  NIL    == NIL    = True
  T      == T      = True
  Sybl x == Sybl y = x == y
  _      == _      = False

cons :: CELL -> CELL -> CELL
cons x y = Pair x y

car :: CELL -> CELL
car (Pair x _) = x

cdr :: CELL -> CELL
cdr (Pair _ y) = y

eq :: CELL -> CELL -> Bool
eq s1 s2 = s1 == s2

atom :: CELL -> Bool
atom s =
  case s of
    NIL      -> True
    T        -> True
    (Sybl s) -> True
    _        -> False


-- S-expression input: s_read

--- s_lex

s_replace :: String -> String
s_replace [] = ""
s_replace (c : s) =
  case c of
    '(' -> " ( "
    ')' -> " ) "
    '\'' -> " \' "
    _    -> [c]
  ++ s_replace s

s_lex :: String -> [String]
s_lex s = words $ s_replace s

--- s_syn

s_quote :: CELL -> [String] -> [(CELL, [String])]
s_quote x s
  | (not $ null s) && (last s == "\'")
    = [(cons (Sybl "quote") $ cons x NIL, init s)]
  | otherwise = [(x, s)]

s_syn0 :: CELL -> [String] -> [(CELL, [String])]
s_syn0 r s =
  let t  = last s
      ss = init s
  in case t of
       "(" -> do return (r, s)
       "." -> do (rr, rss) <- s_syn $ init s
                 c <- [cons rr $ car r]
                 (cr, css) <- s_syn0 c rss
                 return (cr, css)
       _   -> do (rr, rss) <- s_syn s
                 c <- [cons rr r]
                 (cr, css) <- s_syn0 c rss
                 return (cr, css)

s_syn :: [String] -> [(CELL, [String])]
s_syn s =
  let t  = last s
      ss = init s
  in case t of
       ")" -> do (r, ss) <- s_syn0 NIL ss
                 ss <- [init ss]
                 (r, ss) <- s_quote r ss
                 return (r, ss)
       _   -> do (t, ss) <- s_quote (Sybl t) ss
                 return (t, ss)

--- s_read

s_read :: String -> CELL
s_read s = r where [(r, _)] = s_syn $ s_lex s


-- JMC Lisp evaluator: s_eval

eq_ :: CELL -> CELL -> CELL
eq_ s1 s2 = if s1 == s2 then T else NIL

atom_ :: CELL -> CELL
atom_ s =
  case s of
    NIL      -> T
    T        -> T
    (Sybl s) -> T
    _        -> NIL

caar :: CELL -> CELL
caar x = (car (car x))

cadr :: CELL -> CELL
cadr x = (car (cdr x))

cadar :: CELL -> CELL
cadar x = (car (cdr (car x)))

caddr :: CELL -> CELL
caddr x = (car (cdr (cdr x)))

caddar :: CELL -> CELL
caddar x = (car (cdr (cdr (car x))))

s_append :: CELL -> CELL -> CELL
s_append x y
  | x == NIL  = y
  | otherwise = (cons (car x) (s_append (cdr x) y))

s_list :: CELL -> CELL -> CELL
s_list x y = (cons x (cons y NIL))

s_pair :: CELL -> CELL -> CELL
s_pair x y
  | x == NIL && y == NIL = NIL
  | not (atom x) && not (atom y)
    = (cons (s_list (car x) (car y)) (s_pair (cdr x) (cdr y)))

s_assoc :: CELL -> CELL -> CELL
s_assoc x y
  | (eq (caar y) x) = (cadar y)
  | otherwise       = (s_assoc x (cdr y))

s_eval :: CELL -> CELL -> CELL
s_eval e a =
  if      (eq e (Sybl "t"))   then T
  else if (eq e (Sybl "nil")) then NIL
  else if (atom e) then (s_assoc e a)
  else if (atom (car e)) then
    if      (eq (car e) (Sybl "quote")) then (cadr e)
    else if (eq (car e) (Sybl "atom"))  then (atom_ (s_eval (cadr e)  a))
    else if (eq (car e) (Sybl "eq"))    then (eq_   (s_eval (cadr e)  a)
                                                    (s_eval (caddr e) a))
    else if (eq (car e) (Sybl "car"))   then (car   (s_eval (cadr e)  a))
    else if (eq (car e) (Sybl "cdr"))   then (cdr   (s_eval (cadr e)  a))
    else if (eq (car e) (Sybl "cons"))  then (cons  (s_eval (cadr e)  a)
                                                    (s_eval (caddr e) a))
    else if (eq (car e) (Sybl "cond"))  then (evcon (cdr e) a)
    else (s_eval (cons (s_assoc (car e) a) (cdr e)) a)
  else if (eq (caar e) (Sybl "lambda")) then
          (s_eval (caddar e) (s_append (s_pair (cadar e) (evlis (cdr e) a)) a))
  else NIL

evcon :: CELL -> CELL -> CELL
evcon c a
  | (s_eval (caar c) a) == T = (s_eval (cadar c) a)
  | otherwise = (evcon (cdr c) a)

evlis :: CELL -> CELL -> CELL
evlis m a
  | m == NIL  = NIL
  | otherwise = (cons (s_eval (car m) a) (evlis (cdr m) a))


-- REP (no Loop): s_rep

s_rep e = (s_eval (s_read e) NIL)

getLines :: IO [String]
getLines = do
  s <- getLine
  if s == "" then return []
  else do
    ss <- getLines
    return (s : ss)

main = do
  r <- getLines
  let s = foldl (++) "" r
  print $ s_rep s
```

##解説

* リスト処理：`cons` `car` `cdr` `eq` `atom`（`Show`定義によるS式出力込）
[先の記事](https://qiita.com/ytaki0801/items/a11c8143c5c63a406c7f)からほとんどを抜粋．型制約を簡単にするため（具体的には，評価器`s_eval`の戻り値の型を，S式の型である`CELL`に統一するため），真偽値を`Bool`再定義ではなく`T`および`NIL`に設定（言語仕様上では`t`および`nil`=`()`）．

* S式入力：`s_read`
[先の記事](https://qiita.com/ytaki0801/items/b8d7d4c778fe98966ce5)から，字句解析部`s_lex`を`()`および`'`の識別に変更．抽象構文木生成部`s_syn`は新規に作成し，字句解析によって得られた文字列配列に対してリストモナドなどを使用して走査（スキャン）処理を行いながら，上記リスト処理で定義されたS式の型`CELL`および`cons`を用いてコンスセルに基づく構文木を生成．それらをまとめたS式入力関数`s_read`を定義．

* 評価器：`s_eval`＋ユーティリティ関数
["McCarthy's Original Lisp"](http://paulgraham.com/lispcode.html)をベースに`s_eval`関数およびユーティリティ関数を作成．オリジナルおよび他言語実装版との大きな違いは，Haskell上の真偽値を返す`eq` `atom`とは別に，`T` `NIL`を返す`eq_` `atom_`を別途定義し，`cond`などの言語実装上では，`T`か否かは`Eq`の`==`定義を用いて条件判断を行っていること．理由は，上記のリスト処理実装解説にある通り．

* REP (no Loop)：`s_rep`
`s_read`→`s_eval`をまとめた`s_rep`を定義．GHCiやプログラムファイル上では，二重引用符で囲んだ（LISP記述としての）文字列を複数行に分けて入力・記述することができないため，空行を入力するまで行単位の文字列入力をリストに蓄積するIOモナド`getLines`を定義，それをmain関数で結合して`s_rep`に渡すよう記述．

#備考

##記事に関する補足
* 評価器のみの場合，約95行／2500バイトほど．それ以外が約100行／2500バイトほどで，半々といったところ．もっとも，評価器については，オリジナルや他言語実装版との比較のため，わざとLISP並の括弧表現と冗長な条件分岐記述を行っているので，短くしようと思えばかなり短くできるかも．とはいえ，リスト処理／S式入力実装は数日（の間に時間を見つけてちょこちょこと）かかったのに対し，評価器については，真偽値の扱いの変更を含めても，実装に要した時間は数十分程度だったのだけれども．

##更新履歴
* 2020-09-17：`s_lex`を修正（別記事コメントより）
* 2020-09-16：初版公開