「Write Yourself a Scheme in 48 Hours」 を写経してみる(2)

HaskellでLispを書く日記を読んでいたのですけれども、私の能力では Cons のネストを追うのが大変なので、以前に写経した「『Write Yourself a Scheme in 48 Hours』を写経してみる」の続きをやってみます(こっちは出来ない英語なので大変なのですが)。
まず、入力した文字列のパースです。
パースとは何か、ここでは"( 123 'a')" のようなリストを示す文字列を本物のリストにすることです。

module Main where

import Monad
import System.Environment
import Text.ParserCombinators.Parsec hiding (spaces)

symbol :: Parser Char
symbol = oneOf "!$%&|*+-/:<=>?@^_~#"

readExpr input = case parse parseExpr "lisp" input of
    Left err  -> putStrLn $ "No match: " ++ show err
    Right val -> putStrLn $ "showVal:"++showVal val ++"\nshow   :"++ show val

retExpr input = case parse parseExpr "lisp" input of Right val -> val

spaces :: Parser ()
spaces = skipMany1 space

data LispVal = Atom String
             | List [LispVal]                -- List は LispVal のリスト。ネストしていても良い。
             | DottedList [LispVal] LispVal  -- (a b c . d) のようなリスト
             | Number Integer
             | String String
             | Bool Bool deriving Show

-- show と showVal を両方表示してみるので。
-- instance Show LispVal where show = showVal

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name)       = name
showVal (Number contents) = show contents
showVal (Bool True)       = "#t"
showVal (Bool False)      = "#f"
showVal (List contents)   = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal


parseString :: Parser LispVal
parseString = do char '"'
                 x <- many (noneOf "\"")
                 char '"'
                 return $ String x

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
               rest  <- many (letter <|> digit <|> symbol)
               let atom = [first] ++ rest
               return $ case atom of 
                          "#t" -> Bool True
                          "#f" -> Bool False
                          otherwise -> Atom atom

parseNumber :: Parser LispVal
parseNumber = liftM (Number . read) $ many1 digit

parseList :: Parser LispVal
parseList = liftM List $ sepBy parseExpr spaces

{- 
> parseTest parseList "(a b c . d)"
  --> List [DottedList [Atom "a",Atom "b",Atom "c"] (Atom "d")]
-}
parseDottedList :: Parser LispVal
parseDottedList = do
    head <- endBy parseExpr spaces
    tail <- char '.' >> spaces >> parseExpr
    return $ DottedList head tail

parseQuoted :: Parser LispVal
parseQuoted = do
    char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseExpr :: Parser LispVal
parseExpr = parseAtom
        <|> parseString
        <|> parseNumber
        <|> parseQuoted
        <|> do char '('
               x <- (try parseList) <|> parseDottedList
               char ')'
               return x

パースした結果の内部データを表示してみます。

> retExpr  "a"               -- > Atom "a"
> retExpr  "\"Hello\""     -- > String "Hello"
> retExpr  "123"             -- > Number 123
> retExpr  "(abc def)"       -- > List [Atom "abc",Atom "def"]
> retExpr  "(abc def . ghi)" -- > DottedList [Atom "abc",Atom "def"] (Atom "ghi")
> retExpr  "'(1 '(a b))"
-- > List [Atom "quote",List [Number 1,List [Atom "quote",List [Atom "a",Atom "b"]]]]

内部データを showVal を適用させて表示。実際はコメントにした instance Show LispVal where show = showVal によりS式が表示されます。

> let (List xs) = retExpr "'(1 2 abc)"
> map showVal xs           -- > ["quote","(1 2 abc)"]
> unwords $ map showVal xs -- > "quote (1 2 abc)"

パースした結果の内部データを表示するための sohwVal が追加されているので両方表示してみます。

> readExpr  "\"Hello,world\""
showVal:"Hello,world"         -- 上段:S式表示
show   :String "Hello,world"  -- 下段:内部のLispVal型

> readExpr  "atom"
showVal:atom
show   :Atom "atom"

> readExpr  "123"
showVal:123
show   :Number 123

> readExpr  "(123 #t #f (nest abc))"
showVal:(123 #t #f (nest abc))
show   :List [Number 123,Bool True,Bool False,List [Atom "nest",Atom "abc"]]

> readExpr  "(dotted list . 123)"
showVal:(dotted list . 123)
show   :DottedList [Atom "dotted",Atom "list"] (Number 123)